-{
- my $__ntest;
- my $__total;
-
- sub plan {
- @_ == 2 or die "usage: plan(tests => count)";
- my $what = shift;
- $what eq 'tests' or die "cannot plan anything but tests";
- $__total = shift;
- defined $__total && $__total > 0 or die "need a positive number of tests";
- print "1..$__total\n";
- }
+#
+# t/test.pl - most of Test::More functionality without the fuss
- sub skip {
- my $reason = shift;
- ++$__ntest;
- print "ok $__ntest # skip: $reason\n"
- }
- sub ok ($;$$) {
- local($\,$,);
- my $ok = 0;
- my $result = shift;
- if (@_ == 0) {
- $ok = $result;
+# NOTE:
+#
+# Do not rely on features found only in more modern Perls here, as some CPAN
+# distributions copy this file and must operate on older Perls. Similarly, keep
+# things, simple as this may be run under fairly broken circumstances. For
+# example, increment ($x++) has a certain amount of cleverness for things like
+#
+# $x = 'zz';
+# $x++; # $x eq 'aaa';
+#
+# This stands more chance of breaking than just a simple
+#
+# $x = $x + 1
+#
+# In this file, we use the latter "Baby Perl" approach, and increment
+# will be worked over by t/op/inc.t
+
+$| = 1;
+$Level = 1;
+my $test = 1;
+my $planned;
+my $noplan;
+
+# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC
+$::IS_ASCII = ord 'A' == 65;
+$::IS_EBCDIC = ord 'A' == 193;
+
+$TODO = 0;
+$NO_ENDING = 0;
+$Tests_Are_Passing = 1;
+
+# Use this instead of print to avoid interference while testing globals.
+sub _print {
+ local($\, $", $,) = (undef, ' ', '') if "$]" >= 5.004;
+ print STDOUT @_;
+}
+
+sub _print_stderr {
+ local($\, $", $,) = (undef, ' ', '') if "$]" >= 5.004;
+ print STDERR @_;
+}
+
+sub plan {
+ my $n;
+ if (@_ == 1) {
+ $n = shift;
+ if ($n eq 'no_plan') {
+ undef $n;
+ $noplan = 1;
+ }
} else {
- $expected = shift;
- if (!defined $expected) {
- $ok = !defined $result;
- } elsif (!defined $result) {
- $ok = 0;
- } elsif (ref($expected) eq 'Regexp') {
- die "using regular expression objects is not backwards compatible";
- } else {
- $ok = $result eq $expected;
- }
+ my %plan = @_;
+ $plan{skip_all} and skip_all($plan{skip_all});
+ $n = $plan{tests};
+ }
+ _print "1..$n\n" unless $noplan;
+ $planned = $n;
+}
+
+
+# Set the plan at the end. See Test::More::done_testing.
+sub done_testing {
+ my $n = $test - 1;
+ $n = shift if @_;
+
+ _print "1..$n\n";
+ $planned = $n;
+}
+
+
+END {
+ my $ran = $test - 1;
+ if (!$NO_ENDING) {
+ if (defined $planned && $planned != $ran) {
+ _print_stderr
+ "# Looks like you planned $planned tests but ran $ran.\n";
+ } elsif ($noplan) {
+ _print "1..$ran\n";
+ }
+ }
+}
+
+sub _diag {
+ return unless @_;
+ my @mess = _comment(@_);
+ $TODO ? _print(@mess) : _print_stderr(@mess);
+}
+
+# Use this instead of "print STDERR" when outputting failure diagnostic
+# messages
+sub diag {
+ _diag(@_);
+}
+
+# Use this instead of "print" when outputting informational messages
+sub note {
+ return unless @_;
+ _print( _comment(@_) );
+}
+
+sub _comment {
+ return map { /^#/ ? "$_\n" : "# $_\n" }
+ map { split /\n/ } @_;
+}
+
+sub _have_dynamic_extension {
+ my $extension = shift;
+ unless (eval {require Config; 1}) {
+ warn "test.pl had problems loading Config: $@";
+ return 1;
+ }
+ $extension =~ s!::!/!g;
+ return 1 if ($Config::Config{extensions} =~ /\b$extension\b/);
+}
+
+sub skip_all {
+ if (@_) {
+ _print "1..0 # Skip @_\n";
+ } else {
+ _print "1..0\n";
+ }
+ exit(0);
+}
+
+sub BAIL_OUT {
+ my ($reason) = @_;
+ _print("Bail out! $reason\n");
+ exit 255;
+}
+
+sub _ok {
+ my ($pass, $where, $name, @mess) = @_;
+ # Do not try to microoptimize by factoring out the "not ".
+ # VMS will avenge.
+ my $out;
+ if ($name) {
+ # escape out '#' or it will interfere with '# skip' and such
+ $name =~ s/#/\\#/g;
+ $out = $pass ? "ok $test - $name" : "not ok $test - $name";
+ } else {
+ $out = $pass ? "ok $test" : "not ok $test";
+ }
+
+ if ($TODO) {
+ $out = $out . " # TODO $TODO";
+ } else {
+ $Tests_Are_Passing = 0 unless $pass;
+ }
+
+ _print "$out\n";
+
+ if ($pass) {
+ note @mess; # Ensure that the message is properly escaped.
+ }
+ else {
+ my $msg = "# Failed test $test - ";
+ $msg.= "$name " if $name;
+ $msg .= "$where\n";
+ _diag $msg;
+ _diag @mess;
+ }
+
+ $test = $test + 1; # don't use ++
+
+ return $pass;
+}
+
+sub _where {
+ my @caller = caller($Level);
+ return "at $caller[1] line $caller[2]";
+}
+
+sub ok ($@) {
+ if (@_ > 1) { # ok() really was modern 'is', though limited
+ local $Level = $Level + 1;
+ return is(@_);
}
- ++$__ntest;
- if ($ok) {
- print "ok $__ntest\n"
+ my ($pass, $name, @mess) = @_;
+ _ok($pass, _where(), $name, @mess);
+}
+
+sub _q {
+ my $x = shift;
+ return 'undef' unless defined $x;
+ my $q = $x;
+ $q =~ s/\\/\\\\/g;
+ $q =~ s/'/\\'/g;
+ return "'$q'";
+}
+
+sub _qq {
+ my $x = shift;
+ return defined $x ? '"' . display ($x) . '"' : 'undef';
+};
+
+# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file.
+# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!").
+my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*";
+eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }'
+ if !defined &re::is_regexp;
+
+# keys are the codes \n etc map to, values are 2 char strings such as \n
+my %backslash_escape;
+my $x;
+foreach $x (split //, 'nrtfa\\\'"') {
+ $backslash_escape{ord eval "\"\\$x\""} = "\\$x";
+}
+# A way to display scalars containing control characters and Unicode.
+# Trying to avoid setting $_, or relying on local $_ to work.
+sub display {
+ my @result;
+ my $x;
+ foreach $x (@_) {
+ if (defined $x and not ref $x) {
+ my $y = '';
+ my $c;
+ foreach $c (unpack($chars_template, $x)) {
+ if ($c > 255) {
+ $y = $y . sprintf "\\x{%x}", $c;
+ } elsif ($backslash_escape{$c}) {
+ $y = $y . $backslash_escape{$c};
+ } else {
+ my $z = chr $c; # Maybe we can get away with a literal...
+ my $is_printable = ($::IS_ASCII)
+ ? $c >= ord(" ") && $c <= ord("~")
+ : $z !~ /[^[:^print:][:^ascii:]]/;
+ # /[::]/ was introduced before non-ASCII support
+ # The pattern above is equivalent (by de Morgan's
+ # laws) to:
+ # $z !~ /(?[ [:print:] & [:ascii:] ])/
+ # or, $z is not an ascii printable character
+
+ unless ($is_printable) {
+ # Use octal for characters with small ordinals that
+ # are traditionally expressed as octal: the controls
+ # below space, which on EBCDIC are almost all the
+ # controls, but on ASCII don't include DEL nor the C1
+ # controls.
+ if ($c < ord " ") {
+ $z = sprintf "\\%03o", $c;
+ } else {
+ $z = sprintf "\\x{%x}", $c;
+ }
+ }
+ $y = $y . $z;
+ }
+ }
+ $x = $y;
+ }
+ return $x unless wantarray;
+ push @result, $x;
+ }
+ return @result;
+}
+
+sub is ($$@) {
+ my ($got, $expected, $name, @mess) = @_;
+
+ my $pass;
+ if( !defined $got || !defined $expected ) {
+ # undef only matches undef
+ $pass = !defined $got && !defined $expected;
+ }
+ else {
+ $pass = $got eq $expected;
+ }
+
+ unless ($pass) {
+ unshift(@mess, "# got "._qq($got)."\n",
+ "# expected "._qq($expected)."\n");
+ }
+ _ok($pass, _where(), $name, @mess);
+}
+
+sub isnt ($$@) {
+ my ($got, $isnt, $name, @mess) = @_;
+
+ my $pass;
+ if( !defined $got || !defined $isnt ) {
+ # undef only matches undef
+ $pass = defined $got || defined $isnt;
}
else {
- print "not ok $__ntest\n"
+ $pass = $got ne $isnt;
+ }
+
+ unless( $pass ) {
+ unshift(@mess, "# it should not be "._qq($got)."\n",
+ "# but it is.\n");
}
+ _ok($pass, _where(), $name, @mess);
+}
+
+sub cmp_ok ($$$@) {
+ my($got, $type, $expected, $name, @mess) = @_;
+
+ my $pass;
+ {
+ local $^W = 0;
+ local($@,$!); # don't interfere with $@
+ # eval() sometimes resets $!
+ $pass = eval "\$got $type \$expected";
+ }
+ unless ($pass) {
+ # It seems Irix long doubles can have 2147483648 and 2147483648
+ # that stringify to the same thing but are actually numerically
+ # different. Display the numbers if $type isn't a string operator,
+ # and the numbers are stringwise the same.
+ # (all string operators have alphabetic names, so tr/a-z// is true)
+ # This will also show numbers for some unneeded cases, but will
+ # definitely be helpful for things such as == and <= that fail
+ if ($got eq $expected and $type !~ tr/a-z//) {
+ unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+ }
+ unshift(@mess, "# got "._qq($got)."\n",
+ "# expected $type "._qq($expected)."\n");
+ }
+ _ok($pass, _where(), $name, @mess);
+}
+
+# Check that $got is within $range of $expected
+# if $range is 0, then check it's exact
+# else if $expected is 0, then $range is an absolute value
+# otherwise $range is a fractional error.
+# Here $range must be numeric, >= 0
+# Non numeric ranges might be a useful future extension. (eg %)
+sub within ($$$@) {
+ my ($got, $expected, $range, $name, @mess) = @_;
+ my $pass;
+ if (!defined $got or !defined $expected or !defined $range) {
+ # This is a fail, but doesn't need extra diagnostics
+ } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) {
+ # This is a fail
+ unshift @mess, "# got, expected and range must be numeric\n";
+ } elsif ($range < 0) {
+ # This is also a fail
+ unshift @mess, "# range must not be negative\n";
+ } elsif ($range == 0) {
+ # Within 0 is ==
+ $pass = $got == $expected;
+ } elsif ($expected == 0) {
+ # If expected is 0, treat range as absolute
+ $pass = ($got <= $range) && ($got >= - $range);
+ } else {
+ my $diff = $got - $expected;
+ $pass = abs ($diff / $expected) < $range;
+ }
+ unless ($pass) {
+ if ($got eq $expected) {
+ unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n";
+ }
+ unshift@mess, "# got "._qq($got)."\n",
+ "# expected "._qq($expected)." (within "._qq($range).")\n";
+ }
+ _ok($pass, _where(), $name, @mess);
+}
+
+sub pass {
+ _ok(1, '', @_);
+}
+
+sub fail {
+ _ok(0, _where(), @_);
+}
+
+sub curr_test {
+ $test = shift if @_;
+ return $test;
+}
+
+sub next_test {
+ my $retval = $test;
+ $test = $test + 1; # don't use ++
+ $retval;
+}
+
+# Note: can't pass multipart messages since we try to
+# be compatible with Test::More::skip().
+sub skip {
+ my $why = shift;
+ my $n = @_ ? shift : 1;
+ my $bad_swap;
+ my $both_zero;
+ $n = 1 if $n == 0; # XXX Temporary
+ {
+ local $^W = 0;
+ $bad_swap = $why > 0 && $n == 0;
+ $both_zero = $why == 0 && $n == 0;
+ }
+ if ($bad_swap || $both_zero || @_) {
+ my $arg = "'$why', '$n'";
+ if (@_) {
+ $arg .= join(", ", '', map { qq['$_'] } @_);
+ }
+ die qq[$0: expected skip(why, count), got skip($arg)\n];
+ }
+ for (1..$n) {
+ _print "ok $test # skip $why\n";
+ $test = $test + 1;
+ }
+ local $^W = 0;
+ #last SKIP;
+}
+
+sub eq_array {
+ my ($ra, $rb) = @_;
+ return 0 unless $#$ra == $#$rb;
+ my $i;
+ for $i (0..$#$ra) {
+ next if !defined $ra->[$i] && !defined $rb->[$i];
+ return 0 if !defined $ra->[$i];
+ return 0 if !defined $rb->[$i];
+ return 0 unless $ra->[$i] eq $rb->[$i];
+ }
+ return 1;
+}
+
+sub eq_hash {
+ my ($orig, $suspect) = @_;
+ my $fail;
+ while (my ($key, $value) = each %$suspect) {
+ # Force a hash recompute if this perl's internals can cache the hash key.
+ $key = "" . $key;
+ if (exists $orig->{$key}) {
+ if (
+ defined $orig->{$key} != defined $value
+ || (defined $value && $orig->{$key} ne $value)
+ ) {
+ _print "# key ", _qq($key), " was ", _qq($orig->{$key}),
+ " now ", _qq($value), "\n";
+ $fail = 1;
+ }
+ } else {
+ _print "# key ", _qq($key), " is ", _qq($value),
+ ", not in original.\n";
+ $fail = 1;
+ }
+ }
+ foreach (keys %$orig) {
+ # Force a hash recompute if this perl's internals can cache the hash key.
+ $_ = "" . $_;
+ next if (exists $suspect->{$_});
+ _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n";
+ $fail = 1;
}
+ !$fail;
}
1;
https://perl5.git.perl.org / perl5.git / commitdiff