This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/inc/inctools: Rewrite parse_version
[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   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 }