ext/Devel/PPPort/parts/inc/ppphbin

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