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