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