ext/Devel/PPPort/parts/ppptools.pl

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