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