ext/Devel/PPPort/parts/ppptools.pl

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