dist/Devel-PPPort/parts/ppptools.pl

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