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     else {
 262       /^ \s* \w+ \s+ (\w+) \s* $/x and $name = $1; # Everything else.
 263     }
 264   }
 265
 266   $_ = $in;     # Now work on the type.
 267
 268   # Get rid of the name if we found one
 269   defined $name and s/\b$name\b//;
 270
 271   # these don't matter at all; note that const does matter
 272   s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
 273   s/\b(?:$remove)\b//;
 274
 275   s/ (?=<\*) \s+ (?=\*) //xg;   # No spaces in pointer sequences
 276   s/ \s* ( \*+ ) \s* / $1 /xg;  # Normalize pointer sequences to be surrounded
 277                                 # by a single space
 278   s/^\s+//; s/\s+$//;           # No leading, trailing spacd
 279   s/\s+/ /g;                    # Collapse multiple space into one
 280
 281   return ($_, $name);
 282 }
 283
 284 sub parse_embed
 285 {
 286   my @files = @_;
 287   my @func;
 288   my @pps;
 289   my $file;
 290   local *FILE;
 291
 292   for $file (@files) {
 293     open FILE, $file or die "$file: $!\n";
 294     my($line, $l);
 295
 296     while (defined($line = <FILE>)) {
 297       while ($line =~ /\\$/ && defined($l = <FILE>)) {
 298         $line =~ s/\\\s*//;
 299         $line .= $l;
 300       }
 301       next if $line =~ /^\s*:/;
 302       $line =~ s/^\s+|\s+$//gs;
 303       my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/);
 304       if (defined $dir and defined $args) {
 305         for ($dir) {
 306           /^ifdef$/   and do { push @pps, { pre => [], cur => "defined($args)"  }         ; last };
 307           /^ifndef$/  and do { push @pps, { pre => [], cur => "!defined($args)" }         ; last };
 308           /^if$/      and do { push @pps, { pre => [], cur => $args             }         ; last };
 309           /^elif$/    and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
 310           /^else$/    and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
 311           /^endif$/   and do { pop @pps                                                   ; last };
 312           /^include$/ and last;
 313           /^define$/  and last;
 314           /^undef$/   and last;
 315           warn "unhandled preprocessor directive: $dir\n";
 316         }
 317       }
 318       else {
 319         my @e = split /\s*\|\s*/, $line;
 320         if( @e >= 3 ) {
 321           my($flags, $ret, $name, @args) = @e;
 322
 323           # Skip non-name entries, like
 324           #    PL_parser-E<gt>linestr
 325           # which documents a struct entry rather than a function.  We retain
 326           # all other entries, so that our caller has full information, and
 327           # may skip things like non-public functions.
 328           next if $flags =~ /N/;
 329           if ($name =~ /^[^\W\d]\w*$/) {
 330             for (@args) {
 331               $_ = [trim_arg($_)];
 332             }
 333             ($ret) = trim_arg($ret);
 334             push @func, {
 335               name  => $name,
 336               flags => { map { $_, 1 } $flags =~ /./g },
 337               ret   => $ret,
 338               args  => \@args,
 339               cond  => ppcond(\@pps),
 340             };
 341           }
 342           else {
 343             warn "mysterious name [$name] in $file, line $.\n";
 344           }
 345         }
 346       }
 347     }
 348
 349     close FILE;
 350   }
 351
 352   # Here's what two elements of the array look like:
 353   # {
 354   #              'args' => [
 355   #                          [
 356   #                            'const nl_item',
 357   #                            'item'
 358   #                          ]
 359   #                        ],
 360   #              'cond' => '(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))',
 361   #              'flags' => {
 362   #                           'A' => 1,
 363   #                           'T' => 1,
 364   #                           'd' => 1,
 365   #                           'o' => 1
 366   #                         },
 367   #              'name' => 'Perl_langinfo',
 368   #              'ret' => 'const char *'
 369   #            },
 370   #            {
 371   #              'args' => [
 372   #                          [
 373   #                            'const int',
 374   #                            'item'
 375   #                          ]
 376   #                        ],
 377   #              'cond' => '!(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))',
 378   #              'flags' => {
 379   #                           'A' => 1,
 380   #                           'T' => 1,
 381   #                           'd' => 1,
 382   #                           'o' => 1
 383   #                         },
 384   #              'name' => 'Perl_langinfo',
 385   #              'ret' => 'const char *'
 386   #            },
 387
 388   return @func;
 389 }
 390
 391 sub normalize_prototype  # So that they can be compared more easily
 392 {
 393     my $proto = shift;
 394     $proto =~ s/\s* \* \s* / * /xg;
 395     return $proto;
 396 }
 397
 398 sub make_prototype
 399 {
 400   my $f = shift;
 401   my @args = map { "@$_" } @{$f->{args}};
 402   my $proto;
 403   my $pTHX_ = exists $f->{flags}{T} ? "" : "pTHX_ ";
 404   $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
 405   return normalize_prototype($proto);
 406 }
 407
 408 sub format_version
 409 {
 410   my $ver = shift;
 411
 412   $ver =~ s/$/000000/;
 413   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
 414
 415   $v = int $v;
 416   $s = int $s;
 417
 418   if ($r < 5 || ($r == 5 && $v < 6)) {
 419     if ($s % 10) {
 420       die "invalid version '$ver'\n";
 421     }
 422     $s /= 10;
 423
 424     $ver = sprintf "%d.%03d", $r, $v;
 425     $s > 0 and $ver .= sprintf "_%02d", $s;
 426
 427     return $ver;
 428   }
 429
 430   return sprintf "%d.%d.%d", $r, $v, $s;
 431 }
 432
 433 sub parse_version
 434 {
 435   my $ver = shift;
 436
 437   if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
 438     return ($1, $2, $3);
 439   }
 440   elsif ($ver !~ /^\d+\.\d{3}(?:_\d{2})?$/) {
 441     die "cannot parse version '$ver'\n";
 442   }
 443
 444   $ver =~ s/_//g;
 445   $ver =~ s/$/000000/;
 446
 447   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
 448
 449   $v = int $v;
 450   $s = int $s;
 451
 452   if ($r < 5 || ($r == 5 && $v < 6)) {
 453     if ($s % 10) {
 454       die "cannot parse version '$ver'\n";
 455     }
 456     $s /= 10;
 457   }
 458
 459   return ($r, $v, $s);
 460 }
 461
 462 1;