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