source: trunk/third/perl/t/test.pl @ 20075

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