ppphbin revision 1.1.1.2 
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
16use strict;
17
18# Disable broken TRIE-optimization
19BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= 5.009004 && "$]" <= 5.009005 }
20
21my $VERSION = __VERSION__;
22
23my %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
34my($ppport) = $0 =~ /([\w.]+)$/;
35my $LF = '(?:\r\n|[\r\n])';   # line feed
36my $HS = "[ \t]";             # horizontal whitespace
37
38# Never use C comments in this file!
39my $ccs  = '/'.'*';
40my $cce  = '*'.'/';
41my $rccs = quotemeta $ccs;
42my $rcce = quotemeta $cce;
43
44eval {
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
53if ($@ and grep /^-/, @ARGV) {
54  usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
55  die "Getopt::Long not found. Please don't use any options.\n";
56}
57
58if ($opt{version}) {
59  print "This is $0 $VERSION.\n";
60  exit 0;
61}
62
63usage() if $opt{help};
64strip() if $opt{strip};
65
66if (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}
75else {
76  $opt{'compat-version'} = 5;
77}
78
79my %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
91if (exists $opt{'list-unsupported'}) {
92  my $f;
93  for $f (sort { lc $a cmp lc $b } keys %API) {
94    next unless $API{$f}{todo};
95    print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
96  }
97  exit 0;
98}
99
100# Scan for possible replacement candidates
101
102my(%replace, %need, %hints, %warnings, %depends);
103my $replace = 0;
104my($hint, $define, $function);
105
106sub 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
116while (<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
177for (values %depends) {
178  my %s;
179  $_ = [sort grep !$s{$_}++, @$_];
180}
181
182if (exists $opt{'api-info'}) {
183  my $f;
184  my $count = 0;
185  my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
186  for $f (sort { lc $a cmp lc $b } keys %API) {
187    next unless $f =~ /$match/;
188    print "\n=== $f ===\n\n";
189    my $info = 0;
190    if ($API{$f}{base} || $API{$f}{todo}) {
191      my $base = format_version($API{$f}{base} || $API{$f}{todo});
192      print "Supported at least starting from perl-$base.\n";
193      $info++;
194    }
195    if ($API{$f}{provided}) {
196      my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__";
197      print "Support by $ppport provided back to perl-$todo.\n";
198      print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
199      print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
200      print "\n$hints{$f}" if exists $hints{$f};
201      print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
202      $info++;
203    }
204    print "No portability information available.\n" unless $info;
205    $count++;
206  }
207  $count or print "Found no API matching '$opt{'api-info'}'.";
208  print "\n";
209  exit 0;
210}
211
212if (exists $opt{'list-provided'}) {
213  my $f;
214  for $f (sort { lc $a cmp lc $b } keys %API) {
215    next unless $API{$f}{provided};
216    my @flags;
217    push @flags, 'explicit' if exists $need{$f};
218    push @flags, 'depend'   if exists $depends{$f};
219    push @flags, 'hint'     if exists $hints{$f};
220    push @flags, 'warning'  if exists $warnings{$f};
221    my $flags = @flags ? '  ['.join(', ', @flags).']' : '';
222    print "$f$flags\n";
223  }
224  exit 0;
225}
226
227my @files;
228my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
229my $srcext = join '|', map { quotemeta $_ } @srcext;
230
231if (@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}
247else {
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
260if (!@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
273die "No input files given!\n" unless @files;
274
275my(%files, %global, %revreplace);
276%revreplace = reverse %replace;
277my $filename;
278my $patch_opened = 0;
279
280for $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
359my $need;
360for $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
375for $filename (@files) {
376  exists $files{$filename} or next;
377
378  info("=== Analyzing $filename ===");
379
380  my %file = %{$files{$filename}};
381  my $func;
382  my $c = $file{code};
383  my $warnings = 0;
384
385  for $func (sort keys %{$file{uses_Perl}}) {
386    if ($API{$func}{varargs}) {
387      unless ($API{$func}{nothxarg}) {
388        my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
389                              { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
390        if ($changes) {
391          warning("Doesn't pass interpreter argument aTHX to Perl_$func");
392          $file{changes} += $changes;
393        }
394      }
395    }
396    else {
397      warning("Uses Perl_$func instead of $func");
398      $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
399                                {$func$1(}g);
400    }
401  }
402
403  for $func (sort keys %{$file{uses_replace}}) {
404    warning("Uses $func instead of $replace{$func}");
405    $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
406  }
407
408  for $func (sort keys %{$file{uses_provided}}) {
409    if ($file{uses}{$func}) {
410      if (exists $file{uses_deps}{$func}) {
411        diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
412      }
413      else {
414        diag("Uses $func");
415      }
416    }
417    $warnings += hint($func);
418  }
419
420  unless ($opt{quiet}) {
421    for $func (sort keys %{$file{uses_todo}}) {
422      print "*** WARNING: Uses $func, which may not be portable below perl ",
423            format_version($API{$func}{todo}), ", even with '$ppport'\n";
424      $warnings++;
425    }
426  }
427
428  for $func (sort keys %{$file{needed_static}}) {
429    my $message = '';
430    if (not exists $file{uses}{$func}) {
431      $message = "No need to define NEED_$func if $func is never used";
432    }
433    elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
434      $message = "No need to define NEED_$func when already needed globally";
435    }
436    if ($message) {
437      diag($message);
438      $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
439    }
440  }
441
442  for $func (sort keys %{$file{needed_global}}) {
443    my $message = '';
444    if (not exists $global{uses}{$func}) {
445      $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
446    }
447    elsif (exists $file{needs}{$func}) {
448      if ($file{needs}{$func} eq 'extern') {
449        $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
450      }
451      elsif ($file{needs}{$func} eq 'static') {
452        $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
453      }
454    }
455    if ($message) {
456      diag($message);
457      $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
458    }
459  }
460
461  $file{needs_inc_ppport} = keys %{$file{uses}};
462
463  if ($file{needs_inc_ppport}) {
464    my $pp = '';
465
466    for $func (sort keys %{$file{needs}}) {
467      my $type = $file{needs}{$func};
468      next if $type eq 'extern';
469      my $suffix = $type eq 'global' ? '_GLOBAL' : '';
470      unless (exists $file{"needed_$type"}{$func}) {
471        if ($type eq 'global') {
472          diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
473        }
474        else {
475          diag("File needs $func, adding static request");
476        }
477        $pp .= "#define NEED_$func$suffix\n";
478      }
479    }
480
481    if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
482      $pp = '';
483      $file{changes}++;
484    }
485
486    unless ($file{has_inc_ppport}) {
487      diag("Needs to include '$ppport'");
488      $pp .= qq(#include "$ppport"\n)
489    }
490
491    if ($pp) {
492      $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
493                     || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
494                     || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
495                     || ($c =~ s/^/$pp/);
496    }
497  }
498  else {
499    if ($file{has_inc_ppport}) {
500      diag("No need to include '$ppport'");
501      $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
502    }
503  }
504
505  # put back in our C comments
506  my $ix;
507  my $cppc = 0;
508  my @ccom = @{$file{ccom}};
509  for $ix (0 .. $#ccom) {
510    if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
511      $cppc++;
512      $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
513    }
514    else {
515      $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
516    }
517  }
518
519  if ($cppc) {
520    my $s = $cppc != 1 ? 's' : '';
521    warning("Uses $cppc C++ style comment$s, which is not portable");
522  }
523
524  my $s = $warnings != 1 ? 's' : '';
525  my $warn = $warnings ? " ($warnings warning$s)" : '';
526  info("Analysis completed$warn");
527
528  if ($file{changes}) {
529    if (exists $opt{copy}) {
530      my $newfile = "$filename$opt{copy}";
531      if (-e $newfile) {
532        error("'$newfile' already exists, refusing to write copy of '$filename'");
533      }
534      else {
535        local *F;
536        if (open F, ">$newfile") {
537          info("Writing copy of '$filename' with changes to '$newfile'");
538          print F $c;
539          close F;
540        }
541        else {
542          error("Cannot open '$newfile' for writing: $!");
543        }
544      }
545    }
546    elsif (exists $opt{patch} || $opt{changes}) {
547      if (exists $opt{patch}) {
548        unless ($patch_opened) {
549          if (open PATCH, ">$opt{patch}") {
550            $patch_opened = 1;
551          }
552          else {
553            error("Cannot open '$opt{patch}' for writing: $!");
554            delete $opt{patch};
555            $opt{changes} = 1;
556            goto fallback;
557          }
558        }
559        mydiff(\*PATCH, $filename, $c);
560      }
561      else {
562fallback:
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
577close PATCH if $patch_opened;
578
579exit 0;
580
581#######################################################################
582
583sub try_use { eval "use @_;"; return $@ eq '' }
584
585sub 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
600HEADER
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
619sub 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
653sub 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
663sub parse_version
664{
665  my $ver = shift;
666
667  if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
668    return ($1, $2, $3);
669  }
670  elsif ($ver !~ /^\d+\.[\d_]+$/) {
671    die "cannot parse version '$ver'\n";
672  }
673
674  $ver =~ s/_//g;
675  $ver =~ s/$/000000/;
676
677  my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
678
679  $v = int $v;
680  $s = int $s;
681
682  if ($r < 5 || ($r == 5 && $v < 6)) {
683    if ($s % 10) {
684      die "cannot parse version '$ver'\n";
685    }
686  }
687
688  return ($r, $v, $s);
689}
690
691sub format_version
692{
693  my $ver = shift;
694
695  $ver =~ s/$/000000/;
696  my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
697
698  $v = int $v;
699  $s = int $s;
700
701  if ($r < 5 || ($r == 5 && $v < 6)) {
702    if ($s % 10) {
703      die "invalid version '$ver'\n";
704    }
705    $s /= 10;
706
707    $ver = sprintf "%d.%03d", $r, $v;
708    $s > 0 and $ver .= sprintf "_%02d", $s;
709
710    return $ver;
711  }
712
713  return sprintf "%d.%d.%d", $r, $v, $s;
714}
715
716sub info
717{
718  $opt{quiet} and return;
719  print @_, "\n";
720}
721
722sub diag
723{
724  $opt{quiet} and return;
725  $opt{diag} and print @_, "\n";
726}
727
728sub warning
729{
730  $opt{quiet} and return;
731  print "*** ", @_, "\n";
732}
733
734sub error
735{
736  print "*** ERROR: ", @_, "\n";
737}
738
739my %given_hints;
740my %given_warnings;
741sub hint
742{
743  $opt{quiet} and return;
744  my $func = shift;
745  my $rv = 0;
746  if (exists $warnings{$func} && !$given_warnings{$func}++) {
747    my $warn = $warnings{$func};
748    $warn =~ s!^!*** !mg;
749    print "*** WARNING: $func\n", $warn;
750    $rv++;
751  }
752  if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
753    my $hint = $hints{$func};
754    $hint =~ s/^/   /mg;
755    print "   --- hint for $func ---\n", $hint;
756  }
757  $rv;
758}
759
760sub usage
761{
762  my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
763  my %M = ( 'I' => '*' );
764  $usage =~ s/^\s*perl\s+\S+/$^X $0/;
765  $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
766
767  print <<ENDUSAGE;
768
769Usage: $usage
770
771See perldoc $0 for details.
772
773ENDUSAGE
774
775  exit 2;
776}
777
778sub strip
779{
780  my $self = do { local(@ARGV,$/)=($0); <> };
781  my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
782  $copy =~ s/^(?=\S+)/    /gms;
783  $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
784  $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
785if (\@ARGV && \$ARGV[0] eq '--unstrip') {
786  eval { require Devel::PPPort };
787  \$@ and die "Cannot require Devel::PPPort, please install.\\n";
788  if (eval \$Devel::PPPort::VERSION < $VERSION) {
789    die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
790      . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
791      . "Please install a newer version, or --unstrip will not work.\\n";
792  }
793  Devel::PPPort::WriteFile(\$0);
794  exit 0;
795}
796print <<END;
797
798Sorry, but this is a stripped version of \$0.
799
800To be able to use its original script and doc functionality,
801please try to regenerate this file using:
802
803  \$^X \$0 --unstrip
804
805END
806/ms;
807  my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
808  $c =~ s{
809    / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
810  | ( "[^"\\]*(?:\\.[^"\\]*)*"
811    | '[^'\\]*(?:\\.[^'\\]*)*' )
812  | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
813  $c =~ s!\s+$!!mg;
814  $c =~ s!^$LF!!mg;
815  $c =~ s!^\s*#\s*!#!mg;
816  $c =~ s!^\s+!!mg;
817
818  open OUT, ">$0" or die "cannot strip $0: $!\n";
819  print OUT "$pl$c\n";
820
821  exit 0;
822}
823