Commit | Line | Data |
---|---|---|
82196dc6 TC |
1 | #!perl |
2 | # this should be perl 5.8 compatible, since it will be used | |
3 | # with old perls while testing dist modules on those perls | |
4 | use strict; | |
5 | use warnings; | |
6 | use File::Temp "tempdir"; | |
7 | use ExtUtils::Manifest "maniread"; | |
8 | use Cwd "getcwd"; | |
9 | ||
10 | -f "Configure" | |
11 | or die "Expected to be run from a perl checkout"; | |
12 | ||
13 | my $manifest = maniread(); | |
14 | ||
15 | my $start = getcwd() | |
16 | or die "Cannot fetch current directory: $!\n"; | |
17 | ||
18 | # get ppport.h | |
19 | my $pppdir = test_dist("Devel-PPPort"); | |
20 | ||
21 | my $pppfile = "$pppdir/ppport.h"; | |
22 | ||
23 | -f $pppfile | |
24 | or die "No ppport.h found in $pppdir\n"; | |
25 | ||
445772e5 TC |
26 | # Devel-PPPort is manually processed before anything else to ensure we |
27 | # have an up to date ppport.h | |
28 | opendir my $distdir, "dist" | |
29 | or die "Cannot opendir 'dist': $!\n"; | |
82196dc6 TC |
30 | my @dists = sort { lc $a cmp lc $b } grep { /^\w/ && $_ ne "Devel-PPPort" } readdir $distdir; |
31 | closedir $distdir; | |
32 | ||
445772e5 TC |
33 | # These may end up being included if their problems are resolved |
34 | { | |
35 | # https://github.com/Perl/version.pm claims CPAN is upstream | |
36 | @dists = grep { $_ ne "version" } @dists; | |
82196dc6 | 37 | |
445772e5 TC |
38 | # Safe is tied pretty heavily to core |
39 | # in any case it didn't seem simple to fix | |
40 | @dists = grep { $_ ne "Safe" } @dists; | |
41 | } | |
82196dc6 TC |
42 | |
43 | for my $dist (@dists) { | |
44 | test_dist($dist); | |
45 | } | |
46 | ||
47 | sub test_dist { | |
48 | my ($name) = @_; | |
49 | ||
50 | print "*** Testing $name ***\n"; | |
51 | my $dir = tempdir( CLEANUP => 1); | |
445772e5 TC |
52 | system "cp", "-a", "dist/$name/.", "$dir/." |
53 | and die "Cannot copy dist files to working directory\n"; | |
82196dc6 | 54 | chdir $dir |
445772e5 | 55 | or die "Cannot chdir to dist working directory '$dir': $!\n"; |
82196dc6 TC |
56 | if ($pppfile) { |
57 | system "cp", $pppfile, "." | |
58 | and die "Cannot copy $pppfile to .\n"; | |
59 | } | |
60 | if ($name eq "IO" || $name eq "threads" || $name eq "threads-shared") { | |
61 | write_testpl(); | |
62 | } | |
63 | unless (-f "Makefile.PL") { | |
64 | print " Creating Makefile.PL for $name\n"; | |
65 | my $key = "ABSTRACT_FROM"; | |
66 | my @parts = split /-/, $name; | |
67 | my $last = $parts[-1]; | |
68 | my $fromname; | |
69 | for my $check ("$last.pm", join("/", "lib", @parts) . ".pm") { | |
70 | if (-f $check) { | |
71 | $fromname = $check; | |
72 | last; | |
73 | } | |
74 | } | |
75 | $fromname | |
76 | or die "Cannot find ABSTRACT_FROM for $name\n"; | |
77 | my $value = $fromname; | |
78 | open my $fh, ">", "Makefile.PL" | |
79 | or die "Cannot create Makefile.PL: $!\n"; | |
80 | # adapted from make_ext.pl | |
81 | printf $fh <<'EOM', $name, $fromname, $key, $value; | |
82 | use strict; | |
83 | use ExtUtils::MakeMaker; | |
84 | ||
85 | # This is what the .PL extracts to. Not the ultimate file that is installed. | |
86 | # (ie Win32 runs pl2bat after this) | |
87 | ||
88 | # Doing this here avoids all sort of quoting issues that would come from | |
89 | # attempting to write out perl source with literals to generate the arrays and | |
90 | # hash. | |
91 | my @temps = 'Makefile.PL'; | |
92 | foreach (glob('scripts/pod*.PL')) { | |
93 | # The various pod*.PL extractors change directory. Doing that with relative | |
94 | # paths in @INC breaks. It seems the lesser of two evils to copy (to avoid) | |
95 | # the chdir doing anything, than to attempt to convert lib paths to | |
96 | # absolute, and potentially run into problems with quoting special | |
97 | # characters in the path to our build dir (such as spaces) | |
98 | require File::Copy; | |
99 | ||
100 | my $temp = $_; | |
101 | $temp =~ s!scripts/!!; | |
102 | File::Copy::copy($_, $temp) or die "Can't copy $temp to $_: $!"; | |
103 | push @temps, $temp; | |
104 | } | |
105 | ||
106 | my $script_ext = $^O eq 'VMS' ? '.com' : ''; | |
107 | my %%pod_scripts; | |
108 | foreach (glob('pod*.PL')) { | |
109 | my $script = $_; | |
110 | s/.PL$/$script_ext/i; | |
111 | $pod_scripts{$script} = $_; | |
112 | } | |
113 | my @exe_files = values %%pod_scripts; | |
114 | ||
115 | WriteMakefile( | |
116 | NAME => '%s', | |
117 | VERSION_FROM => '%s', | |
118 | %-13s => '%s', | |
119 | realclean => { FILES => "@temps" }, | |
120 | (%%pod_scripts ? ( | |
121 | PL_FILES => \%%pod_scripts, | |
122 | EXE_FILES => \@exe_files, | |
123 | clean => { FILES => "@exe_files" }, | |
124 | ) : ()), | |
125 | ); | |
126 | ||
127 | EOM | |
128 | close $fh; | |
129 | } | |
445772e5 | 130 | system $^X, "Makefile.PL" |
82196dc6 TC |
131 | and die "$name: Makefile.PL failed\n"; |
132 | ||
133 | my $verbose = 0; | |
445772e5 | 134 | system "make", "test", "TEST_VERBOSE=$verbose" |
82196dc6 TC |
135 | and die "$name: make test failed\n"; |
136 | ||
445772e5 | 137 | system "make", "install" |
82196dc6 TC |
138 | and die "$name: make install failed\n"; |
139 | ||
140 | chdir $start | |
141 | or die "Cannot return to $start: $!\n"; | |
142 | ||
143 | $dir; | |
144 | } | |
145 | ||
445772e5 TC |
146 | # IO, threads and threads-shared use the blead t/test.pl when tested in core |
147 | # and bundle their own test.pl when distributed on CPAN. | |
148 | # The test.pl source below is from the IO distribution but so far seems sufficient | |
149 | # for threads and threads-shared. | |
150 | # | |
151 | # This might be better as a file in Porting/ rather than embedded here. | |
82196dc6 TC |
152 | sub write_testpl { |
153 | open my $fh, ">", "t/test.pl" | |
154 | or die "Cannot create t/test.pl: $!"; | |
155 | # the blead t/test.pl uses modern features and can't be used here. | |
156 | print $fh <<'EOS'; | |
157 | # | |
158 | # t/test.pl - most of Test::More functionality without the fuss | |
159 | ||
160 | ||
161 | # NOTE: | |
162 | # | |
163 | # Increment ($x++) has a certain amount of cleverness for things like | |
164 | # | |
165 | # $x = 'zz'; | |
166 | # $x++; # $x eq 'aaa'; | |
167 | # | |
168 | # stands more chance of breaking than just a simple | |
169 | # | |
170 | # $x = $x + 1 | |
171 | # | |
172 | # In this file, we use the latter "Baby Perl" approach, and increment | |
173 | # will be worked over by t/op/inc.t | |
174 | ||
175 | $Level = 1; | |
176 | my $test = 1; | |
177 | my $planned; | |
178 | my $noplan; | |
179 | my $Perl; # Safer version of $^X set by which_perl() | |
180 | ||
181 | $TODO = 0; | |
182 | $NO_ENDING = 0; | |
183 | ||
184 | # Use this instead of print to avoid interference while testing globals. | |
185 | sub _print { | |
186 | local($\, $", $,) = (undef, ' ', ''); | |
187 | print STDOUT @_; | |
188 | } | |
189 | ||
190 | sub _print_stderr { | |
191 | local($\, $", $,) = (undef, ' ', ''); | |
192 | print STDERR @_; | |
193 | } | |
194 | ||
195 | sub plan { | |
196 | my $n; | |
197 | if (@_ == 1) { | |
198 | $n = shift; | |
199 | if ($n eq 'no_plan') { | |
200 | undef $n; | |
201 | $noplan = 1; | |
202 | } | |
203 | } else { | |
204 | my %plan = @_; | |
205 | $n = $plan{tests}; | |
206 | } | |
207 | _print "1..$n\n" unless $noplan; | |
208 | $planned = $n; | |
209 | } | |
210 | ||
211 | END { | |
212 | my $ran = $test - 1; | |
213 | if (!$NO_ENDING) { | |
214 | if (defined $planned && $planned != $ran) { | |
215 | _print_stderr | |
216 | "# Looks like you planned $planned tests but ran $ran.\n"; | |
217 | } elsif ($noplan) { | |
218 | _print "1..$ran\n"; | |
219 | } | |
220 | } | |
221 | } | |
222 | ||
223 | # Use this instead of "print STDERR" when outputing failure diagnostic | |
224 | # messages | |
225 | sub _diag { | |
226 | return unless @_; | |
227 | my @mess = map { /^#/ ? "$_\n" : "# $_\n" } | |
228 | map { split /\n/ } @_; | |
229 | $TODO ? _print(@mess) : _print_stderr(@mess); | |
230 | } | |
231 | ||
232 | sub diag { | |
233 | _diag(@_); | |
234 | } | |
235 | ||
236 | sub skip_all { | |
237 | if (@_) { | |
238 | _print "1..0 # Skip @_\n"; | |
239 | } else { | |
240 | _print "1..0\n"; | |
241 | } | |
242 | exit(0); | |
243 | } | |
244 | ||
245 | sub _ok { | |
246 | my ($pass, $where, $name, @mess) = @_; | |
247 | # Do not try to microoptimize by factoring out the "not ". | |
248 | # VMS will avenge. | |
249 | my $out; | |
250 | if ($name) { | |
251 | # escape out '#' or it will interfere with '# skip' and such | |
252 | $name =~ s/#/\\#/g; | |
253 | $out = $pass ? "ok $test - $name" : "not ok $test - $name"; | |
254 | } else { | |
255 | $out = $pass ? "ok $test" : "not ok $test"; | |
256 | } | |
257 | ||
258 | $out .= " # TODO $TODO" if $TODO; | |
259 | _print "$out\n"; | |
260 | ||
261 | unless ($pass) { | |
262 | _diag "# Failed $where\n"; | |
263 | } | |
264 | ||
265 | # Ensure that the message is properly escaped. | |
266 | _diag @mess; | |
267 | ||
268 | $test = $test + 1; # don't use ++ | |
269 | ||
270 | return $pass; | |
271 | } | |
272 | ||
273 | sub _where { | |
274 | my @caller = caller($Level); | |
275 | return "at $caller[1] line $caller[2]"; | |
276 | } | |
277 | ||
278 | # DON'T use this for matches. Use like() instead. | |
279 | sub ok ($@) { | |
280 | my ($pass, $name, @mess) = @_; | |
281 | _ok($pass, _where(), $name, @mess); | |
282 | } | |
283 | ||
284 | sub _q { | |
285 | my $x = shift; | |
286 | return 'undef' unless defined $x; | |
287 | my $q = $x; | |
288 | $q =~ s/\\/\\\\/g; | |
289 | $q =~ s/'/\\'/g; | |
290 | return "'$q'"; | |
291 | } | |
292 | ||
293 | sub _qq { | |
294 | my $x = shift; | |
295 | return defined $x ? '"' . display ($x) . '"' : 'undef'; | |
296 | }; | |
297 | ||
298 | # keys are the codes \n etc map to, values are 2 char strings such as \n | |
299 | my %backslash_escape; | |
300 | foreach my $x (split //, 'nrtfa\\\'"') { | |
301 | $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; | |
302 | } | |
303 | # A way to display scalars containing control characters and Unicode. | |
304 | # Trying to avoid setting $_, or relying on local $_ to work. | |
305 | sub display { | |
306 | my @result; | |
307 | foreach my $x (@_) { | |
308 | if (defined $x and not ref $x) { | |
309 | my $y = ''; | |
310 | foreach my $c (unpack("U*", $x)) { | |
311 | if ($c > 255) { | |
312 | $y .= sprintf "\\x{%x}", $c; | |
313 | } elsif ($backslash_escape{$c}) { | |
314 | $y .= $backslash_escape{$c}; | |
315 | } else { | |
316 | my $z = chr $c; # Maybe we can get away with a literal... | |
317 | $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; | |
318 | $y .= $z; | |
319 | } | |
320 | } | |
321 | $x = $y; | |
322 | } | |
323 | return $x unless wantarray; | |
324 | push @result, $x; | |
325 | } | |
326 | return @result; | |
327 | } | |
328 | ||
329 | sub is ($$@) { | |
330 | my ($got, $expected, $name, @mess) = @_; | |
331 | ||
332 | my $pass; | |
333 | if( !defined $got || !defined $expected ) { | |
334 | # undef only matches undef | |
335 | $pass = !defined $got && !defined $expected; | |
336 | } | |
337 | else { | |
338 | $pass = $got eq $expected; | |
339 | } | |
340 | ||
341 | unless ($pass) { | |
342 | unshift(@mess, "# got "._q($got)."\n", | |
343 | "# expected "._q($expected)."\n"); | |
344 | } | |
345 | _ok($pass, _where(), $name, @mess); | |
346 | } | |
347 | ||
348 | sub isnt ($$@) { | |
349 | my ($got, $isnt, $name, @mess) = @_; | |
350 | ||
351 | my $pass; | |
352 | if( !defined $got || !defined $isnt ) { | |
353 | # undef only matches undef | |
354 | $pass = defined $got || defined $isnt; | |
355 | } | |
356 | else { | |
357 | $pass = $got ne $isnt; | |
358 | } | |
359 | ||
360 | unless( $pass ) { | |
361 | unshift(@mess, "# it should not be "._q($got)."\n", | |
362 | "# but it is.\n"); | |
363 | } | |
364 | _ok($pass, _where(), $name, @mess); | |
365 | } | |
366 | ||
367 | sub cmp_ok ($$$@) { | |
368 | my($got, $type, $expected, $name, @mess) = @_; | |
369 | ||
370 | my $pass; | |
371 | { | |
372 | local $^W = 0; | |
373 | local($@,$!); # don't interfere with $@ | |
374 | # eval() sometimes resets $! | |
375 | $pass = eval "\$got $type \$expected"; | |
376 | } | |
377 | unless ($pass) { | |
378 | # It seems Irix long doubles can have 2147483648 and 2147483648 | |
379 | # that stringify to the same thing but are acutally numerically | |
380 | # different. Display the numbers if $type isn't a string operator, | |
381 | # and the numbers are stringwise the same. | |
382 | # (all string operators have alphabetic names, so tr/a-z// is true) | |
383 | # This will also show numbers for some uneeded cases, but will | |
384 | # definately be helpful for things such as == and <= that fail | |
385 | if ($got eq $expected and $type !~ tr/a-z//) { | |
386 | unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; | |
387 | } | |
388 | unshift(@mess, "# got "._q($got)."\n", | |
389 | "# expected $type "._q($expected)."\n"); | |
390 | } | |
391 | _ok($pass, _where(), $name, @mess); | |
392 | } | |
393 | ||
394 | # Check that $got is within $range of $expected | |
395 | # if $range is 0, then check it's exact | |
396 | # else if $expected is 0, then $range is an absolute value | |
397 | # otherwise $range is a fractional error. | |
398 | # Here $range must be numeric, >= 0 | |
399 | # Non numeric ranges might be a useful future extension. (eg %) | |
400 | sub within ($$$@) { | |
401 | my ($got, $expected, $range, $name, @mess) = @_; | |
402 | my $pass; | |
403 | if (!defined $got or !defined $expected or !defined $range) { | |
404 | # This is a fail, but doesn't need extra diagnostics | |
405 | } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { | |
406 | # This is a fail | |
407 | unshift @mess, "# got, expected and range must be numeric\n"; | |
408 | } elsif ($range < 0) { | |
409 | # This is also a fail | |
410 | unshift @mess, "# range must not be negative\n"; | |
411 | } elsif ($range == 0) { | |
412 | # Within 0 is == | |
413 | $pass = $got == $expected; | |
414 | } elsif ($expected == 0) { | |
415 | # If expected is 0, treat range as absolute | |
416 | $pass = ($got <= $range) && ($got >= - $range); | |
417 | } else { | |
418 | my $diff = $got - $expected; | |
419 | $pass = abs ($diff / $expected) < $range; | |
420 | } | |
421 | unless ($pass) { | |
422 | if ($got eq $expected) { | |
423 | unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; | |
424 | } | |
425 | unshift@mess, "# got "._q($got)."\n", | |
426 | "# expected "._q($expected)." (within "._q($range).")\n"; | |
427 | } | |
428 | _ok($pass, _where(), $name, @mess); | |
429 | } | |
430 | ||
431 | # Note: this isn't quite as fancy as Test::More::like(). | |
432 | ||
433 | sub like ($$@) { like_yn (0,@_) }; # 0 for - | |
434 | sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- | |
435 | ||
436 | sub like_yn ($$$@) { | |
437 | my ($flip, $got, $expected, $name, @mess) = @_; | |
438 | my $pass; | |
439 | $pass = $got =~ /$expected/ if !$flip; | |
440 | $pass = $got !~ /$expected/ if $flip; | |
441 | unless ($pass) { | |
442 | unshift(@mess, "# got '$got'\n", | |
443 | $flip | |
444 | ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); | |
445 | } | |
446 | local $Level = $Level + 1; | |
447 | _ok($pass, _where(), $name, @mess); | |
448 | } | |
449 | ||
450 | sub pass { | |
451 | _ok(1, '', @_); | |
452 | } | |
453 | ||
454 | sub fail { | |
455 | _ok(0, _where(), @_); | |
456 | } | |
457 | ||
458 | sub curr_test { | |
459 | $test = shift if @_; | |
460 | return $test; | |
461 | } | |
462 | ||
463 | sub next_test { | |
464 | my $retval = $test; | |
465 | $test = $test + 1; # don't use ++ | |
466 | $retval; | |
467 | } | |
468 | ||
469 | # Note: can't pass multipart messages since we try to | |
470 | # be compatible with Test::More::skip(). | |
471 | sub skip { | |
472 | my $why = shift; | |
473 | my $n = @_ ? shift : 1; | |
474 | for (1..$n) { | |
475 | _print "ok $test # skip $why\n"; | |
476 | $test = $test + 1; | |
477 | } | |
478 | local $^W = 0; | |
479 | last SKIP; | |
480 | } | |
481 | ||
482 | sub todo_skip { | |
483 | my $why = shift; | |
484 | my $n = @_ ? shift : 1; | |
485 | ||
486 | for (1..$n) { | |
487 | _print "not ok $test # TODO & SKIP $why\n"; | |
488 | $test = $test + 1; | |
489 | } | |
490 | local $^W = 0; | |
491 | last TODO; | |
492 | } | |
493 | ||
494 | sub eq_array { | |
495 | my ($ra, $rb) = @_; | |
496 | return 0 unless $#$ra == $#$rb; | |
497 | for my $i (0..$#$ra) { | |
498 | next if !defined $ra->[$i] && !defined $rb->[$i]; | |
499 | return 0 if !defined $ra->[$i]; | |
500 | return 0 if !defined $rb->[$i]; | |
501 | return 0 unless $ra->[$i] eq $rb->[$i]; | |
502 | } | |
503 | return 1; | |
504 | } | |
505 | ||
506 | sub eq_hash { | |
507 | my ($orig, $suspect) = @_; | |
508 | my $fail; | |
509 | while (my ($key, $value) = each %$suspect) { | |
510 | # Force a hash recompute if this perl's internals can cache the hash key. | |
511 | $key = "" . $key; | |
512 | if (exists $orig->{$key}) { | |
513 | if ($orig->{$key} ne $value) { | |
514 | _print "# key ", _qq($key), " was ", _qq($orig->{$key}), | |
515 | " now ", _qq($value), "\n"; | |
516 | $fail = 1; | |
517 | } | |
518 | } else { | |
519 | _print "# key ", _qq($key), " is ", _qq($value), | |
520 | ", not in original.\n"; | |
521 | $fail = 1; | |
522 | } | |
523 | } | |
524 | foreach (keys %$orig) { | |
525 | # Force a hash recompute if this perl's internals can cache the hash key. | |
526 | $_ = "" . $_; | |
527 | next if (exists $suspect->{$_}); | |
528 | _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; | |
529 | $fail = 1; | |
530 | } | |
531 | !$fail; | |
532 | } | |
533 | ||
534 | sub require_ok ($) { | |
535 | my ($require) = @_; | |
536 | eval <<REQUIRE_OK; | |
537 | require $require; | |
538 | REQUIRE_OK | |
539 | _ok(!$@, _where(), "require $require"); | |
540 | } | |
541 | ||
542 | sub use_ok ($) { | |
543 | my ($use) = @_; | |
544 | eval <<USE_OK; | |
545 | use $use; | |
546 | USE_OK | |
547 | _ok(!$@, _where(), "use $use"); | |
548 | } | |
549 | ||
550 | # runperl - Runs a separate perl interpreter. | |
551 | # Arguments : | |
552 | # switches => [ command-line switches ] | |
553 | # nolib => 1 # don't use -I../lib (included by default) | |
554 | # prog => one-liner (avoid quotes) | |
555 | # progs => [ multi-liner (avoid quotes) ] | |
556 | # progfile => perl script | |
557 | # stdin => string to feed the stdin | |
558 | # stderr => redirect stderr to stdout | |
559 | # args => [ command-line arguments to the perl program ] | |
560 | # verbose => print the command line | |
561 | ||
562 | my $is_mswin = $^O eq 'MSWin32'; | |
563 | my $is_netware = $^O eq 'NetWare'; | |
564 | my $is_macos = $^O eq 'MacOS'; | |
565 | my $is_vms = $^O eq 'VMS'; | |
566 | my $is_cygwin = $^O eq 'cygwin'; | |
567 | ||
568 | sub _quote_args { | |
569 | my ($runperl, $args) = @_; | |
570 | ||
571 | foreach (@$args) { | |
572 | # In VMS protect with doublequotes because otherwise | |
573 | # DCL will lowercase -- unless already doublequoted. | |
574 | $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; | |
575 | $$runperl .= ' ' . $_; | |
576 | } | |
577 | } | |
578 | ||
579 | sub _create_runperl { # Create the string to qx in runperl(). | |
580 | my %args = @_; | |
581 | my $runperl = which_perl(); | |
582 | if ($runperl =~ m/\s/) { | |
583 | $runperl = qq{"$runperl"}; | |
584 | } | |
585 | #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind | |
586 | if ($ENV{PERL_RUNPERL_DEBUG}) { | |
587 | $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; | |
588 | } | |
589 | unless ($args{nolib}) { | |
590 | if ($is_macos) { | |
591 | $runperl .= ' -I::lib'; | |
592 | # Use UNIX style error messages instead of MPW style. | |
593 | $runperl .= ' -MMac::err=unix' if $args{stderr}; | |
594 | } | |
595 | else { | |
596 | $runperl .= ' "-I../lib"'; # doublequotes because of VMS | |
597 | } | |
598 | } | |
599 | if ($args{switches}) { | |
600 | local $Level = 2; | |
601 | die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() | |
602 | unless ref $args{switches} eq "ARRAY"; | |
603 | _quote_args(\$runperl, $args{switches}); | |
604 | } | |
605 | if (defined $args{prog}) { | |
606 | die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() | |
607 | if defined $args{progs}; | |
608 | $args{progs} = [$args{prog}] | |
609 | } | |
610 | if (defined $args{progs}) { | |
611 | die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() | |
612 | unless ref $args{progs} eq "ARRAY"; | |
613 | foreach my $prog (@{$args{progs}}) { | |
614 | if ($is_mswin || $is_netware || $is_vms) { | |
615 | $runperl .= qq ( -e "$prog" ); | |
616 | } | |
617 | else { | |
618 | $runperl .= qq ( -e '$prog' ); | |
619 | } | |
620 | } | |
621 | } elsif (defined $args{progfile}) { | |
622 | $runperl .= qq( "$args{progfile}"); | |
623 | } else { | |
624 | # You probaby didn't want to be sucking in from the upstream stdin | |
625 | die "test.pl:runperl(): none of prog, progs, progfile, args, " | |
626 | . " switches or stdin specified" | |
627 | unless defined $args{args} or defined $args{switches} | |
628 | or defined $args{stdin}; | |
629 | } | |
630 | if (defined $args{stdin}) { | |
631 | # so we don't try to put literal newlines and crs onto the | |
632 | # command line. | |
633 | $args{stdin} =~ s/\n/\\n/g; | |
634 | $args{stdin} =~ s/\r/\\r/g; | |
635 | ||
636 | if ($is_mswin || $is_netware || $is_vms) { | |
637 | $runperl = qq{$Perl -e "print qq(} . | |
638 | $args{stdin} . q{)" | } . $runperl; | |
639 | } | |
640 | elsif ($is_macos) { | |
641 | # MacOS can only do two processes under MPW at once; | |
642 | # the test itself is one; we can't do two more, so | |
643 | # write to temp file | |
644 | my $stdin = qq{$Perl -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; | |
645 | if ($args{verbose}) { | |
646 | my $stdindisplay = $stdin; | |
647 | $stdindisplay =~ s/\n/\n\#/g; | |
648 | _print_stderr "# $stdindisplay\n"; | |
649 | } | |
650 | `$stdin`; | |
651 | $runperl .= q{ < teststdin }; | |
652 | } | |
653 | else { | |
654 | $runperl = qq{$Perl -e 'print qq(} . | |
655 | $args{stdin} . q{)' | } . $runperl; | |
656 | } | |
657 | } | |
658 | if (defined $args{args}) { | |
659 | _quote_args(\$runperl, $args{args}); | |
660 | } | |
661 | $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; | |
662 | $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; | |
663 | if ($args{verbose}) { | |
664 | my $runperldisplay = $runperl; | |
665 | $runperldisplay =~ s/\n/\n\#/g; | |
666 | _print_stderr "# $runperldisplay\n"; | |
667 | } | |
668 | return $runperl; | |
669 | } | |
670 | ||
671 | sub runperl { | |
672 | die "test.pl:runperl() does not take a hashref" | |
673 | if ref $_[0] and ref $_[0] eq 'HASH'; | |
674 | my $runperl = &_create_runperl; | |
675 | my $result; | |
676 | ||
677 | my $tainted = ${^TAINT}; | |
678 | my %args = @_; | |
679 | exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; | |
680 | ||
681 | if ($tainted) { | |
682 | # We will assume that if you're running under -T, you really mean to | |
683 | # run a fresh perl, so we'll brute force launder everything for you | |
684 | my $sep; | |
685 | ||
686 | if (! eval 'require Config; 1') { | |
687 | warn "test.pl had problems loading Config: $@"; | |
688 | $sep = ':'; | |
689 | } else { | |
690 | $sep = $Config::Config{path_sep}; | |
691 | } | |
692 | ||
693 | my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); | |
694 | local @ENV{@keys} = (); | |
695 | # Untaint, plus take out . and empty string: | |
696 | local $ENV{'DCL$PATH'} = $1 if $is_vms && ($ENV{'DCL$PATH'} =~ /(.*)/s); | |
697 | $ENV{PATH} =~ /(.*)/s; | |
698 | local $ENV{PATH} = | |
699 | join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and | |
700 | ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } | |
701 | split quotemeta ($sep), $1; | |
702 | $ENV{PATH} .= "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin | |
703 | ||
704 | $runperl =~ /(.*)/s; | |
705 | $runperl = $1; | |
706 | ||
707 | $result = `$runperl`; | |
708 | } else { | |
709 | $result = `$runperl`; | |
710 | } | |
711 | $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these | |
712 | return $result; | |
713 | } | |
714 | ||
715 | *run_perl = \&runperl; # Nice alias. | |
716 | ||
717 | sub DIE { | |
718 | _print_stderr "# @_\n"; | |
719 | exit 1; | |
720 | } | |
721 | ||
722 | # A somewhat safer version of the sometimes wrong $^X. | |
723 | sub which_perl { | |
724 | unless (defined $Perl) { | |
725 | $Perl = $^X; | |
726 | ||
727 | # VMS should have 'perl' aliased properly | |
728 | return $Perl if $^O eq 'VMS'; | |
729 | ||
730 | my $exe; | |
731 | if (! eval 'require Config; 1') { | |
732 | warn "test.pl had problems loading Config: $@"; | |
733 | $exe = ''; | |
734 | } else { | |
735 | $exe = $Config::Config{_exe}; | |
736 | } | |
737 | $exe = '' unless defined $exe; | |
738 | ||
739 | # This doesn't absolutize the path: beware of future chdirs(). | |
740 | # We could do File::Spec->abs2rel() but that does getcwd()s, | |
741 | # which is a bit heavyweight to do here. | |
742 | ||
743 | if ($Perl =~ /^perl\Q$exe\E$/i) { | |
744 | my $perl = "perl$exe"; | |
745 | if (! eval 'require File::Spec; 1') { | |
746 | warn "test.pl had problems loading File::Spec: $@"; | |
747 | $Perl = "./$perl"; | |
748 | } else { | |
749 | $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); | |
750 | } | |
751 | } | |
752 | ||
753 | # Build up the name of the executable file from the name of | |
754 | # the command. | |
755 | ||
756 | if ($Perl !~ /\Q$exe\E$/i) { | |
757 | $Perl .= $exe; | |
758 | } | |
759 | ||
760 | warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; | |
761 | ||
762 | # For subcommands to use. | |
763 | $ENV{PERLEXE} = $Perl; | |
764 | } | |
765 | return $Perl; | |
766 | } | |
767 | ||
768 | sub unlink_all { | |
769 | foreach my $file (@_) { | |
770 | 1 while unlink $file; | |
771 | _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; | |
772 | } | |
773 | } | |
774 | ||
775 | my %tmpfiles; | |
776 | END { unlink_all keys %tmpfiles } | |
777 | ||
778 | # A regexp that matches the tempfile names | |
779 | $::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; | |
780 | ||
781 | # Avoid ++, avoid ranges, avoid split // | |
782 | my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); | |
783 | sub tempfile { | |
784 | my $count = 0; | |
785 | do { | |
786 | my $temp = $count; | |
787 | my $try = "tmp$$"; | |
788 | do { | |
789 | $try .= $letters[$temp % 26]; | |
790 | $temp = int ($temp / 26); | |
791 | } while $temp; | |
792 | # Need to note all the file names we allocated, as a second request may | |
793 | # come before the first is created. | |
794 | if (!-e $try && !$tmpfiles{$try}) { | |
795 | # We have a winner | |
796 | $tmpfiles{$try}++; | |
797 | return $try; | |
798 | } | |
799 | $count = $count + 1; | |
800 | } while $count < 26 * 26; | |
801 | die "Can't find temporary file name starting 'tmp$$'"; | |
802 | } | |
803 | ||
804 | # This is the temporary file for _fresh_perl | |
805 | my $tmpfile = tempfile(); | |
806 | ||
807 | # | |
808 | # _fresh_perl | |
809 | # | |
810 | # The $resolve must be a subref that tests the first argument | |
811 | # for success, or returns the definition of success (e.g. the | |
812 | # expected scalar) if given no arguments. | |
813 | # | |
814 | ||
815 | sub _fresh_perl { | |
816 | my($prog, $resolve, $runperl_args, $name) = @_; | |
817 | ||
818 | $runperl_args ||= {}; | |
819 | $runperl_args->{progfile} = $tmpfile; | |
820 | $runperl_args->{stderr} = 1; | |
821 | ||
822 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; | |
823 | ||
824 | # VMS adjustments | |
825 | if( $^O eq 'VMS' ) { | |
826 | $prog =~ s#/dev/null#NL:#; | |
827 | ||
828 | # VMS file locking | |
829 | $prog =~ s{if \(-e _ and -f _ and -r _\)} | |
830 | {if (-e _ and -f _)} | |
831 | } | |
832 | ||
833 | print TEST $prog; | |
834 | close TEST or die "Cannot close $tmpfile: $!"; | |
835 | ||
836 | my $results = runperl(%$runperl_args); | |
837 | my $status = $?; | |
838 | ||
839 | # Clean up the results into something a bit more predictable. | |
840 | $results =~ s/\n+$//; | |
841 | $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; | |
842 | $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; | |
843 | ||
844 | # bison says 'parse error' instead of 'syntax error', | |
845 | # various yaccs may or may not capitalize 'syntax'. | |
846 | $results =~ s/^(syntax|parse) error/syntax error/mig; | |
847 | ||
848 | if ($^O eq 'VMS') { | |
849 | # some tests will trigger VMS messages that won't be expected | |
850 | $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; | |
851 | ||
852 | # pipes double these sometimes | |
853 | $results =~ s/\n\n/\n/g; | |
854 | } | |
855 | ||
856 | my $pass = $resolve->($results); | |
857 | unless ($pass) { | |
858 | _diag "# PROG: \n$prog\n"; | |
859 | _diag "# EXPECTED:\n", $resolve->(), "\n"; | |
860 | _diag "# GOT:\n$results\n"; | |
861 | _diag "# STATUS: $status\n"; | |
862 | } | |
863 | ||
864 | # Use the first line of the program as a name if none was given | |
865 | unless( $name ) { | |
866 | ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; | |
867 | $name .= '...' if length $first_line > length $name; | |
868 | } | |
869 | ||
870 | _ok($pass, _where(), "fresh_perl - $name"); | |
871 | } | |
872 | ||
873 | # | |
874 | # fresh_perl_is | |
875 | # | |
876 | # Combination of run_perl() and is(). | |
877 | # | |
878 | ||
879 | sub fresh_perl_is { | |
880 | my($prog, $expected, $runperl_args, $name) = @_; | |
881 | local $Level = 2; | |
882 | _fresh_perl($prog, | |
883 | sub { @_ ? $_[0] eq $expected : $expected }, | |
884 | $runperl_args, $name); | |
885 | } | |
886 | ||
887 | # | |
888 | # fresh_perl_like | |
889 | # | |
890 | # Combination of run_perl() and like(). | |
891 | # | |
892 | ||
893 | sub fresh_perl_like { | |
894 | my($prog, $expected, $runperl_args, $name) = @_; | |
895 | local $Level = 2; | |
896 | _fresh_perl($prog, | |
897 | sub { @_ ? | |
898 | $_[0] =~ (ref $expected ? $expected : /$expected/) : | |
899 | $expected }, | |
900 | $runperl_args, $name); | |
901 | } | |
902 | ||
903 | sub can_ok ($@) { | |
904 | my($proto, @methods) = @_; | |
905 | my $class = ref $proto || $proto; | |
906 | ||
907 | unless( @methods ) { | |
908 | return _ok( 0, _where(), "$class->can(...)" ); | |
909 | } | |
910 | ||
911 | my @nok = (); | |
912 | foreach my $method (@methods) { | |
913 | local($!, $@); # don't interfere with caller's $@ | |
914 | # eval sometimes resets $! | |
915 | eval { $proto->can($method) } || push @nok, $method; | |
916 | } | |
917 | ||
918 | my $name; | |
919 | $name = @methods == 1 ? "$class->can('$methods[0]')" | |
920 | : "$class->can(...)"; | |
921 | ||
922 | _ok( !@nok, _where(), $name ); | |
923 | } | |
924 | ||
925 | sub isa_ok ($$;$) { | |
926 | my($object, $class, $obj_name) = @_; | |
927 | ||
928 | my $diag; | |
929 | $obj_name = 'The object' unless defined $obj_name; | |
930 | my $name = "$obj_name isa $class"; | |
931 | if( !defined $object ) { | |
932 | $diag = "$obj_name isn't defined"; | |
933 | } | |
934 | elsif( !ref $object ) { | |
935 | $diag = "$obj_name isn't a reference"; | |
936 | } | |
937 | else { | |
938 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides | |
939 | local($@, $!); # eval sometimes resets $! | |
940 | my $rslt = eval { $object->isa($class) }; | |
941 | if( $@ ) { | |
942 | if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { | |
943 | if( !UNIVERSAL::isa($object, $class) ) { | |
944 | my $ref = ref $object; | |
945 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; | |
946 | } | |
947 | } else { | |
948 | die <<WHOA; | |
949 | WHOA! I tried to call ->isa on your object and got some weird error. | |
950 | This should never happen. Please contact the author immediately. | |
951 | Here's the error. | |
952 | $@ | |
953 | WHOA | |
954 | } | |
955 | } | |
956 | elsif( !$rslt ) { | |
957 | my $ref = ref $object; | |
958 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; | |
959 | } | |
960 | } | |
961 | ||
962 | _ok( !$diag, _where(), $name ); | |
963 | } | |
964 | ||
965 | # Set a watchdog to timeout the entire test file | |
966 | # NOTE: If the test file uses 'threads', then call the watchdog() function | |
967 | # _AFTER_ the 'threads' module is loaded. | |
968 | sub watchdog ($) | |
969 | { | |
970 | my $timeout = shift; | |
971 | my $timeout_msg = 'Test process timed out - terminating'; | |
972 | ||
973 | my $pid_to_kill = $$; # PID for this process | |
974 | ||
975 | # Don't use a watchdog process if 'threads' is loaded - | |
976 | # use a watchdog thread instead | |
977 | if (! $threads::threads) { | |
978 | ||
979 | # On Windows and VMS, try launching a watchdog process | |
980 | # using system(1, ...) (see perlport.pod) | |
981 | if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { | |
982 | # On Windows, try to get the 'real' PID | |
983 | if ($^O eq 'MSWin32') { | |
984 | eval { require Win32; }; | |
985 | if (defined(&Win32::GetCurrentProcessId)) { | |
986 | $pid_to_kill = Win32::GetCurrentProcessId(); | |
987 | } | |
988 | } | |
989 | ||
990 | # If we still have a fake PID, we can't use this method at all | |
991 | return if ($pid_to_kill <= 0); | |
992 | ||
993 | # Launch watchdog process | |
994 | my $watchdog; | |
995 | eval { | |
996 | local $SIG{'__WARN__'} = sub { | |
997 | _diag("Watchdog warning: $_[0]"); | |
998 | }; | |
999 | my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; | |
1000 | $watchdog = system(1, which_perl(), '-e', | |
1001 | "sleep($timeout);" . | |
1002 | "warn('# $timeout_msg\n');" . | |
1003 | "kill($sig, $pid_to_kill);"); | |
1004 | }; | |
1005 | if ($@ || ($watchdog <= 0)) { | |
1006 | _diag('Failed to start watchdog'); | |
1007 | _diag($@) if $@; | |
1008 | undef($watchdog); | |
1009 | return; | |
1010 | } | |
1011 | ||
1012 | # Add END block to parent to terminate and | |
1013 | # clean up watchdog process | |
1014 | eval "END { local \$! = 0; local \$? = 0; | |
1015 | wait() if kill('KILL', $watchdog); };"; | |
1016 | return; | |
1017 | } | |
1018 | ||
1019 | # Try using fork() to generate a watchdog process | |
1020 | my $watchdog; | |
1021 | eval { $watchdog = fork() }; | |
1022 | if (defined($watchdog)) { | |
1023 | if ($watchdog) { # Parent process | |
1024 | # Add END block to parent to terminate and | |
1025 | # clean up watchdog process | |
1026 | eval "END { local \$! = 0; local \$? = 0; | |
1027 | wait() if kill('KILL', $watchdog); };"; | |
1028 | return; | |
1029 | } | |
1030 | ||
1031 | ### Watchdog process code | |
1032 | ||
1033 | # Load POSIX if available | |
1034 | eval { require POSIX; }; | |
1035 | ||
1036 | # Execute the timeout | |
1037 | sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 | |
1038 | sleep(2); | |
1039 | ||
1040 | # Kill test process if still running | |
1041 | if (kill(0, $pid_to_kill)) { | |
1042 | _diag($timeout_msg); | |
1043 | kill('KILL', $pid_to_kill); | |
1044 | } | |
1045 | ||
1046 | # Don't execute END block (added at beginning of this file) | |
1047 | $NO_ENDING = 1; | |
1048 | ||
1049 | # Terminate ourself (i.e., the watchdog) | |
1050 | POSIX::_exit(1) if (defined(&POSIX::_exit)); | |
1051 | exit(1); | |
1052 | } | |
1053 | ||
1054 | # fork() failed - fall through and try using a thread | |
1055 | } | |
1056 | ||
1057 | # Use a watchdog thread because either 'threads' is loaded, | |
1058 | # or fork() failed | |
1059 | if (eval 'require threads; 1') { | |
1060 | threads->create(sub { | |
1061 | # Load POSIX if available | |
1062 | eval { require POSIX; }; | |
1063 | ||
1064 | # Execute the timeout | |
1065 | my $time_left = $timeout; | |
1066 | do { | |
1067 | $time_left -= sleep($time_left); | |
1068 | } while ($time_left > 0); | |
1069 | ||
1070 | # Kill the parent (and ourself) | |
1071 | select(STDERR); $| = 1; | |
1072 | _diag($timeout_msg); | |
1073 | POSIX::_exit(1) if (defined(&POSIX::_exit)); | |
1074 | my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; | |
1075 | kill($sig, $pid_to_kill); | |
1076 | })->detach(); | |
1077 | return; | |
1078 | } | |
1079 | ||
1080 | # If everything above fails, then just use an alarm timeout | |
1081 | if (eval { alarm($timeout); 1; }) { | |
1082 | # Load POSIX if available | |
1083 | eval { require POSIX; }; | |
1084 | ||
1085 | # Alarm handler will do the actual 'killing' | |
1086 | $SIG{'ALRM'} = sub { | |
1087 | select(STDERR); $| = 1; | |
1088 | _diag($timeout_msg); | |
1089 | POSIX::_exit(1) if (defined(&POSIX::_exit)); | |
1090 | my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; | |
1091 | kill($sig, $pid_to_kill); | |
1092 | }; | |
1093 | } | |
1094 | } | |
1095 | ||
1096 | 1; | |
1097 | EOS | |
1098 | close $fh; | |
1099 | } |