dist/Devel-PPPort/parts/inc/ppphbin

   1 ################################################################################
   2 ##
   3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
   4 ##  Version 2.x, Copyright (C) 2001, Paul Marquess.
   5 ##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
   6 ##
   7 ##  This program is free software; you can redistribute it and/or
   8 ##  modify it under the same terms as Perl itself.
   9 ##
  10 ################################################################################
  11
  12 =provides
  13
  14 =implementation
  15
  16 use strict;
  17
  18 # Disable broken TRIE-optimization
  19 BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= 5.009004 && "$]" <= 5.009005 }
  20
  21 my $VERSION = __VERSION__;
  22
  23 my %opt = (
  24   quiet     => 0,
  25   diag      => 1,
  26   hints     => 1,
  27   changes   => 1,
  28   cplusplus => 0,
  29   filter    => 1,
  30   strip     => 0,
  31   version   => 0,
  32 );
  33
  34 my($ppport) = $0 =~ /([\w.]+)$/;
  35 my $LF = '(?:\r\n|[\r\n])';   # line feed
  36 my $HS = "[ \t]";             # horizontal whitespace
  37
  38 # Never use C comments in this file!
  39 my $ccs  = '/'.'*';
  40 my $cce  = '*'.'/';
  41 my $rccs = quotemeta $ccs;
  42 my $rcce = quotemeta $cce;
  43
  44 eval {
  45   require Getopt::Long;
  46   Getopt::Long::GetOptions(\%opt, qw(
  47     help quiet diag! filter! hints! changes! cplusplus strip version
  48     patch=s copy=s diff=s compat-version=s
  49     list-provided list-unsupported api-info=s
  50   )) or usage();
  51 };
  52
  53 if ($@ and grep /^-/, @ARGV) {
  54   usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
  55   die "Getopt::Long not found. Please don't use any options.\n";
  56 }
  57
  58 if ($opt{version}) {
  59   print "This is $0 $VERSION.\n";
  60   exit 0;
  61 }
  62
  63 usage() if $opt{help};
  64 strip() if $opt{strip};
  65
  66 if (exists $opt{'compat-version'}) {
  67   my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
  68   if ($@) {
  69     die "Invalid version number format: '$opt{'compat-version'}'\n";
  70   }
  71   die "Only Perl 5 is supported\n" if $r != 5;
  72   die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
  73   $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
  74 }
  75 else {
  76   $opt{'compat-version'} = 5;
  77 }
  78
  79 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
  80                 ? ( $1 => {
  81                       ($2                  ? ( base     => $2 ) : ()),
  82                       ($3                  ? ( todo     => $3 ) : ()),
  83                       (index($4, 'v') >= 0 ? ( varargs  => 1  ) : ()),
  84                       (index($4, 'p') >= 0 ? ( provided => 1  ) : ()),
  85                       (index($4, 'n') >= 0 ? ( nothxarg => 1  ) : ()),
  86                     } )
  87                 : die "invalid spec: $_" } qw(
  88 __PERL_API__
  89 );
  90
  91 if (exists $opt{'list-unsupported'}) {
  92   my $f;
  93   for $f (sort { lc $a cmp lc $b } keys %API) {
  94     next unless $API{$f}{todo};
  95     print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
  96   }
  97   exit 0;
  98 }
  99
 100 # Scan for possible replacement candidates
 101
 102 my(%replace, %need, %hints, %warnings, %depends);
 103 my $replace = 0;
 104 my($hint, $define, $function);
 105
 106 sub find_api
 107 {
 108   my $code = shift;
 109   $code =~ s{
 110     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
 111   | "[^"\\]*(?:\\.[^"\\]*)*"
 112   | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
 113   grep { exists $API{$_} } $code =~ /(\w+)/mg;
 114 }
 115
 116 while (<DATA>) {
 117   if ($hint) {
 118     my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
 119     if (m{^\s*\*\s(.*?)\s*$}) {
 120       for (@{$hint->[1]}) {
 121         $h->{$_} ||= '';  # suppress warning with older perls
 122         $h->{$_} .= "$1\n";
 123       }
 124     }
 125     else { undef $hint }
 126   }
 127
 128   $hint = [$1, [split /,?\s+/, $2]]
 129       if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$};
 130
 131   if ($define) {
 132     if ($define->[1] =~ /\\$/) {
 133       $define->[1] .= $_;
 134     }
 135     else {
 136       if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
 137         my @n = find_api($define->[1]);
 138         push @{$depends{$define->[0]}}, @n if @n
 139       }
 140       undef $define;
 141     }
 142   }
 143
 144   $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
 145
 146   if ($function) {
 147     if (/^}/) {
 148       if (exists $API{$function->[0]}) {
 149         my @n = find_api($function->[1]);
 150         push @{$depends{$function->[0]}}, @n if @n
 151       }
 152       undef $function;
 153     }
 154     else {
 155       $function->[1] .= $_;
 156     }
 157   }
 158
 159   $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
 160
 161   $replace     = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
 162   $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
 163   $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
 164   $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
 165
 166   if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
 167     my @deps = map { s/\s+//g; $_ } split /,/, $3;
 168     my $d;
 169     for $d (map { s/\s+//g; $_ } split /,/, $1) {
 170       push @{$depends{$d}}, @deps;
 171     }
 172   }
 173
 174   $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
 175 }
 176
 177 for (values %depends) {
 178   my %s;
 179   $_ = [sort grep !$s{$_}++, @$_];
 180 }
 181
 182 if (exists $opt{'api-info'}) {
 183   my $f;
 184   my $count = 0;
 185   my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
 186   for $f (sort { lc $a cmp lc $b } keys %API) {
 187     next unless $f =~ /$match/;
 188     print "\n=== $f ===\n\n";
 189     my $info = 0;
 190     if ($API{$f}{base} || $API{$f}{todo}) {
 191       my $base = format_version($API{$f}{base} || $API{$f}{todo});
 192       print "Supported at least starting from perl-$base.\n";
 193       $info++;
 194     }
 195     if ($API{$f}{provided}) {
 196       my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__";
 197       print "Support by $ppport provided back to perl-$todo.\n";
 198       print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
 199       print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
 200       print "\n$hints{$f}" if exists $hints{$f};
 201       print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
 202       $info++;
 203     }
 204     print "No portability information available.\n" unless $info;
 205     $count++;
 206   }
 207   $count or print "Found no API matching '$opt{'api-info'}'.";
 208   print "\n";
 209   exit 0;
 210 }
 211
 212 if (exists $opt{'list-provided'}) {
 213   my $f;
 214   for $f (sort { lc $a cmp lc $b } keys %API) {
 215     next unless $API{$f}{provided};
 216     my @flags;
 217     push @flags, 'explicit' if exists $need{$f};
 218     push @flags, 'depend'   if exists $depends{$f};
 219     push @flags, 'hint'     if exists $hints{$f};
 220     push @flags, 'warning'  if exists $warnings{$f};
 221     my $flags = @flags ? '  ['.join(', ', @flags).']' : '';
 222     print "$f$flags\n";
 223   }
 224   exit 0;
 225 }
 226
 227 my @files;
 228 my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
 229 my $srcext = join '|', map { quotemeta $_ } @srcext;
 230
 231 if (@ARGV) {
 232   my %seen;
 233   for (@ARGV) {
 234     if (-e) {
 235       if (-f) {
 236         push @files, $_ unless $seen{$_}++;
 237       }
 238       else { warn "'$_' is not a file.\n" }
 239     }
 240     else {
 241       my @new = grep { -f } glob $_
 242           or warn "'$_' does not exist.\n";
 243       push @files, grep { !$seen{$_}++ } @new;
 244     }
 245   }
 246 }
 247 else {
 248   eval {
 249     require File::Find;
 250     File::Find::find(sub {
 251       $File::Find::name =~ /($srcext)$/i
 252           and push @files, $File::Find::name;
 253     }, '.');
 254   };
 255   if ($@) {
 256     @files = map { glob "*$_" } @srcext;
 257   }
 258 }
 259
 260 if (!@ARGV || $opt{filter}) {
 261   my(@in, @out);
 262   my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
 263   for (@files) {
 264     my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
 265     push @{ $out ? \@out : \@in }, $_;
 266   }
 267   if (@ARGV && @out) {
 268     warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
 269   }
 270   @files = @in;
 271 }
 272
 273 die "No input files given!\n" unless @files;
 274
 275 my(%files, %global, %revreplace);
 276 %revreplace = reverse %replace;
 277 my $filename;
 278 my $patch_opened = 0;
 279
 280 for $filename (@files) {
 281   unless (open IN, "<$filename") {
 282     warn "Unable to read from $filename: $!\n";
 283     next;
 284   }
 285
 286   info("Scanning $filename ...");
 287
 288   my $c = do { local $/; <IN> };
 289   close IN;
 290
 291   my %file = (orig => $c, changes => 0);
 292
 293   # Temporarily remove C/XS comments and strings from the code
 294   my @ccom;
 295
 296   $c =~ s{
 297     ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
 298     | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
 299   | ( ^$HS*\#[^\r\n]*
 300     | "[^"\\]*(?:\\.[^"\\]*)*"
 301     | '[^'\\]*(?:\\.[^'\\]*)*'
 302     | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
 303   }{ defined $2 and push @ccom, $2;
 304      defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
 305
 306   $file{ccom} = \@ccom;
 307   $file{code} = $c;
 308   $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
 309
 310   my $func;
 311
 312   for $func (keys %API) {
 313     my $match = $func;
 314     $match .= "|$revreplace{$func}" if exists $revreplace{$func};
 315     if ($c =~ /\b(?:Perl_)?($match)\b/) {
 316       $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
 317       $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
 318       if (exists $API{$func}{provided}) {
 319         $file{uses_provided}{$func}++;
 320         if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
 321           $file{uses}{$func}++;
 322           my @deps = rec_depend($func);
 323           if (@deps) {
 324             $file{uses_deps}{$func} = \@deps;
 325             for (@deps) {
 326               $file{uses}{$_} = 0 unless exists $file{uses}{$_};
 327             }
 328           }
 329           for ($func, @deps) {
 330             $file{needs}{$_} = 'static' if exists $need{$_};
 331           }
 332         }
 333       }
 334       if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
 335         if ($c =~ /\b$func\b/) {
 336           $file{uses_todo}{$func}++;
 337         }
 338       }
 339     }
 340   }
 341
 342   while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
 343     if (exists $need{$2}) {
 344       $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
 345     }
 346     else { warning("Possibly wrong #define $1 in $filename") }
 347   }
 348
 349   for (qw(uses needs uses_todo needed_global needed_static)) {
 350     for $func (keys %{$file{$_}}) {
 351       push @{$global{$_}{$func}}, $filename;
 352     }
 353   }
 354
 355   $files{$filename} = \%file;
 356 }
 357
 358 # Globally resolve NEED_'s
 359 my $need;
 360 for $need (keys %{$global{needs}}) {
 361   if (@{$global{needs}{$need}} > 1) {
 362     my @targets = @{$global{needs}{$need}};
 363     my @t = grep $files{$_}{needed_global}{$need}, @targets;
 364     @targets = @t if @t;
 365     @t = grep /\.xs$/i, @targets;
 366     @targets = @t if @t;
 367     my $target = shift @targets;
 368     $files{$target}{needs}{$need} = 'global';
 369     for (@{$global{needs}{$need}}) {
 370       $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
 371     }
 372   }
 373 }
 374
 375 for $filename (@files) {
 376   exists $files{$filename} or next;
 377
 378   info("=== Analyzing $filename ===");
 379
 380   my %file = %{$files{$filename}};
 381   my $func;
 382   my $c = $file{code};
 383   my $warnings = 0;
 384
 385   for $func (sort keys %{$file{uses_Perl}}) {
 386     if ($API{$func}{varargs}) {
 387       unless ($API{$func}{nothxarg}) {
 388         my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
 389                               { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
 390         if ($changes) {
 391           warning("Doesn't pass interpreter argument aTHX to Perl_$func");
 392           $file{changes} += $changes;
 393         }
 394       }
 395     }
 396     else {
 397       warning("Uses Perl_$func instead of $func");
 398       $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
 399                                 {$func$1(}g);
 400     }
 401   }
 402
 403   for $func (sort keys %{$file{uses_replace}}) {
 404     warning("Uses $func instead of $replace{$func}");
 405     $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
 406   }
 407
 408   for $func (sort keys %{$file{uses_provided}}) {
 409     if ($file{uses}{$func}) {
 410       if (exists $file{uses_deps}{$func}) {
 411         diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
 412       }
 413       else {
 414         diag("Uses $func");
 415       }
 416     }
 417     $warnings += hint($func);
 418   }
 419
 420   unless ($opt{quiet}) {
 421     for $func (sort keys %{$file{uses_todo}}) {
 422       print "*** WARNING: Uses $func, which may not be portable below perl ",
 423             format_version($API{$func}{todo}), ", even with '$ppport'\n";
 424       $warnings++;
 425     }
 426   }
 427
 428   for $func (sort keys %{$file{needed_static}}) {
 429     my $message = '';
 430     if (not exists $file{uses}{$func}) {
 431       $message = "No need to define NEED_$func if $func is never used";
 432     }
 433     elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
 434       $message = "No need to define NEED_$func when already needed globally";
 435     }
 436     if ($message) {
 437       diag($message);
 438       $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
 439     }
 440   }
 441
 442   for $func (sort keys %{$file{needed_global}}) {
 443     my $message = '';
 444     if (not exists $global{uses}{$func}) {
 445       $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
 446     }
 447     elsif (exists $file{needs}{$func}) {
 448       if ($file{needs}{$func} eq 'extern') {
 449         $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
 450       }
 451       elsif ($file{needs}{$func} eq 'static') {
 452         $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
 453       }
 454     }
 455     if ($message) {
 456       diag($message);
 457       $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
 458     }
 459   }
 460
 461   $file{needs_inc_ppport} = keys %{$file{uses}};
 462
 463   if ($file{needs_inc_ppport}) {
 464     my $pp = '';
 465
 466     for $func (sort keys %{$file{needs}}) {
 467       my $type = $file{needs}{$func};
 468       next if $type eq 'extern';
 469       my $suffix = $type eq 'global' ? '_GLOBAL' : '';
 470       unless (exists $file{"needed_$type"}{$func}) {
 471         if ($type eq 'global') {
 472           diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
 473         }
 474         else {
 475           diag("File needs $func, adding static request");
 476         }
 477         $pp .= "#define NEED_$func$suffix\n";
 478       }
 479     }
 480
 481     if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
 482       $pp = '';
 483       $file{changes}++;
 484     }
 485
 486     unless ($file{has_inc_ppport}) {
 487       diag("Needs to include '$ppport'");
 488       $pp .= qq(#include "$ppport"\n)
 489     }
 490
 491     if ($pp) {
 492       $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
 493                      || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
 494                      || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
 495                      || ($c =~ s/^/$pp/);
 496     }
 497   }
 498   else {
 499     if ($file{has_inc_ppport}) {
 500       diag("No need to include '$ppport'");
 501       $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
 502     }
 503   }
 504
 505   # put back in our C comments
 506   my $ix;
 507   my $cppc = 0;
 508   my @ccom = @{$file{ccom}};
 509   for $ix (0 .. $#ccom) {
 510     if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
 511       $cppc++;
 512       $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
 513     }
 514     else {
 515       $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
 516     }
 517   }
 518
 519   if ($cppc) {
 520     my $s = $cppc != 1 ? 's' : '';
 521     warning("Uses $cppc C++ style comment$s, which is not portable");
 522   }
 523
 524   my $s = $warnings != 1 ? 's' : '';
 525   my $warn = $warnings ? " ($warnings warning$s)" : '';
 526   info("Analysis completed$warn");
 527
 528   if ($file{changes}) {
 529     if (exists $opt{copy}) {
 530       my $newfile = "$filename$opt{copy}";
 531       if (-e $newfile) {
 532         error("'$newfile' already exists, refusing to write copy of '$filename'");
 533       }
 534       else {
 535         local *F;
 536         if (open F, ">$newfile") {
 537           info("Writing copy of '$filename' with changes to '$newfile'");
 538           print F $c;
 539           close F;
 540         }
 541         else {
 542           error("Cannot open '$newfile' for writing: $!");
 543         }
 544       }
 545     }
 546     elsif (exists $opt{patch} || $opt{changes}) {
 547       if (exists $opt{patch}) {
 548         unless ($patch_opened) {
 549           if (open PATCH, ">$opt{patch}") {
 550             $patch_opened = 1;
 551           }
 552           else {
 553             error("Cannot open '$opt{patch}' for writing: $!");
 554             delete $opt{patch};
 555             $opt{changes} = 1;
 556             goto fallback;
 557           }
 558         }
 559         mydiff(\*PATCH, $filename, $c);
 560       }
 561       else {
 562 fallback:
 563         info("Suggested changes:");
 564         mydiff(\*STDOUT, $filename, $c);
 565       }
 566     }
 567     else {
 568       my $s = $file{changes} == 1 ? '' : 's';
 569       info("$file{changes} potentially required change$s detected");
 570     }
 571   }
 572   else {
 573     info("Looks good");
 574   }
 575 }
 576
 577 close PATCH if $patch_opened;
 578
 579 exit 0;
 580
 581 #######################################################################
 582
 583 sub try_use { eval "use @_;"; return $@ eq '' }
 584
 585 sub mydiff
 586 {
 587   local *F = shift;
 588   my($file, $str) = @_;
 589   my $diff;
 590
 591   if (exists $opt{diff}) {
 592     $diff = run_diff($opt{diff}, $file, $str);
 593   }
 594
 595   if (!defined $diff and try_use('Text::Diff')) {
 596     $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
 597     $diff = <<HEADER . $diff;
 598 --- $file
 599 +++ $file.patched
 600 HEADER
 601   }
 602
 603   if (!defined $diff) {
 604     $diff = run_diff('diff -u', $file, $str);
 605   }
 606
 607   if (!defined $diff) {
 608     $diff = run_diff('diff', $file, $str);
 609   }
 610
 611   if (!defined $diff) {
 612     error("Cannot generate a diff. Please install Text::Diff or use --copy.");
 613     return;
 614   }
 615
 616   print F $diff;
 617 }
 618
 619 sub run_diff
 620 {
 621   my($prog, $file, $str) = @_;
 622   my $tmp = 'dppptemp';
 623   my $suf = 'aaa';
 624   my $diff = '';
 625   local *F;
 626
 627   while (-e "$tmp.$suf") { $suf++ }
 628   $tmp = "$tmp.$suf";
 629
 630   if (open F, ">$tmp") {
 631     print F $str;
 632     close F;
 633
 634     if (open F, "$prog $file $tmp |") {
 635       while (<F>) {
 636         s/\Q$tmp\E/$file.patched/;
 637         $diff .= $_;
 638       }
 639       close F;
 640       unlink $tmp;
 641       return $diff;
 642     }
 643
 644     unlink $tmp;
 645   }
 646   else {
 647     error("Cannot open '$tmp' for writing: $!");
 648   }
 649
 650   return undef;
 651 }
 652
 653 sub rec_depend
 654 {
 655   my($func, $seen) = @_;
 656   return () unless exists $depends{$func};
 657   $seen = {%{$seen||{}}};
 658   return () if $seen->{$func}++;
 659   my %s;
 660   grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
 661 }
 662
 663 sub parse_version
 664 {
 665   my $ver = shift;
 666
 667   if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
 668     return ($1, $2, $3);
 669   }
 670   elsif ($ver !~ /^\d+\.[\d_]+$/) {
 671     die "cannot parse version '$ver'\n";
 672   }
 673
 674   $ver =~ s/_//g;
 675   $ver =~ s/$/000000/;
 676
 677   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
 678
 679   $v = int $v;
 680   $s = int $s;
 681
 682   if ($r < 5 || ($r == 5 && $v < 6)) {
 683     if ($s % 10) {
 684       die "cannot parse version '$ver'\n";
 685     }
 686   }
 687
 688   return ($r, $v, $s);
 689 }
 690
 691 sub format_version
 692 {
 693   my $ver = shift;
 694
 695   $ver =~ s/$/000000/;
 696   my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
 697
 698   $v = int $v;
 699   $s = int $s;
 700
 701   if ($r < 5 || ($r == 5 && $v < 6)) {
 702     if ($s % 10) {
 703       die "invalid version '$ver'\n";
 704     }
 705     $s /= 10;
 706
 707     $ver = sprintf "%d.%03d", $r, $v;
 708     $s > 0 and $ver .= sprintf "_%02d", $s;
 709
 710     return $ver;
 711   }
 712
 713   return sprintf "%d.%d.%d", $r, $v, $s;
 714 }
 715
 716 sub info
 717 {
 718   $opt{quiet} and return;
 719   print @_, "\n";
 720 }
 721
 722 sub diag
 723 {
 724   $opt{quiet} and return;
 725   $opt{diag} and print @_, "\n";
 726 }
 727
 728 sub warning
 729 {
 730   $opt{quiet} and return;
 731   print "*** ", @_, "\n";
 732 }
 733
 734 sub error
 735 {
 736   print "*** ERROR: ", @_, "\n";
 737 }
 738
 739 my %given_hints;
 740 my %given_warnings;
 741 sub hint
 742 {
 743   $opt{quiet} and return;
 744   my $func = shift;
 745   my $rv = 0;
 746   if (exists $warnings{$func} && !$given_warnings{$func}++) {
 747     my $warn = $warnings{$func};
 748     $warn =~ s!^!*** !mg;
 749     print "*** WARNING: $func\n", $warn;
 750     $rv++;
 751   }
 752   if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
 753     my $hint = $hints{$func};
 754     $hint =~ s/^/   /mg;
 755     print "   --- hint for $func ---\n", $hint;
 756   }
 757   $rv;
 758 }
 759
 760 sub usage
 761 {
 762   my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
 763   my %M = ( 'I' => '*' );
 764   $usage =~ s/^\s*perl\s+\S+/$^X $0/;
 765   $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
 766
 767   print <<ENDUSAGE;
 768
 769 Usage: $usage
 770
 771 See perldoc $0 for details.
 772
 773 ENDUSAGE
 774
 775   exit 2;
 776 }
 777
 778 sub strip
 779 {
 780   my $self = do { local(@ARGV,$/)=($0); <> };
 781   my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
 782   $copy =~ s/^(?=\S+)/    /gms;
 783   $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
 784   $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
 785 if (\@ARGV && \$ARGV[0] eq '--unstrip') {
 786   eval { require Devel::PPPort };
 787   \$@ and die "Cannot require Devel::PPPort, please install.\\n";
 788   if (eval \$Devel::PPPort::VERSION < $VERSION) {
 789     die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
 790       . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
 791       . "Please install a newer version, or --unstrip will not work.\\n";
 792   }
 793   Devel::PPPort::WriteFile(\$0);
 794   exit 0;
 795 }
 796 print <<END;
 797
 798 Sorry, but this is a stripped version of \$0.
 799
 800 To be able to use its original script and doc functionality,
 801 please try to regenerate this file using:
 802
 803   \$^X \$0 --unstrip
 804
 805 END
 806 /ms;
 807   my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
 808   $c =~ s{
 809     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
 810   | ( "[^"\\]*(?:\\.[^"\\]*)*"
 811     | '[^'\\]*(?:\\.[^'\\]*)*' )
 812   | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
 813   $c =~ s!\s+$!!mg;
 814   $c =~ s!^$LF!!mg;
 815   $c =~ s!^\s*#\s*!#!mg;
 816   $c =~ s!^\s+!!mg;
 817
 818   open OUT, ">$0" or die "cannot strip $0: $!\n";
 819   print OUT "$pl$c\n";
 820
 821   exit 0;
 822 }