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