This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ppport.h: --api-info Reorder output of hints/depends info
[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 $opt{'compat-version'} = __MIN_PERL__ unless exists $opt{'compat-version'};
67 $opt{'compat-version'} = int_parse_version($opt{'compat-version'});
68
69 my $int_min_perl = int_parse_version(__MIN_PERL__);
70
71 # Each element of this hash looks something like:
72 # 'Poison' => {
73 #                         'base' => '5.008000',
74 #                         'provided' => 1,
75 #                         'todo' => '5.003007'
76 #             },
77 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
78                 ? ( $1 => {
79                       ($2                  ? ( base     => $2 ) : ()),
80                       ($3                  ? ( todo     => $3 ) : ()),
81                       (index($4, 'v') >= 0 ? ( varargs  => 1  ) : ()),
82                       (index($4, 'p') >= 0 ? ( provided => 1  ) : ()),
83                       (index($4, 'n') >= 0 ? ( noTHXarg => 1  ) : ()),
84                       (index($4, 'c') >= 0 ? ( core_only    => 1  ) : ()),
85                       (index($4, 'd') >= 0 ? ( deprecated   => 1  ) : ()),
86                       (index($4, 'i') >= 0 ? ( inaccessible => 1  ) : ()),
87                       (index($4, 'x') >= 0 ? ( experimental => 1  ) : ()),
88                       (index($4, 'u') >= 0 ? ( undocumented => 1  ) : ()),
89                       (index($4, 'o') >= 0 ? ( ppport_fnc => 1  ) : ()),
90                     } )
91                 : die "invalid spec: $_" } qw(
92 __PERL_API__
93 );
94
95 if (exists $opt{'list-unsupported'}) {
96   my $f;
97   for $f (sort dictionary_order keys %API) {
98     next if $API{$f}{core_only};
99     next if $API{$f}{beyond_depr};
100     next if $API{$f}{inaccessible};
101     next if $API{$f}{experimental};
102     next unless $API{$f}{todo};
103     next if int_parse_version($API{$f}{todo}) <= $int_min_perl;
104     print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
105   }
106   exit 0;
107 }
108
109 # Scan for hints, possible replacement candidates, etc.
110
111 my(%replace, %need, %hints, %warnings, %depends);
112 my $replace = 0;
113 my($hint, $define, $function);
114
115 sub find_api
116 {
117   my $code = shift;
118   no warnings 'uninitialized';
119   $code =~ s{
120     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
121   | "[^"\\]*(?:\\.[^"\\]*)*"
122   | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx;
123   grep { exists $API{$_} } $code =~ /(\w+)/mg;
124 }
125
126 while (<DATA>) {
127   if ($hint) {
128
129     # Here, we are in the middle of accumulating a hint or warning.
130     my $end_of_hint = 0;
131
132     # A line containing a comment end marker closes the hint.  Remove that
133     # marker for processing below.
134     if (s/\s*$rcce(.*?)\s*$//) {
135         die "Nothing can follow the end of comment in '$_'\n" if length $1 > 0;
136         $end_of_hint = 1;
137     }
138
139     # Set $h to the hash of which type.
140     my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings;
141
142     # Ignore any leading and trailing white space, and an optional star comment
143     # continuation marker, then place the meat of the line into $1
144     m/^\s*(?:\*\s*)?(.*?)\s*$/;
145
146     # Add the meat of this line to the hash value of each API element it
147     # applies to
148     for (@{$hint->[1]}) {
149       $h->{$_} ||= '';  # avoid the warning older perls generate
150       $h->{$_} .= "$1\n";
151     }
152
153     # If the line had a comment close, we are through with this hint
154     undef $hint if $end_of_hint;
155
156     next;
157   }
158
159   # Set up $hint if this is the beginning of a Hint: or Warning:
160   # These are from a multi-line C comment in the file, with the first line
161   # looking like (a space has been inserted because this file can't have C
162   # comment markers in it):
163   #   / * Warning: PL_expect, PL_copline, PL_rsfp
164   #
165   # $hint becomes
166   #     [
167   #      'Warning',
168   #                [
169   #                  'PL_expect',
170   #                  'PL_copline',
171   #                  'PL_rsfp',
172   #                ],
173   #     ]
174   if (m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}) {
175       $hint = [$1, [split /,?\s+/, $2]];
176       next;
177   }
178
179   if ($define) { # If in the middle of a definition...
180
181     # append a continuation line ending with backslash.
182     if ($define->[1] =~ /\\$/) {
183       $define->[1] .= $_;
184     }
185     else {  # Otherwise this line ends the definition, make foo depend on bar
186             # (and what bar depends on) if its not one of ppp's own constructs
187       if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) {
188         my @n = find_api($define->[1]);
189         push @{$depends{$define->[0]}}, @n if @n
190       }
191       undef $define;
192     }
193   }
194
195   # For '#define foo bar' or '#define foo(a,b,c) bar', $define becomes a
196   # reference to [ foo, bar ]
197   $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)};
198
199   if ($function) {
200     if (/^}/) {
201       if (exists $API{$function->[0]}) {
202         my @n = find_api($function->[1]);
203         push @{$depends{$function->[0]}}, @n if @n
204       }
205       undef $function;
206     }
207     else {
208       $function->[1] .= $_;
209     }
210   }
211
212   $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)};
213
214   # Set $replace to the number given for lines that look like
215   # / * Replace: \d+ * /
216   # (blanks added to keep real C comments from appearing in this file)
217   # Thus setting it to 1 starts a region where replacements are automatically
218   # done, and setting it to 0 ends that region.
219   $replace     = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
220
221   # Add bar => foo to %replace  for lines like '#define foo bar in a region
222   # where $replace is non-zero
223   $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
224
225   # Add bar => foo to %replace for lines like '#define foo bar  / * Replace * /
226   # (blanks added to keep real C comments from appearing in this file)
227   $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
228
229   # Add foo => bar to %replace for lines like / * Replace foo with bar * /
230   # (blanks added to keep real C comments from appearing in this file)
231   $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
232
233   # For lines like / * foo, bar depends on baz, bat * /
234   # create a list of the elements on the rhs, and make that list apply to each
235   # element in the lhs, which becomes a key in \%depends.
236   # (blanks added to keep real C comments from appearing in this file)
237   if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
238     my @deps = map { s/\s+//g; $_ } split /,/, $3;
239     my $d;
240     for $d (map { s/\s+//g; $_ } split /,/, $1) {
241       push @{$depends{$d}}, @deps;
242     }
243   }
244
245   $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
246 }
247
248 for (values %depends) {
249   my %seen;
250   $_ = [sort dictionary_order grep !$seen{$_}++, @$_];
251 }
252
253 if (exists $opt{'api-info'}) {
254   my $f;
255   my $count = 0;
256   my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
257   for $f (sort dictionary_order keys %API) {
258     next unless $f =~ /$match/;
259     print "\n=== $f ===\n\n";
260     my $info = 0;
261     if ($API{$f}{base} || $API{$f}{todo}) {
262       if ($API{$f}{ppport_fnc}) {
263         print "This is only supported by ppport.h, and NOT by ANY perl version.\n";
264       }
265       else {
266         my $base = format_version($API{$f}{base} || $API{$f}{todo});
267         print "Supported at least starting from perl-$base.\n";
268       }
269       $info++;
270     }
271     if ($API{$f}{provided}) {
272       my $todo = $API{$f}{todo} ? $API{$f}{todo} : __MIN_PERL__;
273       my $at_least = (int_parse_version($todo) == int_parse_version(__MIN_PERL__))
274                      ? " at least"
275                      : "";
276       print "Support by $ppport provided$at_least back to perl-",
277             format_version($todo),
278             ".\n";
279       print "Support needs to be explicitly requested by #define NEED_$f\n",
280             "(or #define NEED_${f}_GLOBAL).\n"              if exists $need{$f};
281       $info++;
282     }
283
284     if (! $API{$f}{ppport_fnc}) {
285       my $email = "Send email to perl5-porters\@perl.org if you need to have this functionality.\n";
286       if ($API{$f}{inaccessible}) {
287         print "\nThis is not part of the public API, and may not even be accessible to XS code.\n";
288         $info++;
289       }
290       elsif ($API{$f}{core_only}) {
291         print "\nThis is not part of the public API, and should not be used by XS code.\n";
292         $info++;
293       }
294       elsif ($API{$f}{deprecated}) {
295         print "\nThis is deprecated and should not be used.  Convert existing uses.\n";
296         $info++;
297       }
298       elsif ($API{$f}{experimental}) {
299         print "\nThe API for this is unstable and should not be used by XS code.\n", $email;
300         $info++;
301       }
302       elsif ($API{$f}{undocumented}) {
303         print "\nSince this is undocumented, the API should be considered unstable.\n";
304         if ($API{$f}{provided}) {
305             print "Consider bringing this up on the list: perl5-porters\@perl.org.\n";
306         }
307         else {
308             print "It may be that this is not intended for XS use, or it may just be\n",
309                   "that no one has gotten around to documenting it.\n", $email;
310         }
311         $info++;
312       }
313       unless ($info) {
314         print "No portability information available.  Check your spelling; or",
315               " this could be\na bug in Devel::PPPort.  To report an issue:\n",
316               "https://github.com/Dual-Life/Devel-PPPort/issues/new\n";
317       }
318     }
319
320     print "\nDepends on: ", join(', ', @{$depends{$f}}), ".\n"
321                                                          if exists $depends{$f};
322     if (exists $hints{$f} || exists $warnings{$f}) {
323       print "\n$hints{$f}" if exists $hints{$f};
324       print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f};
325       $info++;
326     }
327     $count++;
328   }
329
330   $count or print "\nFound no API matching '$opt{'api-info'}'.";
331   print "\n";
332   exit 0;
333 }
334
335 if (exists $opt{'list-provided'}) {
336   my $f;
337   for $f (sort dictionary_order keys %API) {
338     next unless $API{$f}{provided};
339     my @flags;
340     push @flags, 'explicit' if exists $need{$f};
341     push @flags, 'depend'   if exists $depends{$f};
342     push @flags, 'hint'     if exists $hints{$f};
343     push @flags, 'warning'  if exists $warnings{$f};
344     my $flags = @flags ? '  ['.join(', ', @flags).']' : '';
345     print "$f$flags\n";
346   }
347   exit 0;
348 }
349
350 my @files;
351 my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc );
352 my $srcext = join '|', map { quotemeta $_ } @srcext;
353
354 if (@ARGV) {
355   my %seen;
356   for (@ARGV) {
357     if (-e) {
358       if (-f) {
359         push @files, $_ unless $seen{$_}++;
360       }
361       else { warn "'$_' is not a file.\n" }
362     }
363     else {
364       my @new = grep { -f } glob $_
365           or warn "'$_' does not exist.\n";
366       push @files, grep { !$seen{$_}++ } @new;
367     }
368   }
369 }
370 else {
371   eval {
372     require File::Find;
373     File::Find::find(sub {
374       $File::Find::name =~ /($srcext)$/i
375           and push @files, $File::Find::name;
376     }, '.');
377   };
378   if ($@) {
379     @files = map { glob "*$_" } @srcext;
380   }
381 }
382
383 if (!@ARGV || $opt{filter}) {
384   my(@in, @out);
385   my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
386   for (@files) {
387     my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i;
388     push @{ $out ? \@out : \@in }, $_;
389   }
390   if (@ARGV && @out) {
391     warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
392   }
393   @files = @in;
394 }
395
396 die "No input files given!\n" unless @files;
397
398 my(%files, %global, %revreplace);
399 %revreplace = reverse %replace;
400 my $filename;
401 my $patch_opened = 0;
402
403 for $filename (@files) {
404   unless (open IN, "<$filename") {
405     warn "Unable to read from $filename: $!\n";
406     next;
407   }
408
409   info("Scanning $filename ...");
410
411   my $c = do { local $/; <IN> };
412   close IN;
413
414   my %file = (orig => $c, changes => 0);
415
416   # Temporarily remove C/XS comments and strings from the code
417   my @ccom;
418
419   $c =~ s{
420     ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]*
421     | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* )
422   | ( ^$HS*\#[^\r\n]*
423     | "[^"\\]*(?:\\.[^"\\]*)*"
424     | '[^'\\]*(?:\\.[^'\\]*)*'
425     | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) )
426   }{ defined $2 and push @ccom, $2;
427      defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex;
428
429   $file{ccom} = \@ccom;
430   $file{code} = $c;
431   $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m;
432
433   my $func;
434
435   for $func (keys %API) {
436     my $match = $func;
437     $match .= "|$revreplace{$func}" if exists $revreplace{$func};
438     if ($c =~ /\b(?:Perl_)?($match)\b/) {
439       $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
440       $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
441       if (exists $API{$func}{provided}) {
442         $file{uses_provided}{$func}++;
443         if ( ! exists $API{$func}{base}
444             || int_parse_version($API{$func}{base}) > $opt{'compat-version'})
445         {
446           $file{uses}{$func}++;
447           my @deps = rec_depend($func);
448           if (@deps) {
449             $file{uses_deps}{$func} = \@deps;
450             for (@deps) {
451               $file{uses}{$_} = 0 unless exists $file{uses}{$_};
452             }
453           }
454           for ($func, @deps) {
455             $file{needs}{$_} = 'static' if exists $need{$_};
456           }
457         }
458       }
459       if (   exists $API{$func}{todo}
460           && int_parse_version($API{$func}{todo}) > $opt{'compat-version'})
461       {
462         if ($c =~ /\b$func\b/) {
463           $file{uses_todo}{$func}++;
464         }
465       }
466     }
467   }
468
469   while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
470     if (exists $need{$2}) {
471       $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
472     }
473     else { warning("Possibly wrong #define $1 in $filename") }
474   }
475
476   for (qw(uses needs uses_todo needed_global needed_static)) {
477     for $func (keys %{$file{$_}}) {
478       push @{$global{$_}{$func}}, $filename;
479     }
480   }
481
482   $files{$filename} = \%file;
483 }
484
485 # Globally resolve NEED_'s
486 my $need;
487 for $need (keys %{$global{needs}}) {
488   if (@{$global{needs}{$need}} > 1) {
489     my @targets = @{$global{needs}{$need}};
490     my @t = grep $files{$_}{needed_global}{$need}, @targets;
491     @targets = @t if @t;
492     @t = grep /\.xs$/i, @targets;
493     @targets = @t if @t;
494     my $target = shift @targets;
495     $files{$target}{needs}{$need} = 'global';
496     for (@{$global{needs}{$need}}) {
497       $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
498     }
499   }
500 }
501
502 for $filename (@files) {
503   exists $files{$filename} or next;
504
505   info("=== Analyzing $filename ===");
506
507   my %file = %{$files{$filename}};
508   my $func;
509   my $c = $file{code};
510   my $warnings = 0;
511
512   for $func (sort dictionary_order keys %{$file{uses_Perl}}) {
513     if ($API{$func}{varargs}) {
514       unless ($API{$func}{noTHXarg}) {
515         my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
516                               { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
517         if ($changes) {
518           warning("Doesn't pass interpreter argument aTHX to Perl_$func");
519           $file{changes} += $changes;
520         }
521       }
522     }
523     else {
524       warning("Uses Perl_$func instead of $func");
525       $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
526                                 {$func$1(}g);
527     }
528   }
529
530   for $func (sort dictionary_order keys %{$file{uses_replace}}) {
531     warning("Uses $func instead of $replace{$func}");
532     $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
533   }
534
535   for $func (sort dictionary_order keys %{$file{uses_provided}}) {
536     if ($file{uses}{$func}) {
537       if (exists $file{uses_deps}{$func}) {
538         diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
539       }
540       else {
541         diag("Uses $func");
542       }
543     }
544     $warnings += hint($func);
545   }
546
547   unless ($opt{quiet}) {
548     for $func (sort dictionary_order keys %{$file{uses_todo}}) {
549       next if int_parse_version($API{$func}{todo}) <= $int_min_perl;
550       print "*** WARNING: Uses $func, which may not be portable below perl ",
551             format_version($API{$func}{todo}), ", even with '$ppport'\n";
552       $warnings++;
553     }
554   }
555
556   for $func (sort dictionary_order keys %{$file{needed_static}}) {
557     my $message = '';
558     if (not exists $file{uses}{$func}) {
559       $message = "No need to define NEED_$func if $func is never used";
560     }
561     elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
562       $message = "No need to define NEED_$func when already needed globally";
563     }
564     if ($message) {
565       diag($message);
566       $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
567     }
568   }
569
570   for $func (sort dictionary_order keys %{$file{needed_global}}) {
571     my $message = '';
572     if (not exists $global{uses}{$func}) {
573       $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
574     }
575     elsif (exists $file{needs}{$func}) {
576       if ($file{needs}{$func} eq 'extern') {
577         $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
578       }
579       elsif ($file{needs}{$func} eq 'static') {
580         $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
581       }
582     }
583     if ($message) {
584       diag($message);
585       $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
586     }
587   }
588
589   $file{needs_inc_ppport} = keys %{$file{uses}};
590
591   if ($file{needs_inc_ppport}) {
592     my $pp = '';
593
594     for $func (sort dictionary_order keys %{$file{needs}}) {
595       my $type = $file{needs}{$func};
596       next if $type eq 'extern';
597       my $suffix = $type eq 'global' ? '_GLOBAL' : '';
598       unless (exists $file{"needed_$type"}{$func}) {
599         if ($type eq 'global') {
600           diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
601         }
602         else {
603           diag("File needs $func, adding static request");
604         }
605         $pp .= "#define NEED_$func$suffix\n";
606       }
607     }
608
609     if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
610       $pp = '';
611       $file{changes}++;
612     }
613
614     unless ($file{has_inc_ppport}) {
615       diag("Needs to include '$ppport'");
616       $pp .= qq(#include "$ppport"\n)
617     }
618
619     if ($pp) {
620       $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
621                      || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
622                      || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
623                      || ($c =~ s/^/$pp/);
624     }
625   }
626   else {
627     if ($file{has_inc_ppport}) {
628       diag("No need to include '$ppport'");
629       $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
630     }
631   }
632
633   # put back in our C comments
634   my $ix;
635   my $cppc = 0;
636   my @ccom = @{$file{ccom}};
637   for $ix (0 .. $#ccom) {
638     if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
639       $cppc++;
640       $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
641     }
642     else {
643       $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
644     }
645   }
646
647   if ($cppc) {
648     my $s = $cppc != 1 ? 's' : '';
649     warning("Uses $cppc C++ style comment$s, which is not portable");
650   }
651
652   my $s = $warnings != 1 ? 's' : '';
653   my $warn = $warnings ? " ($warnings warning$s)" : '';
654   info("Analysis completed$warn");
655
656   if ($file{changes}) {
657     if (exists $opt{copy}) {
658       my $newfile = "$filename$opt{copy}";
659       if (-e $newfile) {
660         error("'$newfile' already exists, refusing to write copy of '$filename'");
661       }
662       else {
663         local *F;
664         if (open F, ">$newfile") {
665           info("Writing copy of '$filename' with changes to '$newfile'");
666           print F $c;
667           close F;
668         }
669         else {
670           error("Cannot open '$newfile' for writing: $!");
671         }
672       }
673     }
674     elsif (exists $opt{patch} || $opt{changes}) {
675       if (exists $opt{patch}) {
676         unless ($patch_opened) {
677           if (open PATCH, ">$opt{patch}") {
678             $patch_opened = 1;
679           }
680           else {
681             error("Cannot open '$opt{patch}' for writing: $!");
682             delete $opt{patch};
683             $opt{changes} = 1;
684             goto fallback;
685           }
686         }
687         mydiff(\*PATCH, $filename, $c);
688       }
689       else {
690 fallback:
691         info("Suggested changes:");
692         mydiff(\*STDOUT, $filename, $c);
693       }
694     }
695     else {
696       my $s = $file{changes} == 1 ? '' : 's';
697       info("$file{changes} potentially required change$s detected");
698     }
699   }
700   else {
701     info("Looks good");
702   }
703 }
704
705 close PATCH if $patch_opened;
706
707 exit 0;
708
709 #######################################################################
710
711 sub try_use { eval "use @_;"; return $@ eq '' }
712
713 sub mydiff
714 {
715   local *F = shift;
716   my($file, $str) = @_;
717   my $diff;
718
719   if (exists $opt{diff}) {
720     $diff = run_diff($opt{diff}, $file, $str);
721   }
722
723   if (!defined $diff and try_use('Text::Diff')) {
724     $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
725     $diff = <<HEADER . $diff;
726 --- $file
727 +++ $file.patched
728 HEADER
729   }
730
731   if (!defined $diff) {
732     $diff = run_diff('diff -u', $file, $str);
733   }
734
735   if (!defined $diff) {
736     $diff = run_diff('diff', $file, $str);
737   }
738
739   if (!defined $diff) {
740     error("Cannot generate a diff. Please install Text::Diff or use --copy.");
741     return;
742   }
743
744   print F $diff;
745 }
746
747 sub run_diff
748 {
749   my($prog, $file, $str) = @_;
750   my $tmp = 'dppptemp';
751   my $suf = 'aaa';
752   my $diff = '';
753   local *F;
754
755   while (-e "$tmp.$suf") { $suf++ }
756   $tmp = "$tmp.$suf";
757
758   if (open F, ">$tmp") {
759     print F $str;
760     close F;
761
762     if (open F, "$prog $file $tmp |") {
763       while (<F>) {
764         s/\Q$tmp\E/$file.patched/;
765         $diff .= $_;
766       }
767       close F;
768       unlink $tmp;
769       return $diff;
770     }
771
772     unlink $tmp;
773   }
774   else {
775     error("Cannot open '$tmp' for writing: $!");
776   }
777
778   return undef;
779 }
780
781 sub rec_depend
782 {
783   my($func, $seen) = @_;
784   return () unless exists $depends{$func};
785   $seen = {%{$seen||{}}};
786   return () if $seen->{$func}++;
787   my %s;
788   grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}};
789 }
790
791 sub info
792 {
793   $opt{quiet} and return;
794   print @_, "\n";
795 }
796
797 sub diag
798 {
799   $opt{quiet} and return;
800   $opt{diag} and print @_, "\n";
801 }
802
803 sub warning
804 {
805   $opt{quiet} and return;
806   print "*** ", @_, "\n";
807 }
808
809 sub error
810 {
811   print "*** ERROR: ", @_, "\n";
812 }
813
814 my %given_hints;
815 my %given_warnings;
816 sub hint
817 {
818   $opt{quiet} and return;
819   my $func = shift;
820   my $rv = 0;
821   if (exists $warnings{$func} && !$given_warnings{$func}++) {
822     my $warn = $warnings{$func};
823     $warn =~ s!^!*** !mg;
824     print "*** WARNING: $func\n", $warn;
825     $rv++;
826   }
827   if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) {
828     my $hint = $hints{$func};
829     $hint =~ s/^/   /mg;
830     print "   --- hint for $func ---\n", $hint;
831   }
832   $rv;
833 }
834
835 sub usage
836 {
837   my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
838   my %M = ( 'I' => '*' );
839   $usage =~ s/^\s*perl\s+\S+/$^X $0/;
840   $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
841
842   print <<ENDUSAGE;
843
844 Usage: $usage
845
846 See perldoc $0 for details.
847
848 ENDUSAGE
849
850   exit 2;
851 }
852
853 sub strip
854 {
855   my $self = do { local(@ARGV,$/)=($0); <> };
856   my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms;
857   $copy =~ s/^(?=\S+)/    /gms;
858   $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms;
859   $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
860 if (\@ARGV && \$ARGV[0] eq '--unstrip') {
861   eval { require Devel::PPPort };
862   \$@ and die "Cannot require Devel::PPPort, please install.\\n";
863   if (eval \$Devel::PPPort::VERSION < $VERSION) {
864     die "$0 was originally generated with Devel::PPPort $VERSION.\\n"
865       . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n"
866       . "Please install a newer version, or --unstrip will not work.\\n";
867   }
868   Devel::PPPort::WriteFile(\$0);
869   exit 0;
870 }
871 print <<END;
872
873 Sorry, but this is a stripped version of \$0.
874
875 To be able to use its original script and doc functionality,
876 please try to regenerate this file using:
877
878   \$^X \$0 --unstrip
879
880 END
881 /ms;
882   my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms;
883   $c =~ s{
884     / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*)
885   | ( "[^"\\]*(?:\\.[^"\\]*)*"
886     | '[^'\\]*(?:\\.[^'\\]*)*' )
887   | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex;
888   $c =~ s!\s+$!!mg;
889   $c =~ s!^$LF!!mg;
890   $c =~ s!^\s*#\s*!#!mg;
891   $c =~ s!^\s+!!mg;
892
893   open OUT, ">$0" or die "cannot strip $0: $!\n";
894   print OUT "$pl$c\n";
895
896   exit 0;
897 }