1#
2# t/test.pl - most of Test::More functionality without the fuss
3
4
5# NOTE:
6#
7# Do not rely on features found only in more modern Perls here, as some CPAN
8# distributions copy this file and must operate on older Perls. Similarly, keep
9# things, simple as this may be run under fairly broken circumstances. For
10# example, increment ($x++) has a certain amount of cleverness for things like
11#
12#   $x = 'zz';
13#   $x++; # $x eq 'aaa';
14#
15# This stands more chance of breaking than just a simple
16#
17#   $x = $x + 1
18#
19# In this file, we use the latter "Baby Perl" approach, and increment
20# will be worked over by t/op/inc.t
21
22$| = 1;
23$Level = 1;
24my $test = 1;
25my $planned;
26my $noplan;
27
28# Fatalize warnings, so that we don't introduce new warnings.  But on early
29# perls the burden of avoiding warnings becomes too large, and someone still
30# trying to use such outmoded versions should be willing to accept warnings in
31# our test suite.
32$SIG{__WARN__} = sub { die "Fatalized: $_[0]" } if $] ge "5.6.0";
33
34# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
35$::IS_ASCII  = ord 'A' ==  65;
36
37$TODO = 0;
38$NO_ENDING = 0;
39$Tests_Are_Passing = 1;
40
41# Use this instead of print to avoid interference while testing globals.
42sub _print {
43    local($\, $", $,) = (undef, ' ', '') if "$]" >= 5.004;
44    print STDOUT @_;
45}
46
47sub _print_stderr {
48    local($\, $", $,) = (undef, ' ', '') if "$]" >= 5.004;
49    print STDERR @_;
50}
51
52sub plan {
53    my $n;
54    if (@_ == 1) {
55	$n = shift;
56	if ($n eq 'no_plan') {
57	  undef $n;
58	  $noplan = 1;
59	}
60    } else {
61	my %plan = @_;
62	$plan{skip_all} and skip_all($plan{skip_all});
63	$n = $plan{tests};
64    }
65    _print "1..$n\n" unless $noplan;
66    $planned = $n;
67}
68
69
70# Set the plan at the end.  See Test::More::done_testing.
71sub done_testing {
72    my $n = $test - 1;
73    $n = shift if @_;
74
75    _print "1..$n\n";
76    $planned = $n;
77}
78
79
80END {
81    my $ran = $test - 1;
82    if (!$NO_ENDING) {
83	if (defined $planned && $planned != $ran) {
84	    _print_stderr
85		"# Looks like you planned $planned tests but ran $ran.\n";
86	} elsif ($noplan) {
87	    _print "1..$ran\n";
88	}
89    }
90}
91
92sub _diag {
93    return unless @_;
94    my @mess = _comment(@_);
95    $TODO ? _print(@mess) : _print_stderr(@mess);
96}
97
98# Use this instead of "print STDERR" when outputting failure diagnostic
99# messages
100sub diag {
101    _diag(@_);
102}
103
104# Use this instead of "print" when outputting informational messages
105sub note {
106    return unless @_;
107    _print( _comment(@_) );
108}
109
110sub _comment {
111    return map { /^#/ ? "$_\n" : "# $_\n" }
112           map { split /\n/ } @_;
113}
114
115sub _have_dynamic_extension {
116    my $extension = shift;
117    unless (eval {require Config; 1}) {
118	warn "test.pl had problems loading Config: $@";
119	return 1;
120    }
121    $extension =~ s!::!/!g;
122    return 1 if ($Config::Config{extensions} =~ /\b$extension\b/);
123}
124
125sub skip_all {
126    if (@_) {
127        _print "1..0 # Skip @_\n";
128    } else {
129	_print "1..0\n";
130    }
131    exit(0);
132}
133
134sub BAIL_OUT {
135    my ($reason) = @_;
136    _print("Bail out!  $reason\n");
137    exit 255;
138}
139
140sub _ok {
141    my ($pass, $where, $name, @mess) = @_;
142    # Do not try to microoptimize by factoring out the "not ".
143    # VMS will avenge.
144    my $out;
145    if ($name) {
146        # escape out '#' or it will interfere with '# skip' and such
147        $name =~ s/#/\\#/g;
148	$out = $pass ? "ok $test - $name" : "not ok $test - $name";
149    } else {
150	$out = $pass ? "ok $test" : "not ok $test";
151    }
152
153    if ($TODO) {
154	$out = $out . " # TODO $TODO";
155    } else {
156	$Tests_Are_Passing = 0 unless $pass;
157    }
158
159    _print "$out\n";
160
161    if ($pass) {
162	note @mess; # Ensure that the message is properly escaped.
163    }
164    else {
165	my $msg = "# Failed test $test - ";
166	$msg.= "$name " if $name;
167	$msg .= "$where\n";
168	_diag $msg;
169	_diag @mess;
170    }
171
172    $test = $test + 1; # don't use ++
173
174    return $pass;
175}
176
177sub _where {
178    my @caller = caller($Level);
179    return "at $caller[1] line $caller[2]";
180}
181
182sub ok ($@) {
183    my ($pass, $name, @mess) = @_;
184    _ok($pass, _where(), $name, @mess);
185}
186
187sub _q {
188    my $x = shift;
189    return 'undef' unless defined $x;
190    my $q = $x;
191    $q =~ s/\\/\\\\/g;
192    $q =~ s/'/\\'/g;
193    return "'$q'";
194}
195
196sub _qq {
197    my $x = shift;
198    return defined $x ? '"' . display ($x) . '"' : 'undef';
199};
200
201# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file.
202# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!").
203my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : defined(eval { pack "U*", 90 }) ? "U*" : "C*";
204eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }'
205    if !defined &re::is_regexp;
206
207# keys are the codes \n etc map to, values are 2 char strings such as \n
208my %backslash_escape;
209my $x;
210foreach $x (split //, 'nrtfa\\\'"') {
211    $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
212}
213# A way to display scalars containing control characters and Unicode.
214# Trying to avoid setting $_, or relying on local $_ to work.
215sub display {
216    my @result;
217    my $x;
218    foreach $x (@_) {
219        if (defined $x and not ref $x) {
220            my $y = '';
221            my $c;
222            foreach $c (unpack($chars_template, $x)) {
223                if ($c > 255) {
224                    $y = $y . sprintf "\\x{%x}", $c;
225                } elsif ($backslash_escape{$c}) {
226                    $y = $y . $backslash_escape{$c};
227                } elsif ($c < ord " ") {
228                    # Use octal for characters with small ordinals that are
229                    # traditionally expressed as octal: the controls below
230                    # space, which on EBCDIC are almost all the controls, but
231                    # on ASCII don't include DEL nor the C1 controls.
232                    $y = $y . sprintf "\\%03o", $c;
233                } elsif ($::IS_ASCII && $c <= ord('~')) {
234                    $y = $y . chr $c;
235                } elsif ( ! $::IS_ASCII
236                         && eval 'chr $c =~ /[^[:^print:][:^ascii:]]/')
237                        # The pattern above is equivalent (by de Morgan's
238                        # laws) to:
239                        #     $z =~ /(?[ [:print:] & [:ascii:] ])/
240                        # or, $z is an ascii printable character
241                        # The /a modifier doesn't go back so far.
242                {
243                    $y = $y . chr $c;
244                }
245                elsif ($@) { # Should only be an error on platforms too
246                             # early to have the [:posix:] syntax, which
247                             # also should be ASCII ones
248                    die __FILE__ . __LINE__
249                      . ": Unexpected non-ASCII platform; $@";
250                }
251                else {
252                    $y = $y . sprintf "\\x%02X", $c;
253                }
254            }
255            $x = $y;
256        }
257        return $x unless wantarray;
258        push @result, $x;
259    }
260    return @result;
261}
262
263sub is ($$@) {
264    my ($got, $expected, $name, @mess) = @_;
265
266    my $pass;
267    if( !defined $got || !defined $expected ) {
268        # undef only matches undef
269        $pass = !defined $got && !defined $expected;
270    }
271    else {
272        $pass = $got eq $expected;
273    }
274
275    unless ($pass) {
276	unshift(@mess, "#      got "._qq($got)."\n",
277		       "# expected "._qq($expected)."\n");
278    }
279    _ok($pass, _where(), $name, @mess);
280}
281
282sub isnt ($$@) {
283    my ($got, $isnt, $name, @mess) = @_;
284
285    my $pass;
286    if( !defined $got || !defined $isnt ) {
287        # undef only matches undef
288        $pass = defined $got || defined $isnt;
289    }
290    else {
291        $pass = $got ne $isnt;
292    }
293
294    unless( $pass ) {
295        unshift(@mess, "# it should not be "._qq($got)."\n",
296                       "# but it is.\n");
297    }
298    _ok($pass, _where(), $name, @mess);
299}
300
301sub cmp_ok ($$$@) {
302    my($got, $type, $expected, $name, @mess) = @_;
303
304    my $pass;
305    {
306        local $^W = 0;
307        local($@,$!);   # don't interfere with $@
308                        # eval() sometimes resets $!
309        $pass = eval "\$got $type \$expected";
310    }
311    unless ($pass) {
312        # It seems Irix long doubles can have 2147483648 and 2147483648
313        # that stringify to the same thing but are actually numerically
314        # different. Display the numbers if $type isn't a string operator,
315        # and the numbers are stringwise the same.
316        # (all string operators have alphabetic names, so tr/a-z// is true)
317        # This will also show numbers for some unneeded cases, but will
318        # definitely be helpful for things such as == and <= that fail
319        if ($got eq $expected and $type !~ tr/a-z//) {
320            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
321        }
322        unshift(@mess, "#      got "._qq($got)."\n",
323                       "# expected $type "._qq($expected)."\n");
324    }
325    _ok($pass, _where(), $name, @mess);
326}
327
328# Check that $got is within $range of $expected
329# if $range is 0, then check it's exact
330# else if $expected is 0, then $range is an absolute value
331# otherwise $range is a fractional error.
332# Here $range must be numeric, >= 0
333# Non numeric ranges might be a useful future extension. (eg %)
334sub within ($$$@) {
335    my ($got, $expected, $range, $name, @mess) = @_;
336    my $pass;
337    if (!defined $got or !defined $expected or !defined $range) {
338        # This is a fail, but doesn't need extra diagnostics
339    } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
340        # This is a fail
341        unshift @mess, "# got, expected and range must be numeric\n";
342    } elsif ($range < 0) {
343        # This is also a fail
344        unshift @mess, "# range must not be negative\n";
345    } elsif ($range == 0) {
346        # Within 0 is ==
347        $pass = $got == $expected;
348    } elsif ($expected == 0) {
349        # If expected is 0, treat range as absolute
350        $pass = ($got <= $range) && ($got >= - $range);
351    } else {
352        my $diff = $got - $expected;
353        $pass = abs ($diff / $expected) < $range;
354    }
355    unless ($pass) {
356        if ($got eq $expected) {
357            unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
358        }
359	unshift@mess, "#      got "._qq($got)."\n",
360		      "# expected "._qq($expected)." (within "._qq($range).")\n";
361    }
362    _ok($pass, _where(), $name, @mess);
363}
364
365sub pass {
366    _ok(1, '', @_);
367}
368
369sub fail {
370    _ok(0, _where(), @_);
371}
372
373sub curr_test {
374    $test = shift if @_;
375    return $test;
376}
377
378sub next_test {
379  my $retval = $test;
380  $test = $test + 1; # don't use ++
381  $retval;
382}
383
384# Note: can't pass multipart messages since we try to
385# be compatible with Test::More::skip().
386sub skip {
387    my $why = shift;
388    my $n   = @_ ? shift : 1;
389    my $bad_swap;
390    my $both_zero;
391    {
392      local $^W = 0;
393      $bad_swap = $why > 0 && $n == 0;
394      $both_zero = $why == 0 && $n == 0;
395    }
396    if ($bad_swap || $both_zero || @_) {
397      my $arg = "'$why', '$n'";
398      if (@_) {
399        $arg .= join(", ", '', map { qq['$_'] } @_);
400      }
401      die qq[$0: expected skip(why, count), got skip($arg)\n];
402    }
403    for (1..$n) {
404        _print "ok $test # skip $why\n";
405        $test = $test + 1;
406    }
407    local $^W = 0;
408    #last SKIP;
409}
410
411sub eq_array {
412    my ($ra, $rb) = @_;
413    return 0 unless $#$ra == $#$rb;
414    my $i;
415    for $i (0..$#$ra) {
416	next     if !defined $ra->[$i] && !defined $rb->[$i];
417	return 0 if !defined $ra->[$i];
418	return 0 if !defined $rb->[$i];
419	return 0 unless $ra->[$i] eq $rb->[$i];
420    }
421    return 1;
422}
423
424sub eq_hash {
425  my ($orig, $suspect) = @_;
426  my $fail;
427  while (my ($key, $value) = each %$suspect) {
428    # Force a hash recompute if this perl's internals can cache the hash key.
429    $key = "" . $key;
430    if (exists $orig->{$key}) {
431      if (
432        defined $orig->{$key} != defined $value
433        || (defined $value && $orig->{$key} ne $value)
434      ) {
435        _print "# key ", _qq($key), " was ", _qq($orig->{$key}),
436                     " now ", _qq($value), "\n";
437        $fail = 1;
438      }
439    } else {
440      _print "# key ", _qq($key), " is ", _qq($value),
441                   ", not in original.\n";
442      $fail = 1;
443    }
444  }
445  foreach (keys %$orig) {
446    # Force a hash recompute if this perl's internals can cache the hash key.
447    $_ = "" . $_;
448    next if (exists $suspect->{$_});
449    _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
450    $fail = 1;
451  }
452  !$fail;
453}
454
4551;
456