cpan/Devel-PPPort/parts/ppptools.pl

   1 ################################################################################
   2 #
   3 #  ppptools.pl -- various utility functions
   4 #
   5 ################################################################################
   6 #
   7 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   8 #  Version 2.x, Copyright (C) 2001, Paul Marquess.
   9 #  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
  10 #
  11 #  This program is free software; you can redistribute it and/or
  12 #  modify it under the same terms as Perl itself.
  13 #
  14 ################################################################################
  15
  16 sub cat_file
  17 {
  18   eval { require File::Spec };
  19   return $@ ? join('/', @_) : File::Spec->catfile(@_);
  20 }
  21
  22 sub all_files_in_dir
  23 {
  24   my $dir = shift;
  25   local *DIR;
  26
  27   opendir DIR, $dir or die "cannot open directory $dir: $!\n";
  28   my @files = grep { !-d && !/^\./ } readdir DIR;  # no dirs or hidden files
  29   closedir DIR;
  30
  31   return map { cat_file($dir, $_) } sort @files;
  32 }
  33
  34 sub parse_todo
  35 {
  36   my $dir = shift || 'parts/todo';
  37   local *TODO;
  38   my %todo;
  39   my $todo;
  40
  41   for $todo (all_files_in_dir($dir)) {
  42     open TODO, $todo or die "cannot open $todo: $!\n";
  43     my $perl = <TODO>;
  44     chomp $perl;
  45     while (<TODO>) {
  46       chomp;
  47       s/#.*//;
  48       s/^\s+//; s/\s+$//;
  49       /^\s*$/ and next;
  50       /^\w+$/ or die "invalid identifier: $_\n";
  51       exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $perl)\n";
  52       $todo{$_} = $perl;
  53     }
  54     close TODO;
  55   }
  56
  57   return \%todo;
  58 }
  59
  60 sub expand_version
  61 {
  62   my($op, $ver) = @_;
  63   my($r, $v, $s) = parse_version($ver);
  64   $r == 5 or die "only Perl revision 5 is supported\n";
  65   my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s;
  66   return "(PERL_BCDVERSION $op $bcdver)";
  67 }
  68
  69 sub parse_partspec
  70 {
  71   my $file = shift;
  72   my $section = 'implementation';
  73   my $vsec = join '|', qw( provides dontwarn implementation
  74                            xsubs xsinit xsmisc xshead xsboot tests );
  75   my(%data, %options);
  76   local *F;
  77
  78   open F, $file or die "$file: $!\n";
  79   while (<F>) {
  80     /[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n";
  81     if ($section eq 'implementation') {
  82       m!//! && !m!(?:=~|s/).*//! && !m!(?:ht|f)tp(?:s)://!
  83           and warn "$file:$.: warning: potential C++ comment\n";
  84     }
  85     /^##/ and next;
  86     if (/^=($vsec)(?:\s+(.*))?/) {
  87       $section = $1;
  88       if (defined $2) {
  89         my $opt = $2;
  90         $options{$section} = eval "{ $opt }";
  91         $@ and die "$file:$.: invalid options ($opt) in section $section: $@\n";
  92       }
  93       next;
  94     }
  95     push @{$data{$section}}, $_;
  96   }
  97   close F;
  98
  99   for (keys %data) {
 100     my @v = @{$data{$_}};
 101     shift @v while @v && $v[0]  =~ /^\s*$/;
 102     pop   @v while @v && $v[-1] =~ /^\s*$/;
 103     $data{$_} = join '', @v;
 104   }
 105
 106   unless (exists $data{provides}) {
 107     $data{provides} = ($file =~ /(\w+)\.?$/)[0];
 108   }
 109   $data{provides} = [$data{provides} =~ /(\S+)/g];
 110
 111   if (exists $data{dontwarn}) {
 112     $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
 113   }
 114
 115   my @prov;
 116   my %proto;
 117
 118   if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) {
 119     $data{implementation} = '';
 120   }
 121   else {
 122     $data{implementation} =~ /\S/ or die "Empty implementation in $file\n";
 123
 124     my $p;
 125
 126     for $p (@{$data{provides}}) {
 127       if ($p =~ m#^/.*/\w*$#) {
 128         my @tmp = eval "\$data{implementation} =~ ${p}gm";
 129         $@ and die "invalid regex $p in $file\n";
 130         @tmp or warn "no matches for regex $p in $file\n";
 131         push @prov, do { my %h; grep !$h{$_}++, @tmp };
 132       }
 133       elsif ($p eq '__UNDEFINED__') {
 134         my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm;
 135         @tmp or warn "no __UNDEFINED__ macros in $file\n";
 136         push @prov, @tmp;
 137       }
 138       else {
 139         push @prov, $p;
 140       }
 141     }
 142
 143     for (@prov) {
 144       if ($data{implementation} !~ /\b\Q$_\E\b/) {
 145         warn "$file claims to provide $_, but doesn't seem to do so\n";
 146         next;
 147       }
 148
 149       # scan for prototypes
 150       my($proto) = $data{implementation} =~ /
 151                    ( ^ (?:[\w*]|[^\S\r\n])+
 152                        [\r\n]*?
 153                      ^ \b$_\b \s*
 154                        \( [^{]* \)
 155                    )
 156                        \s* \{
 157                    /xm or next;
 158
 159       $proto =~ s/^\s+//;
 160       $proto =~ s/\s+$//;
 161       $proto =~ s/\s+/ /g;
 162
 163       exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
 164       $proto{$_} = $proto;
 165     }
 166   }
 167
 168   for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) {
 169     if (exists $data{$section}) {
 170       $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei;
 171     }
 172   }
 173
 174   $data{provides}   = \@prov;
 175   $data{prototypes} = \%proto;
 176   $data{OPTIONS}    = \%options;
 177
 178   my %prov     = map { ($_ => 1) } @prov;
 179   my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
 180   my @maybeprov = do { my %h;
 181                        grep {
 182                          my($nop) = /^Perl_(.*)/;
 183                          not exists $prov{$_}                         ||
 184                              exists $dontwarn{$_}                     ||
 185                              /^D_PPP_/                                ||
 186                              (defined $nop && exists $prov{$nop}    ) ||
 187                              (defined $nop && exists $dontwarn{$nop}) ||
 188                              $h{$_}++;
 189                        }
 190                        $data{implementation} =~ /^\s*#\s*define\s+(\w+)/gm };
 191
 192   if (@maybeprov) {
 193     warn "$file seems to provide these macros, but doesn't list them:\n  "
 194          . join("\n  ", @maybeprov) . "\n";
 195   }
 196
 197   return \%data;
 198 }
 199
 200 sub compare_prototypes
 201 {
 202   my($p1, $p2) = @_;
 203   for ($p1, $p2) {
 204     s/^\s+//;
 205     s/\s+$//;
 206     s/\s+/ /g;
 207     s/(\w)\s(\W)/$1$2/g;
 208     s/(\W)\s(\w)/$1$2/g;
 209   }
 210   return $p1 cmp $p2;
 211 }
 212
 213 sub ppcond
 214 {
 215   my $s = shift;
 216   my @c;
 217   my $p;
 218
 219   for $p (@$s) {
 220     push @c, map "!($_)", @{$p->{pre}};
 221     defined $p->{cur} and push @c, "($p->{cur})";
 222   }
 223
 224   join " && ", @c;
 225 }
 226
 227 sub trim_arg
 228 {
 229   my $in = shift;
 230   my $remove = join '|', qw( NN NULLOK VOL );
 231
 232   $in eq '...' and return ($in);
 233
 234   local $_ = $in;
 235   my $id;
 236
 237   s/[*()]/ /g;
 238   s/\[[^\]]*\]/ /g;
 239   s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
 240   s/\b(?:$remove)\b//;
 241   s/^\s*//; s/\s*$//;
 242
 243   if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) {
 244     defined $1 and $id = $1;
 245   }
 246   else {
 247     if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
 248       /^\s*(\w+)\s*$/ and $id = $1;
 249     }
 250     else {
 251       /^\s*\w+\s+(\w+)\s*$/ and $id = $1;
 252     }
 253   }
 254
 255   $_ = $in;
 256
 257   defined $id and s/\b$id\b//;
 258
 259   # these don't matter at all
 260   s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
 261   s/\b(?:$remove)\b//;
 262
 263   s/(?=<\*)\s+(?=\*)//g;
 264   s/\s*(\*+)\s*/ $1 /g;
 265   s/^\s*//; s/\s*$//;
 266   s/\s+/ /g;
 267
 268   return ($_, $id);
 269 }
 270
 271 sub parse_embed
 272 {
 273   my @files = @_;
 274   my @func;
 275   my @pps;
 276   my $file;
 277   local *FILE;
 278
 279   for $file (@files) {
 280     open FILE, $file or die "$file: $!\n";
 281     my($line, $l);
 282
 283     while (defined($line = <FILE>)) {
 284       while ($line =~ /\\$/ && defined($l = <FILE>)) {
 285         $line =~ s/\\\s*//;
 286         $line .= $l;
 287       }
 288       next if $line =~ /^\s*:/;
 289       $line =~ s/^\s+|\s+$//gs;
 290       my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/);
 291       if (defined $dir and defined $args) {
 292         for ($dir) {
 293           /^ifdef$/   and do { push @pps, { pre => [], cur => "defined($args)"  }         ; last };
 294           /^ifndef$/  and do { push @pps, { pre => [], cur => "!defined($args)" }         ; last };
 295           /^if$/      and do { push @pps, { pre => [], cur => $args             }         ; last };
 296           /^elif$/    and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
 297           /^else$/    and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
 298           /^endif$/   and do { pop @pps                                                   ; last };
 299           /^include$/ and last;
 300           /^define$/  and last;
 301           /^undef$/   and last;
 302           warn "unhandled preprocessor directive: $dir\n";
 303         }
 304       }
 305       else {
 306         my @e = split /\s*\|\s*/, $line;
 307         if( @e >= 3 ) {
 308           my($flags, $ret, $name, @args) = @e;
 309           if ($name =~ /^[^\W\d]\w*$/) {
 310             for (@args) {
 311               $_ = [trim_arg($_)];
 312             }
 313             ($ret) = trim_arg($ret);
 314             push @func, {
 315               name  => $name,
 316               flags => { map { $_, 1 } $flags =~ /./g },
 317               ret   => $ret,
 318               args  => \@args,
 319               cond  => ppcond(\@pps),
 320             };
 321           }
 322           elsif ($name =~ /^[^\W\d]\w*-E<gt>[^\W\d]\w*$/) {
 323             # silenty ignore entries of the form
 324             #    PL_parser-E<gt>linestr
 325             # which documents a struct entry rather than a function
 326           }
 327           else {
 328             warn "mysterious name [$name] in $file, line $.\n";
 329           }
 330         }
 331       }
 332     }
 333
 334     close FILE;
 335   }
 336
 337   return @func;
 338 }
 339
 340 sub make_prototype
 341 {
 342   my $f = shift;
 343   my @args = map { "@$_" } @{$f->{args}};
 344   my $proto;
 345   my $pTHX_ = exists $f->{flags}{n} ? "" : "pTHX_ ";
 346   $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
 347   return $proto;
 348 }
 349
 350 sub format_version
 351 {
 352   my $ver = shift;
 353
 354   $ver =~ s/$/000000/;
 355   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
 356
 357   $v = int $v;
 358   $s = int $s;
 359
 360   if ($r < 5 || ($r == 5 && $v < 6)) {
 361     if ($s % 10) {
 362       die "invalid version '$ver'\n";
 363     }
 364     $s /= 10;
 365
 366     $ver = sprintf "%d.%03d", $r, $v;
 367     $s > 0 and $ver .= sprintf "_%02d", $s;
 368
 369     return $ver;
 370   }
 371
 372   return sprintf "%d.%d.%d", $r, $v, $s;
 373 }
 374
 375 sub parse_version
 376 {
 377   my $ver = shift;
 378
 379   if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
 380     return ($1, $2, $3);
 381   }
 382   elsif ($ver !~ /^\d+\.[\d_]+$/) {
 383     die "cannot parse version '$ver'\n";
 384   }
 385
 386   $ver =~ s/_//g;
 387   $ver =~ s/$/000000/;
 388
 389   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
 390
 391   $v = int $v;
 392   $s = int $s;
 393
 394   if ($r < 5 || ($r == 5 && $v < 6)) {
 395     if ($s % 10) {
 396       die "cannot parse version '$ver'\n";
 397     }
 398     $s /= 10;
 399   }
 400
 401   return ($r, $v, $s);
 402 }
 403
 404 1;