xref: /openbsd/gnu/usr.bin/perl/t/test.pl (revision db3296cf) 
1#
2# t/test.pl - most of Test::More functionality without the fuss
3#
4
5my $test = 1;
6my $planned;
7
8$TODO = 0;
9$NO_ENDING = 0;
10
11sub plan {
12    my $n;
13    if (@_ == 1) {
14	$n = shift;
15    } else {
16	my %plan = @_;
17	$n = $plan{tests};
18    }
19    print STDOUT "1..$n\n";
20    $planned = $n;
21}
22
23END {
24    my $ran = $test - 1;
25    if (!$NO_ENDING && defined $planned && $planned != $ran) {
26        print STDERR "# Looks like you planned $planned tests but ran $ran.\n";
27    }
28}
29
30# Use this instead of "print STDERR" when outputing failure diagnostic
31# messages
32sub _diag {
33    return unless @_;
34    my @mess = map { /^#/ ? "$_\n" : "# $_\n" }
35               map { split /\n/ } @_;
36    my $fh = $TODO ? *STDOUT : *STDERR;
37    print $fh @mess;
38
39}
40
41sub skip_all {
42    if (@_) {
43	print STDOUT "1..0 # Skipped: @_\n";
44    } else {
45	print STDOUT "1..0\n";
46    }
47    exit(0);
48}
49
50sub _ok {
51    my ($pass, $where, $name, @mess) = @_;
52    # Do not try to microoptimize by factoring out the "not ".
53    # VMS will avenge.
54    my $out;
55    if ($name) {
56        # escape out '#' or it will interfere with '# skip' and such
57        $name =~ s/#/\\#/g;
58	$out = $pass ? "ok $test - $name" : "not ok $test - $name";
59    } else {
60	$out = $pass ? "ok $test" : "not ok $test";
61    }
62
63    $out .= " # TODO $TODO" if $TODO;
64    print STDOUT "$out\n";
65
66    unless ($pass) {
67	_diag "# Failed $where\n";
68    }
69
70    # Ensure that the message is properly escaped.
71    _diag @mess;
72
73    $test++;
74
75    return $pass;
76}
77
78sub _where {
79    my @caller = caller(1);
80    return "at $caller[1] line $caller[2]";
81}
82
83# DON'T use this for matches. Use like() instead.
84sub ok {
85    my ($pass, $name, @mess) = @_;
86    _ok($pass, _where(), $name, @mess);
87}
88
89sub _q {
90    my $x = shift;
91    return 'undef' unless defined $x;
92    my $q = $x;
93    $q =~ s/\\/\\\\/;
94    $q =~ s/'/\\'/;
95    return "'$q'";
96}
97
98sub _qq {
99    my $x = shift;
100    return defined $x ? '"' . display ($x) . '"' : 'undef';
101};
102
103# keys are the codes \n etc map to, values are 2 char strings such as \n
104my %backslash_escape;
105foreach my $x (split //, 'nrtfa\\\'"') {
106    $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
107}
108# A way to display scalars containing control characters and Unicode.
109# Trying to avoid setting $_, or relying on local $_ to work.
110sub display {
111    my @result;
112    foreach my $x (@_) {
113        if (defined $x and not ref $x) {
114            my $y = '';
115            foreach my $c (unpack("U*", $x)) {
116                if ($c > 255) {
117                    $y .= sprintf "\\x{%x}", $c;
118                } elsif ($backslash_escape{$c}) {
119                    $y .= $backslash_escape{$c};
120                } else {
121                    my $z = chr $c; # Maybe we can get away with a literal...
122                    $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/;
123                    $y .= $z;
124                }
125            }
126            $x = $y;
127        }
128        return $x unless wantarray;
129        push @result, $x;
130    }
131    return @result;
132}
133
134sub is {
135    my ($got, $expected, $name, @mess) = @_;
136    my $pass = $got eq $expected;
137    unless ($pass) {
138	unshift(@mess, "#      got "._q($got)."\n",
139		       "# expected "._q($expected)."\n");
140    }
141    _ok($pass, _where(), $name, @mess);
142}
143
144sub isnt {
145    my ($got, $isnt, $name, @mess) = @_;
146    my $pass = $got ne $isnt;
147    unless( $pass ) {
148        unshift(@mess, "# it should not be "._q($got)."\n",
149                       "# but it is.\n");
150    }
151    _ok($pass, _where(), $name, @mess);
152}
153
154sub cmp_ok {
155    my($got, $type, $expected, $name, @mess) = @_;
156
157    my $pass;
158    {
159        local $^W = 0;
160        local($@,$!);   # don't interfere with $@
161                        # eval() sometimes resets $!
162        $pass = eval "\$got $type \$expected";
163    }
164    unless ($pass) {
165        # It seems Irix long doubles can have 2147483648 and 2147483648
166        # that stringify to the same thing but are acutally numerically
167        # different. Display the numbers if $type isn't a string operator,
168        # and the numbers are stringwise the same.
169        # (all string operators have alphabetic names, so tr/a-z// is true)
170        # This will also show numbers for some uneeded cases, but will
171        # definately be helpful for things such as == and <= that fail
172        if ($got eq $expected and $type !~ tr/a-z//) {
173            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
174        }
175        unshift(@mess, "#      got "._q($got)."\n",
176                       "# expected $type "._q($expected)."\n");
177    }
178    _ok($pass, _where(), $name, @mess);
179}
180
181# Check that $got is within $range of $expected
182# if $range is 0, then check it's exact
183# else if $expected is 0, then $range is an absolute value
184# otherwise $range is a fractional error.
185# Here $range must be numeric, >= 0
186# Non numeric ranges might be a useful future extension. (eg %)
187sub within {
188    my ($got, $expected, $range, $name, @mess) = @_;
189    my $pass;
190    if (!defined $got or !defined $expected or !defined $range) {
191        # This is a fail, but doesn't need extra diagnostics
192    } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
193        # This is a fail
194        unshift @mess, "# got, expected and range must be numeric\n";
195    } elsif ($range < 0) {
196        # This is also a fail
197        unshift @mess, "# range must not be negative\n";
198    } elsif ($range == 0) {
199        # Within 0 is ==
200        $pass = $got == $expected;
201    } elsif ($expected == 0) {
202        # If expected is 0, treat range as absolute
203        $pass = ($got <= $range) && ($got >= - $range);
204    } else {
205        my $diff = $got - $expected;
206        $pass = abs ($diff / $expected) < $range;
207    }
208    unless ($pass) {
209        if ($got eq $expected) {
210            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
211        }
212	unshift@mess, "#      got "._q($got)."\n",
213		      "# expected "._q($expected)." (within "._q($range).")\n";
214    }
215    _ok($pass, _where(), $name, @mess);
216}
217
218# Note: this isn't quite as fancy as Test::More::like().
219sub like {
220    my ($got, $expected, $name, @mess) = @_;
221    my $pass;
222    if (ref $expected eq 'Regexp') {
223	$pass = $got =~ $expected;
224	unless ($pass) {
225	    unshift(@mess, "#      got '$got'\n",
226		           "# expected /$expected/\n");
227	}
228    } else {
229	$pass = $got =~ /$expected/;
230	unless ($pass) {
231	    unshift(@mess, "#      got '$got'\n",
232		           "# expected /$expected/\n");
233	}
234    }
235    _ok($pass, _where(), $name, @mess);
236}
237
238sub pass {
239    _ok(1, '', @_);
240}
241
242sub fail {
243    _ok(0, _where(), @_);
244}
245
246sub curr_test {
247    $test = shift if @_;
248    return $test;
249}
250
251sub next_test {
252  $test++;
253}
254
255# Note: can't pass multipart messages since we try to
256# be compatible with Test::More::skip().
257sub skip {
258    my $why = shift;
259    my $n    = @_ ? shift : 1;
260    for (1..$n) {
261        print STDOUT "ok $test # skip: $why\n";
262        $test++;
263    }
264    local $^W = 0;
265    last SKIP;
266}
267
268sub eq_array {
269    my ($ra, $rb) = @_;
270    return 0 unless $#$ra == $#$rb;
271    for my $i (0..$#$ra) {
272	return 0 unless $ra->[$i] eq $rb->[$i];
273    }
274    return 1;
275}
276
277sub eq_hash {
278  my ($orig, $suspect) = @_;
279  my $fail;
280  while (my ($key, $value) = each %$suspect) {
281    # Force a hash recompute if this perl's internals can cache the hash key.
282    $key = "" . $key;
283    if (exists $orig->{$key}) {
284      if ($orig->{$key} ne $value) {
285        print STDOUT "# key ", _qq($key), " was ", _qq($orig->{$key}),
286                     " now ", _qq($value), "\n";
287        $fail = 1;
288      }
289    } else {
290      print STDOUT "# key ", _qq($key), " is ", _qq($value),
291                   ", not in original.\n";
292      $fail = 1;
293    }
294  }
295  foreach (keys %$orig) {
296    # Force a hash recompute if this perl's internals can cache the hash key.
297    $_ = "" . $_;
298    next if (exists $suspect->{$_});
299    print STDOUT "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
300    $fail = 1;
301  }
302  !$fail;
303}
304
305sub require_ok {
306    my ($require) = @_;
307    eval <<REQUIRE_OK;
308require $require;
309REQUIRE_OK
310    _ok(!$@, _where(), "require $require");
311}
312
313sub use_ok {
314    my ($use) = @_;
315    eval <<USE_OK;
316use $use;
317USE_OK
318    _ok(!$@, _where(), "use $use");
319}
320
321# runperl - Runs a separate perl interpreter.
322# Arguments :
323#   switches => [ command-line switches ]
324#   nolib    => 1 # don't use -I../lib (included by default)
325#   prog     => one-liner (avoid quotes)
326#   progs    => [ multi-liner (avoid quotes) ]
327#   progfile => perl script
328#   stdin    => string to feed the stdin
329#   stderr   => redirect stderr to stdout
330#   args     => [ command-line arguments to the perl program ]
331#   verbose  => print the command line
332
333my $is_mswin    = $^O eq 'MSWin32';
334my $is_netware  = $^O eq 'NetWare';
335my $is_macos    = $^O eq 'MacOS';
336my $is_vms      = $^O eq 'VMS';
337
338sub _quote_args {
339    my ($runperl, $args) = @_;
340
341    foreach (@$args) {
342	# In VMS protect with doublequotes because otherwise
343	# DCL will lowercase -- unless already doublequoted.
344       $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0;
345	$$runperl .= ' ' . $_;
346    }
347}
348
349sub runperl {
350    my %args = @_;
351    my $runperl = $^X;
352    unless ($args{nolib}) {
353	if ($is_macos) {
354	    $runperl .= ' -I::lib';
355	    # Use UNIX style error messages instead of MPW style.
356	    $runperl .= ' -MMac::err=unix' if $args{stderr};
357	}
358	else {
359	    $runperl .= ' "-I../lib"'; # doublequotes because of VMS
360	}
361    }
362    if ($args{switches}) {
363	_quote_args(\$runperl, $args{switches});
364    }
365    if (defined $args{prog}) {
366        $args{progs} = [$args{prog}]
367    }
368    if (defined $args{progs}) {
369        foreach my $prog (@{$args{progs}}) {
370            if ($is_mswin || $is_netware || $is_vms) {
371                $runperl .= qq ( -e "$prog" );
372            }
373            else {
374                $runperl .= qq ( -e '$prog' );
375            }
376        }
377    } elsif (defined $args{progfile}) {
378	$runperl .= qq( "$args{progfile}");
379    }
380    if (defined $args{stdin}) {
381	# so we don't try to put literal newlines and crs onto the
382	# command line.
383	$args{stdin} =~ s/\n/\\n/g;
384	$args{stdin} =~ s/\r/\\r/g;
385
386	if ($is_mswin || $is_netware || $is_vms) {
387	    $runperl = qq{$^X -e "print qq(} .
388		$args{stdin} . q{)" | } . $runperl;
389	}
390	elsif ($is_macos) {
391	    # MacOS can only do two processes under MPW at once;
392	    # the test itself is one; we can't do two more, so
393	    # write to temp file
394	    my $stdin = qq{$^X -e 'print qq(} . $args{stdin} . qq{)' > teststdin; };
395	    if ($args{verbose}) {
396		my $stdindisplay = $stdin;
397		$stdindisplay =~ s/\n/\n\#/g;
398		print STDERR "# $stdindisplay\n";
399	    }
400	    `$stdin`;
401	    $runperl .= q{ < teststdin };
402	}
403	else {
404	    $runperl = qq{$^X -e 'print qq(} .
405		$args{stdin} . q{)' | } . $runperl;
406	}
407    }
408    if (defined $args{args}) {
409	_quote_args(\$runperl, $args{args});
410    }
411    $runperl .= ' 2>&1'          if  $args{stderr} && !$is_macos;
412    $runperl .= " \xB3 Dev:Null" if !$args{stderr} &&  $is_macos;
413    if ($args{verbose}) {
414	my $runperldisplay = $runperl;
415	$runperldisplay =~ s/\n/\n\#/g;
416	print STDERR "# $runperldisplay\n";
417    }
418    my $result = `$runperl`;
419    $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these
420    return $result;
421}
422
423*run_perl = \&runperl; # Nice alias.
424
425sub DIE {
426    print STDERR "# @_\n";
427    exit 1;
428}
429
430# A somewhat safer version of the sometimes wrong $^X.
431my $Perl;
432sub which_perl {
433    unless (defined $Perl) {
434	$Perl = $^X;
435
436	# VMS should have 'perl' aliased properly
437	return $Perl if $^O eq 'VMS';
438
439	my $exe;
440	eval "require Config; Config->import";
441	if ($@) {
442	    warn "test.pl had problems loading Config: $@";
443	    $exe = '';
444	} else {
445	    $exe = $Config{_exe};
446	}
447       $exe = '' unless defined $exe;
448
449	# This doesn't absolutize the path: beware of future chdirs().
450	# We could do File::Spec->abs2rel() but that does getcwd()s,
451	# which is a bit heavyweight to do here.
452
453	if ($Perl =~ /^perl\Q$exe\E$/i) {
454	    my $perl = "perl$exe";
455	    eval "require File::Spec";
456	    if ($@) {
457		warn "test.pl had problems loading File::Spec: $@";
458		$Perl = "./$perl";
459	    } else {
460		$Perl = File::Spec->catfile(File::Spec->curdir(), $perl);
461	    }
462	}
463
464	# Build up the name of the executable file from the name of
465	# the command.
466
467	if ($Perl !~ /\Q$exe\E$/i) {
468	    $Perl .= $exe;
469	}
470
471	warn "which_perl: cannot find $Perl from $^X" unless -f $Perl;
472
473	# For subcommands to use.
474	$ENV{PERLEXE} = $Perl;
475    }
476    return $Perl;
477}
478
479sub unlink_all {
480    foreach my $file (@_) {
481        1 while unlink $file;
482        print STDERR "# Couldn't unlink '$file': $!\n" if -f $file;
483    }
484}
485
486
487my $tmpfile = "misctmp000";
4881 while -f ++$tmpfile;
489END { unlink_all $tmpfile }
490
491#
492# _fresh_perl
493#
494# The $resolve must be a subref that tests the first argument
495# for success, or returns the definition of success (e.g. the
496# expected scalar) if given no arguments.
497#
498
499sub _fresh_perl {
500    my($prog, $resolve, $runperl_args, $name) = @_;
501
502    $runperl_args ||= {};
503    $runperl_args->{progfile} = $tmpfile;
504    $runperl_args->{stderr} = 1;
505
506    open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
507
508    # VMS adjustments
509    if( $^O eq 'VMS' ) {
510        $prog =~ s#/dev/null#NL:#;
511
512        # VMS file locking
513        $prog =~ s{if \(-e _ and -f _ and -r _\)}
514                  {if (-e _ and -f _)}
515    }
516
517    print TEST $prog, "\n";
518    close TEST or die "Cannot close $tmpfile: $!";
519
520    my $results = runperl(%$runperl_args);
521    my $status = $?;
522
523    # Clean up the results into something a bit more predictable.
524    $results =~ s/\n+$//;
525    $results =~ s/at\s+misctmp\d+\s+line/at - line/g;
526    $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g;
527
528    # bison says 'parse error' instead of 'syntax error',
529    # various yaccs may or may not capitalize 'syntax'.
530    $results =~ s/^(syntax|parse) error/syntax error/mig;
531
532    if ($^O eq 'VMS') {
533        # some tests will trigger VMS messages that won't be expected
534        $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//;
535
536        # pipes double these sometimes
537        $results =~ s/\n\n/\n/g;
538    }
539
540    my $pass = $resolve->($results);
541    unless ($pass) {
542        _diag "# PROG: \n$prog\n";
543        _diag "# EXPECTED:\n", $resolve->(), "\n";
544        _diag "# GOT:\n$results\n";
545        _diag "# STATUS: $status\n";
546    }
547
548    # Use the first line of the program as a name if none was given
549    unless( $name ) {
550        ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
551        $name .= '...' if length $first_line > length $name;
552    }
553
554    _ok($pass, _where(), "fresh_perl - $name");
555}
556
557#
558# run_perl_is
559#
560# Combination of run_perl() and is().
561#
562
563sub fresh_perl_is {
564    my($prog, $expected, $runperl_args, $name) = @_;
565    _fresh_perl($prog,
566		sub { @_ ? $_[0] eq $expected : $expected },
567		$runperl_args, $name);
568}
569
570#
571# run_perl_like
572#
573# Combination of run_perl() and like().
574#
575
576sub fresh_perl_like {
577    my($prog, $expected, $runperl_args, $name) = @_;
578    _fresh_perl($prog,
579		sub { @_ ?
580			  $_[0] =~ (ref $expected ? $expected : /$expected/) :
581		          $expected },
582		$runperl_args, $name);
583}
584
5851;
586