cpan/Devel-PPPort/parts/ppptools.pl

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