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