This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
bbf7b6f7c145e69d95e239fa7876b131918bae65
[perl5.git] / 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 dictionary_order 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 info
664 {
665   $opt{quiet} and return;
666   print @_, "\n";
667 }
668
669 sub diag
670 {
671   $opt{quiet} and return;
672   $opt{diag} and print @_, "\n";
673 }
674
675 sub warning
676 {
677   $opt{quiet} and return;
678   print "*** ", @_, "\n";
679 }
680
681 sub error
682 {
683   print "*** ERROR: ", @_, "\n";
684 }
685
686 my %given_hints;
687 my %given_warnings;
688 sub hint
689 {
690   $opt{quiet} and return;
691   my $func = shift;
692   my $rv = 0;
693   if (exists $warnings{$func} && !$given_warnings{$func}++) {
694     my $warn = $warnings{$func};
695     $warn =~ s!^!*** !mg;
696     print "*** WARNING: $func\n", $warn;
697     $rv++;
698   }
699   if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
700     my $hint = $hints{$func};
701     $hint =~ s/^/   /mg;
702     print "   --- hint for $func ---\n", $hint;
703   }
704   $rv;
705 }
706
707 sub usage
708 {
709   my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
710   my %M = ( 'I' => '*' );
711   $usage =~ s/^\s*perl\s+\S+/$^X $0/;
712   $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
713
714   print <<ENDUSAGE;
715
716 Usage: $usage
717
718 See perldoc $0 for details.
719
720 ENDUSAGE
721
722   exit 2;
723 }
724
725 sub strip
726 {
727   my $self = do { local(@ARGV,$/)=($0); <> };
728   my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
729   $copy =~ s/^(?=\S+)/    /gms;
730   $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
731   $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
732 if (\@ARGV && \$ARGV[0] eq '--unstrip') {
733   eval { require Devel::PPPort };
734   \$@ and die "Cannot require Devel::PPPort, please install.\\n";
735   if (eval \$Devel::PPPort::VERSION < $VERSION) {
736     die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
737       . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
738       . "Please install a newer version, or --unstrip will not work.\\n";
739   }
740   Devel::PPPort::WriteFile(\$0);
741   exit 0;
742 }
743 print <<END;
744
745 Sorry, but this is a stripped version of \$0.
746
747 To be able to use its original script and doc functionality,
748 please try to regenerate this file using:
749
750   \$^X \$0 --unstrip
751
752 END
753 /ms;
754   my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
755   $c =~ s{
756     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
757   | ( "[^"\\]*(?:\\.[^"\\]*)*"
758     | '[^'\\]*(?:\\.[^'\\]*)*' )
759   | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
760   $c =~ s!\s+$!!mg;
761   $c =~ s!^$LF!!mg;
762   $c =~ s!^\s*#\s*!#!mg;
763   $c =~ s!^\s+!!mg;
764
765   open OUT, ">$0" or die "cannot strip $0: $!\n";
766   print OUT "$pl$c\n";
767
768   exit 0;
769 }