| 1 | # |
| 2 | # t/test.pl - most of Test::More functionality without the fuss, plus |
| 3 | # has mappings native_to_latin1 and latin1_to_native so that fewer tests |
| 4 | # on non ASCII-ish platforms need to be skipped |
| 5 | |
| 6 | |
| 7 | # NOTE: |
| 8 | # |
| 9 | # Increment ($x++) has a certain amount of cleverness for things like |
| 10 | # |
| 11 | # $x = 'zz'; |
| 12 | # $x++; # $x eq 'aaa'; |
| 13 | # |
| 14 | # stands more chance of breaking than just a simple |
| 15 | # |
| 16 | # $x = $x + 1 |
| 17 | # |
| 18 | # In this file, we use the latter "Baby Perl" approach, and increment |
| 19 | # will be worked over by t/op/inc.t |
| 20 | |
| 21 | $Level = 1; |
| 22 | my $test = 1; |
| 23 | my $planned; |
| 24 | my $noplan; |
| 25 | my $Perl; # Safer version of $^X set by which_perl() |
| 26 | |
| 27 | # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC |
| 28 | $::IS_ASCII = ord 'A' == 65; |
| 29 | $::IS_EBCDIC = ord 'A' == 193; |
| 30 | |
| 31 | $TODO = 0; |
| 32 | $NO_ENDING = 0; |
| 33 | $Tests_Are_Passing = 1; |
| 34 | |
| 35 | # Use this instead of print to avoid interference while testing globals. |
| 36 | sub _print { |
| 37 | local($\, $", $,) = (undef, ' ', ''); |
| 38 | print STDOUT @_; |
| 39 | } |
| 40 | |
| 41 | sub _print_stderr { |
| 42 | local($\, $", $,) = (undef, ' ', ''); |
| 43 | print STDERR @_; |
| 44 | } |
| 45 | |
| 46 | sub plan { |
| 47 | my $n; |
| 48 | if (@_ == 1) { |
| 49 | $n = shift; |
| 50 | if ($n eq 'no_plan') { |
| 51 | undef $n; |
| 52 | $noplan = 1; |
| 53 | } |
| 54 | } else { |
| 55 | my %plan = @_; |
| 56 | $n = $plan{tests}; |
| 57 | } |
| 58 | _print "1..$n\n" unless $noplan; |
| 59 | $planned = $n; |
| 60 | } |
| 61 | |
| 62 | |
| 63 | # Set the plan at the end. See Test::More::done_testing. |
| 64 | sub done_testing { |
| 65 | my $n = $test - 1; |
| 66 | $n = shift if @_; |
| 67 | |
| 68 | _print "1..$n\n"; |
| 69 | $planned = $n; |
| 70 | } |
| 71 | |
| 72 | |
| 73 | END { |
| 74 | my $ran = $test - 1; |
| 75 | if (!$NO_ENDING) { |
| 76 | if (defined $planned && $planned != $ran) { |
| 77 | _print_stderr |
| 78 | "# Looks like you planned $planned tests but ran $ran.\n"; |
| 79 | } elsif ($noplan) { |
| 80 | _print "1..$ran\n"; |
| 81 | } |
| 82 | } |
| 83 | } |
| 84 | |
| 85 | sub _diag { |
| 86 | return unless @_; |
| 87 | my @mess = _comment(@_); |
| 88 | $TODO ? _print(@mess) : _print_stderr(@mess); |
| 89 | } |
| 90 | |
| 91 | # Use this instead of "print STDERR" when outputting failure diagnostic |
| 92 | # messages |
| 93 | sub diag { |
| 94 | _diag(@_); |
| 95 | } |
| 96 | |
| 97 | # Use this instead of "print" when outputting informational messages |
| 98 | sub note { |
| 99 | return unless @_; |
| 100 | _print( _comment(@_) ); |
| 101 | } |
| 102 | |
| 103 | sub is_miniperl { |
| 104 | return !defined &DynaLoader::boot_DynaLoader; |
| 105 | } |
| 106 | |
| 107 | sub _comment { |
| 108 | return map { /^#/ ? "$_\n" : "# $_\n" } |
| 109 | map { split /\n/ } @_; |
| 110 | } |
| 111 | |
| 112 | sub skip_all { |
| 113 | if (@_) { |
| 114 | _print "1..0 # Skip @_\n"; |
| 115 | } else { |
| 116 | _print "1..0\n"; |
| 117 | } |
| 118 | exit(0); |
| 119 | } |
| 120 | |
| 121 | sub skip_all_if_miniperl { |
| 122 | skip_all(@_) if is_miniperl(); |
| 123 | } |
| 124 | |
| 125 | sub skip_all_without_dynamic_extension { |
| 126 | my $extension = shift; |
| 127 | skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); |
| 128 | unless (eval {require Config; 1}) { |
| 129 | warn "test.pl had problems loading Config: $@"; |
| 130 | return; |
| 131 | } |
| 132 | $extension =~ s!::!/!g; |
| 133 | return if ($Config::Config{extensions} =~ /\b$extension\b/); |
| 134 | skip_all("$extension was not built"); |
| 135 | } |
| 136 | |
| 137 | sub skip_all_without_perlio { |
| 138 | skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); |
| 139 | } |
| 140 | |
| 141 | sub skip_all_without_config { |
| 142 | unless (eval {require Config; 1}) { |
| 143 | warn "test.pl had problems loading Config: $@"; |
| 144 | return; |
| 145 | } |
| 146 | foreach (@_) { |
| 147 | next if $Config::Config{$_}; |
| 148 | my $key = $_; # Need to copy, before trying to modify. |
| 149 | $key =~ s/^use//; |
| 150 | $key =~ s/^d_//; |
| 151 | skip_all("no $key"); |
| 152 | } |
| 153 | } |
| 154 | |
| 155 | sub find_git_or_skip { |
| 156 | my ($found_dir, $reason); |
| 157 | if (-d '.git') { |
| 158 | $found_dir = 1; |
| 159 | } elsif (-l 'MANIFEST' && -l 'AUTHORS') { |
| 160 | my $where = readlink 'MANIFEST'; |
| 161 | die "Can't readling MANIFEST: $!" unless defined $where; |
| 162 | die "Confusing symlink target for MANIFEST, '$where'" |
| 163 | unless $where =~ s!/MANIFEST\z!!; |
| 164 | if (-d "$where/.git") { |
| 165 | # Looks like we are in a symlink tree |
| 166 | chdir $where or die "Can't chdir '$where': $!"; |
| 167 | note("Found source tree at $where"); |
| 168 | $found_dir = 1; |
| 169 | } |
| 170 | } |
| 171 | if ($found_dir) { |
| 172 | my $version_string = `git --version`; |
| 173 | if (defined $version_string |
| 174 | && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { |
| 175 | return if eval "v$1 ge v1.5.0"; |
| 176 | # If you have earlier than 1.5.0 and it works, change this test |
| 177 | $reason = "in git checkout, but git version '$1$2' too old"; |
| 178 | } else { |
| 179 | $reason = "in git checkout, but cannot run git"; |
| 180 | } |
| 181 | } else { |
| 182 | $reason = 'not being run from a git checkout'; |
| 183 | } |
| 184 | skip_all($reason) if $_[0] && $_[0] eq 'all'; |
| 185 | skip($reason, @_); |
| 186 | } |
| 187 | |
| 188 | sub _ok { |
| 189 | my ($pass, $where, $name, @mess) = @_; |
| 190 | # Do not try to microoptimize by factoring out the "not ". |
| 191 | # VMS will avenge. |
| 192 | my $out; |
| 193 | if ($name) { |
| 194 | # escape out '#' or it will interfere with '# skip' and such |
| 195 | $name =~ s/#/\\#/g; |
| 196 | $out = $pass ? "ok $test - $name" : "not ok $test - $name"; |
| 197 | } else { |
| 198 | $out = $pass ? "ok $test" : "not ok $test"; |
| 199 | } |
| 200 | |
| 201 | if ($TODO) { |
| 202 | $out = $out . " # TODO $TODO"; |
| 203 | } else { |
| 204 | $Tests_Are_Passing = 0 unless $pass; |
| 205 | } |
| 206 | |
| 207 | _print "$out\n"; |
| 208 | |
| 209 | if ($pass) { |
| 210 | note @mess; # Ensure that the message is properly escaped. |
| 211 | } |
| 212 | else { |
| 213 | _diag "# Failed $where\n"; |
| 214 | _diag @mess; |
| 215 | } |
| 216 | |
| 217 | $test = $test + 1; # don't use ++ |
| 218 | |
| 219 | return $pass; |
| 220 | } |
| 221 | |
| 222 | sub _where { |
| 223 | my @caller = caller($Level); |
| 224 | return "at $caller[1] line $caller[2]"; |
| 225 | } |
| 226 | |
| 227 | # DON'T use this for matches. Use like() instead. |
| 228 | sub ok ($@) { |
| 229 | my ($pass, $name, @mess) = @_; |
| 230 | _ok($pass, _where(), $name, @mess); |
| 231 | } |
| 232 | |
| 233 | sub _q { |
| 234 | my $x = shift; |
| 235 | return 'undef' unless defined $x; |
| 236 | my $q = $x; |
| 237 | $q =~ s/\\/\\\\/g; |
| 238 | $q =~ s/'/\\'/g; |
| 239 | return "'$q'"; |
| 240 | } |
| 241 | |
| 242 | sub _qq { |
| 243 | my $x = shift; |
| 244 | return defined $x ? '"' . display ($x) . '"' : 'undef'; |
| 245 | }; |
| 246 | |
| 247 | # keys are the codes \n etc map to, values are 2 char strings such as \n |
| 248 | my %backslash_escape; |
| 249 | foreach my $x (split //, 'nrtfa\\\'"') { |
| 250 | $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; |
| 251 | } |
| 252 | # A way to display scalars containing control characters and Unicode. |
| 253 | # Trying to avoid setting $_, or relying on local $_ to work. |
| 254 | sub display { |
| 255 | my @result; |
| 256 | foreach my $x (@_) { |
| 257 | if (defined $x and not ref $x) { |
| 258 | my $y = ''; |
| 259 | foreach my $c (unpack("U*", $x)) { |
| 260 | if ($c > 255) { |
| 261 | $y = $y . sprintf "\\x{%x}", $c; |
| 262 | } elsif ($backslash_escape{$c}) { |
| 263 | $y = $y . $backslash_escape{$c}; |
| 264 | } else { |
| 265 | my $z = chr $c; # Maybe we can get away with a literal... |
| 266 | if ($z =~ /[[:^print:]]/) { |
| 267 | |
| 268 | # Use octal for characters traditionally expressed as |
| 269 | # such: the low controls |
| 270 | if ($c <= 037) { |
| 271 | $z = sprintf "\\%03o", $c; |
| 272 | } else { |
| 273 | $z = sprintf "\\x{%x}", $c; |
| 274 | } |
| 275 | } |
| 276 | $y = $y . $z; |
| 277 | } |
| 278 | } |
| 279 | $x = $y; |
| 280 | } |
| 281 | return $x unless wantarray; |
| 282 | push @result, $x; |
| 283 | } |
| 284 | return @result; |
| 285 | } |
| 286 | |
| 287 | sub is ($$@) { |
| 288 | my ($got, $expected, $name, @mess) = @_; |
| 289 | |
| 290 | my $pass; |
| 291 | if( !defined $got || !defined $expected ) { |
| 292 | # undef only matches undef |
| 293 | $pass = !defined $got && !defined $expected; |
| 294 | } |
| 295 | else { |
| 296 | $pass = $got eq $expected; |
| 297 | } |
| 298 | |
| 299 | unless ($pass) { |
| 300 | unshift(@mess, "# got "._qq($got)."\n", |
| 301 | "# expected "._qq($expected)."\n"); |
| 302 | } |
| 303 | _ok($pass, _where(), $name, @mess); |
| 304 | } |
| 305 | |
| 306 | sub isnt ($$@) { |
| 307 | my ($got, $isnt, $name, @mess) = @_; |
| 308 | |
| 309 | my $pass; |
| 310 | if( !defined $got || !defined $isnt ) { |
| 311 | # undef only matches undef |
| 312 | $pass = defined $got || defined $isnt; |
| 313 | } |
| 314 | else { |
| 315 | $pass = $got ne $isnt; |
| 316 | } |
| 317 | |
| 318 | unless( $pass ) { |
| 319 | unshift(@mess, "# it should not be "._qq($got)."\n", |
| 320 | "# but it is.\n"); |
| 321 | } |
| 322 | _ok($pass, _where(), $name, @mess); |
| 323 | } |
| 324 | |
| 325 | sub cmp_ok ($$$@) { |
| 326 | my($got, $type, $expected, $name, @mess) = @_; |
| 327 | |
| 328 | my $pass; |
| 329 | { |
| 330 | local $^W = 0; |
| 331 | local($@,$!); # don't interfere with $@ |
| 332 | # eval() sometimes resets $! |
| 333 | $pass = eval "\$got $type \$expected"; |
| 334 | } |
| 335 | unless ($pass) { |
| 336 | # It seems Irix long doubles can have 2147483648 and 2147483648 |
| 337 | # that stringify to the same thing but are actually numerically |
| 338 | # different. Display the numbers if $type isn't a string operator, |
| 339 | # and the numbers are stringwise the same. |
| 340 | # (all string operators have alphabetic names, so tr/a-z// is true) |
| 341 | # This will also show numbers for some unneeded cases, but will |
| 342 | # definitely be helpful for things such as == and <= that fail |
| 343 | if ($got eq $expected and $type !~ tr/a-z//) { |
| 344 | unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; |
| 345 | } |
| 346 | unshift(@mess, "# got "._qq($got)."\n", |
| 347 | "# expected $type "._qq($expected)."\n"); |
| 348 | } |
| 349 | _ok($pass, _where(), $name, @mess); |
| 350 | } |
| 351 | |
| 352 | # Check that $got is within $range of $expected |
| 353 | # if $range is 0, then check it's exact |
| 354 | # else if $expected is 0, then $range is an absolute value |
| 355 | # otherwise $range is a fractional error. |
| 356 | # Here $range must be numeric, >= 0 |
| 357 | # Non numeric ranges might be a useful future extension. (eg %) |
| 358 | sub within ($$$@) { |
| 359 | my ($got, $expected, $range, $name, @mess) = @_; |
| 360 | my $pass; |
| 361 | if (!defined $got or !defined $expected or !defined $range) { |
| 362 | # This is a fail, but doesn't need extra diagnostics |
| 363 | } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { |
| 364 | # This is a fail |
| 365 | unshift @mess, "# got, expected and range must be numeric\n"; |
| 366 | } elsif ($range < 0) { |
| 367 | # This is also a fail |
| 368 | unshift @mess, "# range must not be negative\n"; |
| 369 | } elsif ($range == 0) { |
| 370 | # Within 0 is == |
| 371 | $pass = $got == $expected; |
| 372 | } elsif ($expected == 0) { |
| 373 | # If expected is 0, treat range as absolute |
| 374 | $pass = ($got <= $range) && ($got >= - $range); |
| 375 | } else { |
| 376 | my $diff = $got - $expected; |
| 377 | $pass = abs ($diff / $expected) < $range; |
| 378 | } |
| 379 | unless ($pass) { |
| 380 | if ($got eq $expected) { |
| 381 | unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; |
| 382 | } |
| 383 | unshift@mess, "# got "._qq($got)."\n", |
| 384 | "# expected "._qq($expected)." (within "._qq($range).")\n"; |
| 385 | } |
| 386 | _ok($pass, _where(), $name, @mess); |
| 387 | } |
| 388 | |
| 389 | # Note: this isn't quite as fancy as Test::More::like(). |
| 390 | |
| 391 | sub like ($$@) { like_yn (0,@_) }; # 0 for - |
| 392 | sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- |
| 393 | |
| 394 | sub like_yn ($$$@) { |
| 395 | my ($flip, undef, $expected, $name, @mess) = @_; |
| 396 | my $pass; |
| 397 | $pass = $_[1] =~ /$expected/ if !$flip; |
| 398 | $pass = $_[1] !~ /$expected/ if $flip; |
| 399 | unless ($pass) { |
| 400 | unshift(@mess, "# got '$_[1]'\n", |
| 401 | $flip |
| 402 | ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); |
| 403 | } |
| 404 | local $Level = $Level + 1; |
| 405 | _ok($pass, _where(), $name, @mess); |
| 406 | } |
| 407 | |
| 408 | sub pass { |
| 409 | _ok(1, '', @_); |
| 410 | } |
| 411 | |
| 412 | sub fail { |
| 413 | _ok(0, _where(), @_); |
| 414 | } |
| 415 | |
| 416 | sub curr_test { |
| 417 | $test = shift if @_; |
| 418 | return $test; |
| 419 | } |
| 420 | |
| 421 | sub next_test { |
| 422 | my $retval = $test; |
| 423 | $test = $test + 1; # don't use ++ |
| 424 | $retval; |
| 425 | } |
| 426 | |
| 427 | # Note: can't pass multipart messages since we try to |
| 428 | # be compatible with Test::More::skip(). |
| 429 | sub skip { |
| 430 | my $why = shift; |
| 431 | my $n = @_ ? shift : 1; |
| 432 | for (1..$n) { |
| 433 | _print "ok $test # skip $why\n"; |
| 434 | $test = $test + 1; |
| 435 | } |
| 436 | local $^W = 0; |
| 437 | last SKIP; |
| 438 | } |
| 439 | |
| 440 | sub skip_if_miniperl { |
| 441 | skip(@_) if is_miniperl(); |
| 442 | } |
| 443 | |
| 444 | sub todo_skip { |
| 445 | my $why = shift; |
| 446 | my $n = @_ ? shift : 1; |
| 447 | |
| 448 | for (1..$n) { |
| 449 | _print "not ok $test # TODO & SKIP $why\n"; |
| 450 | $test = $test + 1; |
| 451 | } |
| 452 | local $^W = 0; |
| 453 | last TODO; |
| 454 | } |
| 455 | |
| 456 | sub eq_array { |
| 457 | my ($ra, $rb) = @_; |
| 458 | return 0 unless $#$ra == $#$rb; |
| 459 | for my $i (0..$#$ra) { |
| 460 | next if !defined $ra->[$i] && !defined $rb->[$i]; |
| 461 | return 0 if !defined $ra->[$i]; |
| 462 | return 0 if !defined $rb->[$i]; |
| 463 | return 0 unless $ra->[$i] eq $rb->[$i]; |
| 464 | } |
| 465 | return 1; |
| 466 | } |
| 467 | |
| 468 | sub eq_hash { |
| 469 | my ($orig, $suspect) = @_; |
| 470 | my $fail; |
| 471 | while (my ($key, $value) = each %$suspect) { |
| 472 | # Force a hash recompute if this perl's internals can cache the hash key. |
| 473 | $key = "" . $key; |
| 474 | if (exists $orig->{$key}) { |
| 475 | if ($orig->{$key} ne $value) { |
| 476 | _print "# key ", _qq($key), " was ", _qq($orig->{$key}), |
| 477 | " now ", _qq($value), "\n"; |
| 478 | $fail = 1; |
| 479 | } |
| 480 | } else { |
| 481 | _print "# key ", _qq($key), " is ", _qq($value), |
| 482 | ", not in original.\n"; |
| 483 | $fail = 1; |
| 484 | } |
| 485 | } |
| 486 | foreach (keys %$orig) { |
| 487 | # Force a hash recompute if this perl's internals can cache the hash key. |
| 488 | $_ = "" . $_; |
| 489 | next if (exists $suspect->{$_}); |
| 490 | _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; |
| 491 | $fail = 1; |
| 492 | } |
| 493 | !$fail; |
| 494 | } |
| 495 | |
| 496 | # We only provide a subset of the Test::More functionality. |
| 497 | sub require_ok ($) { |
| 498 | my ($require) = @_; |
| 499 | if ($require =~ tr/[A-Za-z0-9:.]//c) { |
| 500 | fail("Invalid character in \"$require\", passed to require_ok"); |
| 501 | } else { |
| 502 | eval <<REQUIRE_OK; |
| 503 | require $require; |
| 504 | REQUIRE_OK |
| 505 | is($@, '', _where(), "require $require"); |
| 506 | } |
| 507 | } |
| 508 | |
| 509 | sub use_ok ($) { |
| 510 | my ($use) = @_; |
| 511 | if ($use =~ tr/[A-Za-z0-9:.]//c) { |
| 512 | fail("Invalid character in \"$use\", passed to use"); |
| 513 | } else { |
| 514 | eval <<USE_OK; |
| 515 | use $use; |
| 516 | USE_OK |
| 517 | is($@, '', _where(), "use $use"); |
| 518 | } |
| 519 | } |
| 520 | |
| 521 | # runperl - Runs a separate perl interpreter. |
| 522 | # Arguments : |
| 523 | # switches => [ command-line switches ] |
| 524 | # nolib => 1 # don't use -I../lib (included by default) |
| 525 | # non_portable => Don't warn if a one liner contains quotes |
| 526 | # prog => one-liner (avoid quotes) |
| 527 | # progs => [ multi-liner (avoid quotes) ] |
| 528 | # progfile => perl script |
| 529 | # stdin => string to feed the stdin |
| 530 | # stderr => redirect stderr to stdout |
| 531 | # args => [ command-line arguments to the perl program ] |
| 532 | # verbose => print the command line |
| 533 | |
| 534 | my $is_mswin = $^O eq 'MSWin32'; |
| 535 | my $is_netware = $^O eq 'NetWare'; |
| 536 | my $is_vms = $^O eq 'VMS'; |
| 537 | my $is_cygwin = $^O eq 'cygwin'; |
| 538 | |
| 539 | sub _quote_args { |
| 540 | my ($runperl, $args) = @_; |
| 541 | |
| 542 | foreach (@$args) { |
| 543 | # In VMS protect with doublequotes because otherwise |
| 544 | # DCL will lowercase -- unless already doublequoted. |
| 545 | $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; |
| 546 | $runperl = $runperl . ' ' . $_; |
| 547 | } |
| 548 | return $runperl; |
| 549 | } |
| 550 | |
| 551 | sub _create_runperl { # Create the string to qx in runperl(). |
| 552 | my %args = @_; |
| 553 | my $runperl = which_perl(); |
| 554 | if ($runperl =~ m/\s/) { |
| 555 | $runperl = qq{"$runperl"}; |
| 556 | } |
| 557 | #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind |
| 558 | if ($ENV{PERL_RUNPERL_DEBUG}) { |
| 559 | $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; |
| 560 | } |
| 561 | unless ($args{nolib}) { |
| 562 | $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS |
| 563 | } |
| 564 | if ($args{switches}) { |
| 565 | local $Level = 2; |
| 566 | die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() |
| 567 | unless ref $args{switches} eq "ARRAY"; |
| 568 | $runperl = _quote_args($runperl, $args{switches}); |
| 569 | } |
| 570 | if (defined $args{prog}) { |
| 571 | die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() |
| 572 | if defined $args{progs}; |
| 573 | $args{progs} = [$args{prog}] |
| 574 | } |
| 575 | if (defined $args{progs}) { |
| 576 | die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() |
| 577 | unless ref $args{progs} eq "ARRAY"; |
| 578 | foreach my $prog (@{$args{progs}}) { |
| 579 | if ($prog =~ tr/'"// && !$args{non_portable}) { |
| 580 | warn "quotes in prog >>$prog<< are not portable"; |
| 581 | } |
| 582 | if ($is_mswin || $is_netware || $is_vms) { |
| 583 | $runperl = $runperl . qq ( -e "$prog" ); |
| 584 | } |
| 585 | else { |
| 586 | $runperl = $runperl . qq ( -e '$prog' ); |
| 587 | } |
| 588 | } |
| 589 | } elsif (defined $args{progfile}) { |
| 590 | $runperl = $runperl . qq( "$args{progfile}"); |
| 591 | } else { |
| 592 | # You probably didn't want to be sucking in from the upstream stdin |
| 593 | die "test.pl:runperl(): none of prog, progs, progfile, args, " |
| 594 | . " switches or stdin specified" |
| 595 | unless defined $args{args} or defined $args{switches} |
| 596 | or defined $args{stdin}; |
| 597 | } |
| 598 | if (defined $args{stdin}) { |
| 599 | # so we don't try to put literal newlines and crs onto the |
| 600 | # command line. |
| 601 | $args{stdin} =~ s/\n/\\n/g; |
| 602 | $args{stdin} =~ s/\r/\\r/g; |
| 603 | |
| 604 | if ($is_mswin || $is_netware || $is_vms) { |
| 605 | $runperl = qq{$Perl -e "print qq(} . |
| 606 | $args{stdin} . q{)" | } . $runperl; |
| 607 | } |
| 608 | else { |
| 609 | $runperl = qq{$Perl -e 'print qq(} . |
| 610 | $args{stdin} . q{)' | } . $runperl; |
| 611 | } |
| 612 | } |
| 613 | if (defined $args{args}) { |
| 614 | $runperl = _quote_args($runperl, $args{args}); |
| 615 | } |
| 616 | $runperl = $runperl . ' 2>&1' if $args{stderr}; |
| 617 | if ($args{verbose}) { |
| 618 | my $runperldisplay = $runperl; |
| 619 | $runperldisplay =~ s/\n/\n\#/g; |
| 620 | _print_stderr "# $runperldisplay\n"; |
| 621 | } |
| 622 | return $runperl; |
| 623 | } |
| 624 | |
| 625 | sub runperl { |
| 626 | die "test.pl:runperl() does not take a hashref" |
| 627 | if ref $_[0] and ref $_[0] eq 'HASH'; |
| 628 | my $runperl = &_create_runperl; |
| 629 | my $result; |
| 630 | |
| 631 | my $tainted = ${^TAINT}; |
| 632 | my %args = @_; |
| 633 | exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; |
| 634 | |
| 635 | if ($tainted) { |
| 636 | # We will assume that if you're running under -T, you really mean to |
| 637 | # run a fresh perl, so we'll brute force launder everything for you |
| 638 | my $sep; |
| 639 | |
| 640 | if (! eval {require Config; 1}) { |
| 641 | warn "test.pl had problems loading Config: $@"; |
| 642 | $sep = ':'; |
| 643 | } else { |
| 644 | $sep = $Config::Config{path_sep}; |
| 645 | } |
| 646 | |
| 647 | my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); |
| 648 | local @ENV{@keys} = (); |
| 649 | # Untaint, plus take out . and empty string: |
| 650 | local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); |
| 651 | $ENV{PATH} =~ /(.*)/s; |
| 652 | local $ENV{PATH} = |
| 653 | join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and |
| 654 | ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } |
| 655 | split quotemeta ($sep), $1; |
| 656 | if ($is_cygwin) { # Must have /bin under Cygwin |
| 657 | if (length $ENV{PATH}) { |
| 658 | $ENV{PATH} = $ENV{PATH} . $sep; |
| 659 | } |
| 660 | $ENV{PATH} = $ENV{PATH} . '/bin'; |
| 661 | } |
| 662 | $runperl =~ /(.*)/s; |
| 663 | $runperl = $1; |
| 664 | |
| 665 | $result = `$runperl`; |
| 666 | } else { |
| 667 | $result = `$runperl`; |
| 668 | } |
| 669 | $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these |
| 670 | return $result; |
| 671 | } |
| 672 | |
| 673 | # Nice alias |
| 674 | *run_perl = *run_perl = \&runperl; # shut up "used only once" warning |
| 675 | |
| 676 | sub DIE { |
| 677 | _print_stderr "# @_\n"; |
| 678 | exit 1; |
| 679 | } |
| 680 | |
| 681 | # A somewhat safer version of the sometimes wrong $^X. |
| 682 | sub which_perl { |
| 683 | unless (defined $Perl) { |
| 684 | $Perl = $^X; |
| 685 | |
| 686 | # VMS should have 'perl' aliased properly |
| 687 | return $Perl if $is_vms; |
| 688 | |
| 689 | my $exe; |
| 690 | if (! eval {require Config; 1}) { |
| 691 | warn "test.pl had problems loading Config: $@"; |
| 692 | $exe = ''; |
| 693 | } else { |
| 694 | $exe = $Config::Config{_exe}; |
| 695 | } |
| 696 | $exe = '' unless defined $exe; |
| 697 | |
| 698 | # This doesn't absolutize the path: beware of future chdirs(). |
| 699 | # We could do File::Spec->abs2rel() but that does getcwd()s, |
| 700 | # which is a bit heavyweight to do here. |
| 701 | |
| 702 | if ($Perl =~ /^perl\Q$exe\E$/i) { |
| 703 | my $perl = "perl$exe"; |
| 704 | if (! eval {require File::Spec; 1}) { |
| 705 | warn "test.pl had problems loading File::Spec: $@"; |
| 706 | $Perl = "./$perl"; |
| 707 | } else { |
| 708 | $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); |
| 709 | } |
| 710 | } |
| 711 | |
| 712 | # Build up the name of the executable file from the name of |
| 713 | # the command. |
| 714 | |
| 715 | if ($Perl !~ /\Q$exe\E$/i) { |
| 716 | $Perl = $Perl . $exe; |
| 717 | } |
| 718 | |
| 719 | warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; |
| 720 | |
| 721 | # For subcommands to use. |
| 722 | $ENV{PERLEXE} = $Perl; |
| 723 | } |
| 724 | return $Perl; |
| 725 | } |
| 726 | |
| 727 | sub unlink_all { |
| 728 | my $count = 0; |
| 729 | foreach my $file (@_) { |
| 730 | 1 while unlink $file; |
| 731 | if( -f $file ){ |
| 732 | _print_stderr "# Couldn't unlink '$file': $!\n"; |
| 733 | }else{ |
| 734 | ++$count; |
| 735 | } |
| 736 | } |
| 737 | $count; |
| 738 | } |
| 739 | |
| 740 | my %tmpfiles; |
| 741 | END { unlink_all keys %tmpfiles } |
| 742 | |
| 743 | # A regexp that matches the tempfile names |
| 744 | $::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; |
| 745 | |
| 746 | # Avoid ++, avoid ranges, avoid split // |
| 747 | my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); |
| 748 | sub tempfile { |
| 749 | my $count = 0; |
| 750 | do { |
| 751 | my $temp = $count; |
| 752 | my $try = "tmp$$"; |
| 753 | do { |
| 754 | $try = $try . $letters[$temp % 26]; |
| 755 | $temp = int ($temp / 26); |
| 756 | } while $temp; |
| 757 | # Need to note all the file names we allocated, as a second request may |
| 758 | # come before the first is created. |
| 759 | if (!-e $try && !$tmpfiles{$try}) { |
| 760 | # We have a winner |
| 761 | $tmpfiles{$try} = 1; |
| 762 | return $try; |
| 763 | } |
| 764 | $count = $count + 1; |
| 765 | } while $count < 26 * 26; |
| 766 | die "Can't find temporary file name starting 'tmp$$'"; |
| 767 | } |
| 768 | |
| 769 | # This is the temporary file for _fresh_perl |
| 770 | my $tmpfile = tempfile(); |
| 771 | |
| 772 | sub _fresh_perl { |
| 773 | my($prog, $action, $expect, $runperl_args, $name) = @_; |
| 774 | |
| 775 | # Given the choice of the mis-parsable {} |
| 776 | # (we want an anon hash, but a borked lexer might think that it's a block) |
| 777 | # or relying on taking a reference to a lexical |
| 778 | # (\ might be mis-parsed, and the reference counting on the pad may go |
| 779 | # awry) |
| 780 | # it feels like the least-worse thing is to assume that auto-vivification |
| 781 | # works. At least, this is only going to be a run-time failure, so won't |
| 782 | # affect tests using this file but not this function. |
| 783 | $runperl_args->{progfile} = $tmpfile; |
| 784 | $runperl_args->{stderr} = 1; |
| 785 | |
| 786 | open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; |
| 787 | |
| 788 | # VMS adjustments |
| 789 | if( $is_vms ) { |
| 790 | $prog =~ s#/dev/null#NL:#; |
| 791 | |
| 792 | # VMS file locking |
| 793 | $prog =~ s{if \(-e _ and -f _ and -r _\)} |
| 794 | {if (-e _ and -f _)} |
| 795 | } |
| 796 | |
| 797 | print TEST $prog; |
| 798 | close TEST or die "Cannot close $tmpfile: $!"; |
| 799 | |
| 800 | my $results = runperl(%$runperl_args); |
| 801 | my $status = $?; |
| 802 | |
| 803 | # Clean up the results into something a bit more predictable. |
| 804 | $results =~ s/\n+$//; |
| 805 | $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; |
| 806 | $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; |
| 807 | |
| 808 | # bison says 'parse error' instead of 'syntax error', |
| 809 | # various yaccs may or may not capitalize 'syntax'. |
| 810 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
| 811 | |
| 812 | if ($is_vms) { |
| 813 | # some tests will trigger VMS messages that won't be expected |
| 814 | $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; |
| 815 | |
| 816 | # pipes double these sometimes |
| 817 | $results =~ s/\n\n/\n/g; |
| 818 | } |
| 819 | |
| 820 | # Use the first line of the program as a name if none was given |
| 821 | unless( $name ) { |
| 822 | ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; |
| 823 | $name = $name . '...' if length $first_line > length $name; |
| 824 | } |
| 825 | |
| 826 | # Historically this was implemented using a closure, but then that means |
| 827 | # that the tests for closures avoid using this code. Given that there |
| 828 | # are exactly two callers, doing exactly two things, the simpler approach |
| 829 | # feels like a better trade off. |
| 830 | my $pass; |
| 831 | if ($action eq 'eq') { |
| 832 | $pass = is($results, $expect, $name); |
| 833 | } elsif ($action eq '=~') { |
| 834 | $pass = like($results, $expect, $name); |
| 835 | } else { |
| 836 | die "_fresh_perl can't process action '$action'"; |
| 837 | } |
| 838 | |
| 839 | unless ($pass) { |
| 840 | _diag "# PROG: \n$prog\n"; |
| 841 | _diag "# STATUS: $status\n"; |
| 842 | } |
| 843 | |
| 844 | return $pass; |
| 845 | } |
| 846 | |
| 847 | # |
| 848 | # fresh_perl_is |
| 849 | # |
| 850 | # Combination of run_perl() and is(). |
| 851 | # |
| 852 | |
| 853 | sub fresh_perl_is { |
| 854 | my($prog, $expected, $runperl_args, $name) = @_; |
| 855 | |
| 856 | # _fresh_perl() is going to clip the trailing newlines off the result. |
| 857 | # This will make it so the test author doesn't have to know that. |
| 858 | $expected =~ s/\n+$//; |
| 859 | |
| 860 | local $Level = 2; |
| 861 | _fresh_perl($prog, 'eq', $expected, $runperl_args, $name); |
| 862 | } |
| 863 | |
| 864 | # |
| 865 | # fresh_perl_like |
| 866 | # |
| 867 | # Combination of run_perl() and like(). |
| 868 | # |
| 869 | |
| 870 | sub fresh_perl_like { |
| 871 | my($prog, $expected, $runperl_args, $name) = @_; |
| 872 | local $Level = 2; |
| 873 | _fresh_perl($prog, '=~', $expected, $runperl_args, $name); |
| 874 | } |
| 875 | |
| 876 | # Many tests use the same format in __DATA__ or external files to specify a |
| 877 | # sequence of (fresh) tests to run, extra files they may temporarily need, and |
| 878 | # what the expected output is. So have excatly one copy of the code to run that |
| 879 | # |
| 880 | # Each program is source code to run followed by an "EXPECT" line, followed |
| 881 | # by the expected output. |
| 882 | # |
| 883 | # The code to run may contain: |
| 884 | # # TODO reason for todo |
| 885 | # # SKIP reason for skip |
| 886 | # # SKIP ?code to test if this should be skipped |
| 887 | # # NAME name of the test (as with ok($ok, $name)) |
| 888 | # |
| 889 | # The expected output may contain: |
| 890 | # OPTION list of options |
| 891 | # OPTIONS list of options |
| 892 | # PREFIX |
| 893 | # indicates that the supplied output is only a prefix to the |
| 894 | # expected output |
| 895 | # |
| 896 | # The possible options for OPTION may be: |
| 897 | # regex - the expected output is a regular expression |
| 898 | # random - all lines match but in any order |
| 899 | # fatal - the code will fail fatally (croak, die) |
| 900 | # |
| 901 | # If the actual output contains a line "SKIPPED" the test will be |
| 902 | # skipped. |
| 903 | # |
| 904 | # If the global variable $FATAL is true then OPTION fatal is the |
| 905 | # default. |
| 906 | |
| 907 | sub run_multiple_progs { |
| 908 | my $up = shift; |
| 909 | my @prgs; |
| 910 | if ($up) { |
| 911 | # The tests in lib run in a temporary subdirectory of t, and always |
| 912 | # pass in a list of "programs" to run |
| 913 | @prgs = @_; |
| 914 | } else { |
| 915 | # The tests below t run in t and pass in a file handle. |
| 916 | my $fh = shift; |
| 917 | local $/; |
| 918 | @prgs = split "\n########\n", <$fh>; |
| 919 | } |
| 920 | |
| 921 | my $tmpfile = tempfile(); |
| 922 | |
| 923 | for (@prgs){ |
| 924 | unless (/\n/) { |
| 925 | print "# From $_\n"; |
| 926 | next; |
| 927 | } |
| 928 | my $switch = ""; |
| 929 | my @temps ; |
| 930 | my @temp_path; |
| 931 | if (s/^(\s*-\w+)//) { |
| 932 | $switch = $1; |
| 933 | } |
| 934 | my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); |
| 935 | |
| 936 | my %reason; |
| 937 | foreach my $what (qw(skip todo)) { |
| 938 | $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; |
| 939 | # If the SKIP reason starts ? then it's taken as a code snippet to |
| 940 | # evaluate. This provides the flexibility to have conditional SKIPs |
| 941 | if ($reason{$what} && $reason{$what} =~ s/^\?//) { |
| 942 | my $temp = eval $reason{$what}; |
| 943 | if ($@) { |
| 944 | die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; |
| 945 | } |
| 946 | $reason{$what} = $temp; |
| 947 | } |
| 948 | } |
| 949 | my $name = ''; |
| 950 | if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { |
| 951 | $name = $1; |
| 952 | } |
| 953 | |
| 954 | if ($prog =~ /--FILE--/) { |
| 955 | my @files = split(/\n--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; |
| 956 | shift @files ; |
| 957 | die "Internal error: test $_ didn't split into pairs, got " . |
| 958 | scalar(@files) . "[" . join("%%%%", @files) ."]\n" |
| 959 | if @files % 2; |
| 960 | while (@files > 2) { |
| 961 | my $filename = shift @files; |
| 962 | my $code = shift @files; |
| 963 | push @temps, $filename; |
| 964 | if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { |
| 965 | require File::Path; |
| 966 | File::Path::mkpath($1); |
| 967 | push(@temp_path, $1); |
| 968 | } |
| 969 | open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; |
| 970 | print $fh $code; |
| 971 | close $fh or die "Cannot close $filename: $!\n"; |
| 972 | } |
| 973 | shift @files; |
| 974 | $prog = shift @files; |
| 975 | } |
| 976 | |
| 977 | open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; |
| 978 | print $fh q{ |
| 979 | BEGIN { |
| 980 | open STDERR, '>&', STDOUT |
| 981 | or die "Can't dup STDOUT->STDERR: $!;"; |
| 982 | } |
| 983 | }; |
| 984 | print $fh "\n#line 1\n"; # So the line numbers don't get messed up. |
| 985 | print $fh $prog,"\n"; |
| 986 | close $fh or die "Cannot close $tmpfile: $!"; |
| 987 | my $results = runperl( stderr => 1, progfile => $tmpfile, $up |
| 988 | ? (switches => ["-I$up/lib", $switch], nolib => 1) |
| 989 | : (switches => [$switch]) |
| 990 | ); |
| 991 | my $status = $?; |
| 992 | $results =~ s/\n+$//; |
| 993 | # allow expected output to be written as if $prog is on STDIN |
| 994 | $results =~ s/$::tempfile_regexp/-/g; |
| 995 | if ($^O eq 'VMS') { |
| 996 | # some tests will trigger VMS messages that won't be expected |
| 997 | $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; |
| 998 | |
| 999 | # pipes double these sometimes |
| 1000 | $results =~ s/\n\n/\n/g; |
| 1001 | } |
| 1002 | # bison says 'parse error' instead of 'syntax error', |
| 1003 | # various yaccs may or may not capitalize 'syntax'. |
| 1004 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
| 1005 | # allow all tests to run when there are leaks |
| 1006 | $results =~ s/Scalars leaked: \d+\n//g; |
| 1007 | |
| 1008 | $expected =~ s/\n+$//; |
| 1009 | my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; |
| 1010 | # any special options? (OPTIONS foo bar zap) |
| 1011 | my $option_regex = 0; |
| 1012 | my $option_random = 0; |
| 1013 | my $fatal = $FATAL; |
| 1014 | if ($expected =~ s/^OPTIONS? (.+)\n//) { |
| 1015 | foreach my $option (split(' ', $1)) { |
| 1016 | if ($option eq 'regex') { # allow regular expressions |
| 1017 | $option_regex = 1; |
| 1018 | } |
| 1019 | elsif ($option eq 'random') { # all lines match, but in any order |
| 1020 | $option_random = 1; |
| 1021 | } |
| 1022 | elsif ($option eq 'fatal') { # perl should fail |
| 1023 | $fatal = 1; |
| 1024 | } |
| 1025 | else { |
| 1026 | die "$0: Unknown OPTION '$option'\n"; |
| 1027 | } |
| 1028 | } |
| 1029 | } |
| 1030 | die "$0: can't have OPTION regex and random\n" |
| 1031 | if $option_regex + $option_random > 1; |
| 1032 | my $ok = 0; |
| 1033 | if ($results =~ s/^SKIPPED\n//) { |
| 1034 | print "$results\n" ; |
| 1035 | $ok = 1; |
| 1036 | } |
| 1037 | else { |
| 1038 | if ($option_random) { |
| 1039 | my @got = sort split "\n", $results; |
| 1040 | my @expected = sort split "\n", $expected; |
| 1041 | |
| 1042 | $ok = "@got" eq "@expected"; |
| 1043 | } |
| 1044 | elsif ($option_regex) { |
| 1045 | $ok = $results =~ /^$expected/; |
| 1046 | } |
| 1047 | elsif ($prefix) { |
| 1048 | $ok = $results =~ /^\Q$expected/; |
| 1049 | } |
| 1050 | else { |
| 1051 | $ok = $results eq $expected; |
| 1052 | } |
| 1053 | |
| 1054 | if ($ok && $fatal && !($status >> 8)) { |
| 1055 | $ok = 0; |
| 1056 | } |
| 1057 | } |
| 1058 | |
| 1059 | local $::TODO = $reason{todo}; |
| 1060 | |
| 1061 | unless ($ok) { |
| 1062 | my $err_line = "PROG: $switch\n$prog\n" . |
| 1063 | "EXPECTED:\n$expected\n"; |
| 1064 | $err_line .= "EXIT STATUS: != 0\n" if $fatal; |
| 1065 | $err_line .= "GOT:\n$results\n"; |
| 1066 | $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; |
| 1067 | if ($::TODO) { |
| 1068 | $err_line =~ s/^/# /mg; |
| 1069 | print $err_line; # Harness can't filter it out from STDERR. |
| 1070 | } |
| 1071 | else { |
| 1072 | print STDERR $err_line; |
| 1073 | } |
| 1074 | } |
| 1075 | |
| 1076 | ok($ok, $name); |
| 1077 | |
| 1078 | foreach (@temps) { |
| 1079 | unlink $_ if $_; |
| 1080 | } |
| 1081 | foreach (@temp_path) { |
| 1082 | File::Path::rmtree $_ if -d $_; |
| 1083 | } |
| 1084 | } |
| 1085 | } |
| 1086 | |
| 1087 | sub can_ok ($@) { |
| 1088 | my($proto, @methods) = @_; |
| 1089 | my $class = ref $proto || $proto; |
| 1090 | |
| 1091 | unless( @methods ) { |
| 1092 | return _ok( 0, _where(), "$class->can(...)" ); |
| 1093 | } |
| 1094 | |
| 1095 | my @nok = (); |
| 1096 | foreach my $method (@methods) { |
| 1097 | local($!, $@); # don't interfere with caller's $@ |
| 1098 | # eval sometimes resets $! |
| 1099 | eval { $proto->can($method) } || push @nok, $method; |
| 1100 | } |
| 1101 | |
| 1102 | my $name; |
| 1103 | $name = @methods == 1 ? "$class->can('$methods[0]')" |
| 1104 | : "$class->can(...)"; |
| 1105 | |
| 1106 | _ok( !@nok, _where(), $name ); |
| 1107 | } |
| 1108 | |
| 1109 | |
| 1110 | # Call $class->new( @$args ); and run the result through object_ok. |
| 1111 | # See Test::More::new_ok |
| 1112 | sub new_ok { |
| 1113 | my($class, $args, $obj_name) = @_; |
| 1114 | $args ||= []; |
| 1115 | $object_name = "The object" unless defined $obj_name; |
| 1116 | |
| 1117 | local $Level = $Level + 1; |
| 1118 | |
| 1119 | my $obj; |
| 1120 | my $ok = eval { $obj = $class->new(@$args); 1 }; |
| 1121 | my $error = $@; |
| 1122 | |
| 1123 | if($ok) { |
| 1124 | object_ok($obj, $class, $object_name); |
| 1125 | } |
| 1126 | else { |
| 1127 | ok( 0, "new() died" ); |
| 1128 | diag("Error was: $@"); |
| 1129 | } |
| 1130 | |
| 1131 | return $obj; |
| 1132 | |
| 1133 | } |
| 1134 | |
| 1135 | |
| 1136 | sub isa_ok ($$;$) { |
| 1137 | my($object, $class, $obj_name) = @_; |
| 1138 | |
| 1139 | my $diag; |
| 1140 | $obj_name = 'The object' unless defined $obj_name; |
| 1141 | my $name = "$obj_name isa $class"; |
| 1142 | if( !defined $object ) { |
| 1143 | $diag = "$obj_name isn't defined"; |
| 1144 | } |
| 1145 | else { |
| 1146 | my $whatami = ref $object ? 'object' : 'class'; |
| 1147 | |
| 1148 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides |
| 1149 | local($@, $!); # eval sometimes resets $! |
| 1150 | my $rslt = eval { $object->isa($class) }; |
| 1151 | my $error = $@; # in case something else blows away $@ |
| 1152 | |
| 1153 | if( $error ) { |
| 1154 | if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { |
| 1155 | # It's an unblessed reference |
| 1156 | $obj_name = 'The reference' unless defined $obj_name; |
| 1157 | if( !UNIVERSAL::isa($object, $class) ) { |
| 1158 | my $ref = ref $object; |
| 1159 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
| 1160 | } |
| 1161 | } |
| 1162 | elsif( $error =~ /Can't call method "isa" without a package/ ) { |
| 1163 | # It's something that can't even be a class |
| 1164 | $obj_name = 'The thing' unless defined $obj_name; |
| 1165 | $diag = "$obj_name isn't a class or reference"; |
| 1166 | } |
| 1167 | else { |
| 1168 | die <<WHOA; |
| 1169 | WHOA! I tried to call ->isa on your object and got some weird error. |
| 1170 | This should never happen. Please contact the author immediately. |
| 1171 | Here's the error. |
| 1172 | $@ |
| 1173 | WHOA |
| 1174 | } |
| 1175 | } |
| 1176 | elsif( !$rslt ) { |
| 1177 | $obj_name = "The $whatami" unless defined $obj_name; |
| 1178 | my $ref = ref $object; |
| 1179 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
| 1180 | } |
| 1181 | } |
| 1182 | |
| 1183 | _ok( !$diag, _where(), $name ); |
| 1184 | } |
| 1185 | |
| 1186 | |
| 1187 | sub class_ok { |
| 1188 | my($class, $isa, $class_name) = @_; |
| 1189 | |
| 1190 | # Written so as to count as one test |
| 1191 | local $Level = $Level + 1; |
| 1192 | if( ref $class ) { |
| 1193 | ok( 0, "$class is a refrence, not a class name" ); |
| 1194 | } |
| 1195 | else { |
| 1196 | isa_ok($class, $isa, $class_name); |
| 1197 | } |
| 1198 | } |
| 1199 | |
| 1200 | |
| 1201 | sub object_ok { |
| 1202 | my($obj, $isa, $obj_name) = @_; |
| 1203 | |
| 1204 | local $Level = $Level + 1; |
| 1205 | if( !ref $obj ) { |
| 1206 | ok( 0, "$obj is not a reference" ); |
| 1207 | } |
| 1208 | else { |
| 1209 | isa_ok($obj, $isa, $obj_name); |
| 1210 | } |
| 1211 | } |
| 1212 | |
| 1213 | |
| 1214 | # Purposefully avoiding a closure. |
| 1215 | sub __capture { |
| 1216 | push @::__capture, join "", @_; |
| 1217 | } |
| 1218 | |
| 1219 | sub capture_warnings { |
| 1220 | my $code = shift; |
| 1221 | |
| 1222 | local @::__capture; |
| 1223 | local $SIG {__WARN__} = \&__capture; |
| 1224 | &$code; |
| 1225 | return @::__capture; |
| 1226 | } |
| 1227 | |
| 1228 | # This will generate a variable number of tests. |
| 1229 | # Use done_testing() instead of a fixed plan. |
| 1230 | sub warnings_like { |
| 1231 | my ($code, $expect, $name) = @_; |
| 1232 | local $Level = $Level + 1; |
| 1233 | |
| 1234 | my @w = capture_warnings($code); |
| 1235 | |
| 1236 | cmp_ok(scalar @w, '==', scalar @$expect, $name); |
| 1237 | foreach my $e (@$expect) { |
| 1238 | if (ref $e) { |
| 1239 | like(shift @w, $e, $name); |
| 1240 | } else { |
| 1241 | is(shift @w, $e, $name); |
| 1242 | } |
| 1243 | } |
| 1244 | if (@w) { |
| 1245 | diag("Saw these additional warnings:"); |
| 1246 | diag($_) foreach @w; |
| 1247 | } |
| 1248 | } |
| 1249 | |
| 1250 | sub _fail_excess_warnings { |
| 1251 | my($expect, $got, $name) = @_; |
| 1252 | local $Level = $Level + 1; |
| 1253 | # This will fail, and produce diagnostics |
| 1254 | is($expect, scalar @$got, $name); |
| 1255 | diag("Saw these warnings:"); |
| 1256 | diag($_) foreach @$got; |
| 1257 | } |
| 1258 | |
| 1259 | sub warning_is { |
| 1260 | my ($code, $expect, $name) = @_; |
| 1261 | die sprintf "Expect must be a string or undef, not a %s reference", ref $expect |
| 1262 | if ref $expect; |
| 1263 | local $Level = $Level + 1; |
| 1264 | my @w = capture_warnings($code); |
| 1265 | if (@w > 1) { |
| 1266 | _fail_excess_warnings(0 + defined $expect, \@w, $name); |
| 1267 | } else { |
| 1268 | is($w[0], $expect, $name); |
| 1269 | } |
| 1270 | } |
| 1271 | |
| 1272 | sub warning_like { |
| 1273 | my ($code, $expect, $name) = @_; |
| 1274 | die sprintf "Expect must be a regexp object" |
| 1275 | unless ref $expect eq 'Regexp'; |
| 1276 | local $Level = $Level + 1; |
| 1277 | my @w = capture_warnings($code); |
| 1278 | if (@w > 1) { |
| 1279 | _fail_excess_warnings(0 + defined $expect, \@w, $name); |
| 1280 | } else { |
| 1281 | like($w[0], $expect, $name); |
| 1282 | } |
| 1283 | } |
| 1284 | |
| 1285 | # Set a watchdog to timeout the entire test file |
| 1286 | # NOTE: If the test file uses 'threads', then call the watchdog() function |
| 1287 | # _AFTER_ the 'threads' module is loaded. |
| 1288 | sub watchdog ($;$) |
| 1289 | { |
| 1290 | my $timeout = shift; |
| 1291 | my $method = shift || ""; |
| 1292 | my $timeout_msg = 'Test process timed out - terminating'; |
| 1293 | |
| 1294 | # Valgrind slows perl way down so give it more time before dying. |
| 1295 | $timeout *= 10 if $ENV{PERL_VALGRIND}; |
| 1296 | |
| 1297 | my $pid_to_kill = $$; # PID for this process |
| 1298 | |
| 1299 | if ($method eq "alarm") { |
| 1300 | goto WATCHDOG_VIA_ALARM; |
| 1301 | } |
| 1302 | |
| 1303 | # shut up use only once warning |
| 1304 | my $threads_on = $threads::threads && $threads::threads; |
| 1305 | |
| 1306 | # Don't use a watchdog process if 'threads' is loaded - |
| 1307 | # use a watchdog thread instead |
| 1308 | if (!$threads_on || $method eq "process") { |
| 1309 | |
| 1310 | # On Windows and VMS, try launching a watchdog process |
| 1311 | # using system(1, ...) (see perlport.pod) |
| 1312 | if ($is_mswin || $is_vms) { |
| 1313 | # On Windows, try to get the 'real' PID |
| 1314 | if ($is_mswin) { |
| 1315 | eval { require Win32; }; |
| 1316 | if (defined(&Win32::GetCurrentProcessId)) { |
| 1317 | $pid_to_kill = Win32::GetCurrentProcessId(); |
| 1318 | } |
| 1319 | } |
| 1320 | |
| 1321 | # If we still have a fake PID, we can't use this method at all |
| 1322 | return if ($pid_to_kill <= 0); |
| 1323 | |
| 1324 | # Launch watchdog process |
| 1325 | my $watchdog; |
| 1326 | eval { |
| 1327 | local $SIG{'__WARN__'} = sub { |
| 1328 | _diag("Watchdog warning: $_[0]"); |
| 1329 | }; |
| 1330 | my $sig = $is_vms ? 'TERM' : 'KILL'; |
| 1331 | my $cmd = _create_runperl( prog => "sleep($timeout);" . |
| 1332 | "warn qq/# $timeout_msg" . '\n/;' . |
| 1333 | "kill($sig, $pid_to_kill);"); |
| 1334 | $watchdog = system(1, $cmd); |
| 1335 | }; |
| 1336 | if ($@ || ($watchdog <= 0)) { |
| 1337 | _diag('Failed to start watchdog'); |
| 1338 | _diag($@) if $@; |
| 1339 | undef($watchdog); |
| 1340 | return; |
| 1341 | } |
| 1342 | |
| 1343 | # Add END block to parent to terminate and |
| 1344 | # clean up watchdog process |
| 1345 | eval "END { local \$! = 0; local \$? = 0; |
| 1346 | wait() if kill('KILL', $watchdog); };"; |
| 1347 | return; |
| 1348 | } |
| 1349 | |
| 1350 | # Try using fork() to generate a watchdog process |
| 1351 | my $watchdog; |
| 1352 | eval { $watchdog = fork() }; |
| 1353 | if (defined($watchdog)) { |
| 1354 | if ($watchdog) { # Parent process |
| 1355 | # Add END block to parent to terminate and |
| 1356 | # clean up watchdog process |
| 1357 | eval "END { local \$! = 0; local \$? = 0; |
| 1358 | wait() if kill('KILL', $watchdog); };"; |
| 1359 | return; |
| 1360 | } |
| 1361 | |
| 1362 | ### Watchdog process code |
| 1363 | |
| 1364 | # Load POSIX if available |
| 1365 | eval { require POSIX; }; |
| 1366 | |
| 1367 | # Execute the timeout |
| 1368 | sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 |
| 1369 | sleep(2); |
| 1370 | |
| 1371 | # Kill test process if still running |
| 1372 | if (kill(0, $pid_to_kill)) { |
| 1373 | _diag($timeout_msg); |
| 1374 | kill('KILL', $pid_to_kill); |
| 1375 | if ($is_cygwin) { |
| 1376 | # sometimes the above isn't enough on cygwin |
| 1377 | sleep 1; # wait a little, it might have worked after all |
| 1378 | system("/bin/kill -f $pid_to_kill"); |
| 1379 | } |
| 1380 | } |
| 1381 | |
| 1382 | # Don't execute END block (added at beginning of this file) |
| 1383 | $NO_ENDING = 1; |
| 1384 | |
| 1385 | # Terminate ourself (i.e., the watchdog) |
| 1386 | POSIX::_exit(1) if (defined(&POSIX::_exit)); |
| 1387 | exit(1); |
| 1388 | } |
| 1389 | |
| 1390 | # fork() failed - fall through and try using a thread |
| 1391 | } |
| 1392 | |
| 1393 | # Use a watchdog thread because either 'threads' is loaded, |
| 1394 | # or fork() failed |
| 1395 | if (eval {require threads; 1}) { |
| 1396 | 'threads'->create(sub { |
| 1397 | # Load POSIX if available |
| 1398 | eval { require POSIX; }; |
| 1399 | |
| 1400 | # Execute the timeout |
| 1401 | my $time_left = $timeout; |
| 1402 | do { |
| 1403 | $time_left = $time_left - sleep($time_left); |
| 1404 | } while ($time_left > 0); |
| 1405 | |
| 1406 | # Kill the parent (and ourself) |
| 1407 | select(STDERR); $| = 1; |
| 1408 | _diag($timeout_msg); |
| 1409 | POSIX::_exit(1) if (defined(&POSIX::_exit)); |
| 1410 | my $sig = $is_vms ? 'TERM' : 'KILL'; |
| 1411 | kill($sig, $pid_to_kill); |
| 1412 | })->detach(); |
| 1413 | return; |
| 1414 | } |
| 1415 | |
| 1416 | # If everything above fails, then just use an alarm timeout |
| 1417 | WATCHDOG_VIA_ALARM: |
| 1418 | if (eval { alarm($timeout); 1; }) { |
| 1419 | # Load POSIX if available |
| 1420 | eval { require POSIX; }; |
| 1421 | |
| 1422 | # Alarm handler will do the actual 'killing' |
| 1423 | $SIG{'ALRM'} = sub { |
| 1424 | select(STDERR); $| = 1; |
| 1425 | _diag($timeout_msg); |
| 1426 | POSIX::_exit(1) if (defined(&POSIX::_exit)); |
| 1427 | my $sig = $is_vms ? 'TERM' : 'KILL'; |
| 1428 | kill($sig, $pid_to_kill); |
| 1429 | }; |
| 1430 | } |
| 1431 | } |
| 1432 | |
| 1433 | my $cp_0037 = # EBCDIC code page 0037 |
| 1434 | '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x25\x0B\x0C\x0D\x0E\x0F' . |
| 1435 | '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . |
| 1436 | '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . |
| 1437 | '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . |
| 1438 | '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . |
| 1439 | '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBA\xE0\xBB\xB0\x6D' . |
| 1440 | '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . |
| 1441 | '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' . |
| 1442 | '\x20\x21\x22\x23\x24\x15\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . |
| 1443 | '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' . |
| 1444 | '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBD\xB4\x9A\x8A\x5F\xCA\xAF\xBC' . |
| 1445 | '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . |
| 1446 | '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . |
| 1447 | '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xAD\xAE\x59' . |
| 1448 | '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . |
| 1449 | '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; |
| 1450 | |
| 1451 | my $cp_1047 = # EBCDIC code page 1047 |
| 1452 | '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' . |
| 1453 | '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . |
| 1454 | '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . |
| 1455 | '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . |
| 1456 | '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . |
| 1457 | '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xAD\xE0\xBD\x5F\x6D' . |
| 1458 | '\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . |
| 1459 | '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xC0\x4F\xD0\xA1\x07' . |
| 1460 | '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . |
| 1461 | '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\xFF' . |
| 1462 | '\x41\xAA\x4A\xB1\x9F\xB2\x6A\xB5\xBB\xB4\x9A\x8A\xB0\xCA\xAF\xBC' . |
| 1463 | '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . |
| 1464 | '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . |
| 1465 | '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xFD\xFE\xFB\xFC\xBA\xAE\x59' . |
| 1466 | '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . |
| 1467 | '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xDD\xDE\xDB\xDC\x8D\x8E\xDF'; |
| 1468 | |
| 1469 | my $cp_bc = # EBCDIC code page POSiX-BC |
| 1470 | '\x00\x01\x02\x03\x37\x2D\x2E\x2F\x16\x05\x15\x0B\x0C\x0D\x0E\x0F' . |
| 1471 | '\x10\x11\x12\x13\x3C\x3D\x32\x26\x18\x19\x3F\x27\x1C\x1D\x1E\x1F' . |
| 1472 | '\x40\x5A\x7F\x7B\x5B\x6C\x50\x7D\x4D\x5D\x5C\x4E\x6B\x60\x4B\x61' . |
| 1473 | '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\x7A\x5E\x4C\x7E\x6E\x6F' . |
| 1474 | '\x7C\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xD1\xD2\xD3\xD4\xD5\xD6' . |
| 1475 | '\xD7\xD8\xD9\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xBB\xBC\xBD\x6A\x6D' . |
| 1476 | '\x4A\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96' . |
| 1477 | '\x97\x98\x99\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xFB\x4F\xFD\xFF\x07' . |
| 1478 | '\x20\x21\x22\x23\x24\x25\x06\x17\x28\x29\x2A\x2B\x2C\x09\x0A\x1B' . |
| 1479 | '\x30\x31\x1A\x33\x34\x35\x36\x08\x38\x39\x3A\x3B\x04\x14\x3E\x5F' . |
| 1480 | '\x41\xAA\xB0\xB1\x9F\xB2\xD0\xB5\x79\xB4\x9A\x8A\xBA\xCA\xAF\xA1' . |
| 1481 | '\x90\x8F\xEA\xFA\xBE\xA0\xB6\xB3\x9D\xDA\x9B\x8B\xB7\xB8\xB9\xAB' . |
| 1482 | '\x64\x65\x62\x66\x63\x67\x9E\x68\x74\x71\x72\x73\x78\x75\x76\x77' . |
| 1483 | '\xAC\x69\xED\xEE\xEB\xEF\xEC\xBF\x80\xE0\xFE\xDD\xFC\xAD\xAE\x59' . |
| 1484 | '\x44\x45\x42\x46\x43\x47\x9C\x48\x54\x51\x52\x53\x58\x55\x56\x57' . |
| 1485 | '\x8C\x49\xCD\xCE\xCB\xCF\xCC\xE1\x70\xC0\xDE\xDB\xDC\x8D\x8E\xDF'; |
| 1486 | |
| 1487 | my $straight = # Avoid ranges |
| 1488 | '\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0A\x0B\x0C\x0D\x0E\x0F' . |
| 1489 | '\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1A\x1B\x1C\x1D\x1E\x1F' . |
| 1490 | '\x20\x21\x22\x23\x24\x25\x26\x27\x28\x29\x2A\x2B\x2C\x2D\x2E\x2F' . |
| 1491 | '\x30\x31\x32\x33\x34\x35\x36\x37\x38\x39\x3A\x3B\x3C\x3D\x3E\x3F' . |
| 1492 | '\x40\x41\x42\x43\x44\x45\x46\x47\x48\x49\x4A\x4B\x4C\x4D\x4E\x4F' . |
| 1493 | '\x50\x51\x52\x53\x54\x55\x56\x57\x58\x59\x5A\x5B\x5C\x5D\x5E\x5F' . |
| 1494 | '\x60\x61\x62\x63\x64\x65\x66\x67\x68\x69\x6A\x6B\x6C\x6D\x6E\x6F' . |
| 1495 | '\x70\x71\x72\x73\x74\x75\x76\x77\x78\x79\x7A\x7B\x7C\x7D\x7E\x7F' . |
| 1496 | '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F' . |
| 1497 | '\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F' . |
| 1498 | '\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF' . |
| 1499 | '\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF' . |
| 1500 | '\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF' . |
| 1501 | '\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF' . |
| 1502 | '\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF' . |
| 1503 | '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF'; |
| 1504 | |
| 1505 | # The following 2 functions allow tests to work on both EBCDIC and |
| 1506 | # ASCII-ish platforms. They convert string scalars between the native |
| 1507 | # character set and the set of 256 characters which is usually called |
| 1508 | # Latin1. |
| 1509 | # |
| 1510 | # These routines don't work on UTF-EBCDIC and UTF-8. |
| 1511 | |
| 1512 | sub native_to_latin1($) { |
| 1513 | my $string = shift; |
| 1514 | |
| 1515 | return $string if ord('^') == 94; # ASCII, Latin1 |
| 1516 | my $cp; |
| 1517 | if (ord('^') == 95) { # EBCDIC 1047 |
| 1518 | $cp = \$cp_1047; |
| 1519 | } |
| 1520 | elsif (ord('^') == 106) { # EBCDIC POSIX-BC |
| 1521 | $cp = \$cp_bc; |
| 1522 | } |
| 1523 | elsif (ord('^') == 176) { # EBCDIC 037 */ |
| 1524 | $cp = \$cp_0037; |
| 1525 | } |
| 1526 | else { |
| 1527 | die "Unknown native character set"; |
| 1528 | } |
| 1529 | |
| 1530 | eval '$string =~ tr/' . $$cp . '/' . $straight . '/'; |
| 1531 | return $string; |
| 1532 | } |
| 1533 | |
| 1534 | sub latin1_to_native($) { |
| 1535 | my $string = shift; |
| 1536 | |
| 1537 | return $string if ord('^') == 94; # ASCII, Latin1 |
| 1538 | my $cp; |
| 1539 | if (ord('^') == 95) { # EBCDIC 1047 |
| 1540 | $cp = \$cp_1047; |
| 1541 | } |
| 1542 | elsif (ord('^') == 106) { # EBCDIC POSIX-BC |
| 1543 | $cp = \$cp_bc; |
| 1544 | } |
| 1545 | elsif (ord('^') == 176) { # EBCDIC 037 */ |
| 1546 | $cp = \$cp_0037; |
| 1547 | } |
| 1548 | else { |
| 1549 | die "Unknown native character set"; |
| 1550 | } |
| 1551 | |
| 1552 | eval '$string =~ tr/' . $straight . '/' . $$cp . '/'; |
| 1553 | return $string; |
| 1554 | } |
| 1555 | |
| 1556 | sub ord_latin1_to_native { |
| 1557 | # given an input code point, return the platform's native |
| 1558 | # equivalent value. Anything above latin1 is itself. |
| 1559 | |
| 1560 | my $ord = shift; |
| 1561 | return $ord if $ord > 255; |
| 1562 | return ord latin1_to_native(chr $ord); |
| 1563 | } |
| 1564 | |
| 1565 | sub ord_native_to_latin1 { |
| 1566 | # given an input platform code point, return the latin1 equivalent value. |
| 1567 | # Anything above latin1 is itself. |
| 1568 | |
| 1569 | my $ord = shift; |
| 1570 | return $ord if $ord > 255; |
| 1571 | return ord native_to_latin1(chr $ord); |
| 1572 | } |
| 1573 | |
| 1574 | 1; |