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