dist/Devel-PPPort/t/testutil.pl

   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;
  24 my $test = 1;
  25 my $planned;
  26 my $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.
  42 sub _print {
  43     local($\, $", $,) = (undef, ' ', '') if "$]" >= 5.004;
  44     print STDOUT @_;
  45 }
  46
  47 sub _print_stderr {
  48     local($\, $", $,) = (undef, ' ', '') if "$]" >= 5.004;
  49     print STDERR @_;
  50 }
  51
  52 sub 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.
  71 sub done_testing {
  72     my $n = $test - 1;
  73     $n = shift if @_;
  74
  75     _print "1..$n\n";
  76     $planned = $n;
  77 }
  78
  79
  80 END {
  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
  92 sub _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
 100 sub diag {
 101     _diag(@_);
 102 }
 103
 104 # Use this instead of "print" when outputting informational messages
 105 sub note {
 106     return unless @_;
 107     _print( _comment(@_) );
 108 }
 109
 110 sub _comment {
 111     return map { /^#/ ? "$_\n" : "# $_\n" }
 112            map { split /\n/ } @_;
 113 }
 114
 115 sub _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
 125 sub skip_all {
 126     if (@_) {
 127         _print "1..0 # Skip @_\n";
 128     } else {
 129         _print "1..0\n";
 130     }
 131     exit(0);
 132 }
 133
 134 sub BAIL_OUT {
 135     my ($reason) = @_;
 136     _print("Bail out!  $reason\n");
 137     exit 255;
 138 }
 139
 140 sub _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
 177 sub _where {
 178     my @caller = caller($Level);
 179     return "at $caller[1] line $caller[2]";
 180 }
 181
 182 sub ok ($@) {
 183     my ($pass, $name, @mess) = @_;
 184     _ok($pass, _where(), $name, @mess);
 185 }
 186
 187 sub _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
 196 sub _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 ("!").
 203 my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : defined(eval { pack "U*", 90 }) ? "U*" : "C*";
 204 eval '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
 208 my %backslash_escape;
 209 my $x;
 210 foreach $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.
 215 sub 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
 263 sub 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
 282 sub 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
 301 sub 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 %)
 334 sub 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
 365 sub pass {
 366     _ok(1, '', @_);
 367 }
 368
 369 sub fail {
 370     _ok(0, _where(), @_);
 371 }
 372
 373 sub curr_test {
 374     $test = shift if @_;
 375     return $test;
 376 }
 377
 378 sub 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().
 386 sub 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
 411 sub 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
 424 sub 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
 455 1;