1#!perl -w 2# HARNESS-NO-STREAM 3# HARNESS-NO-PRELOAD 4 5BEGIN { 6 if( $ENV{PERL_CORE} ) { 7 chdir 't'; 8 @INC = ('../lib', 'lib'); 9 } 10 else { 11 unshift @INC, 't/lib'; 12 } 13} 14 15use strict; 16 17require Test::Simple::Catch; 18my($out, $err) = Test::Simple::Catch::caught(); 19local $ENV{HARNESS_ACTIVE} = 0; 20 21 22# Can't use Test.pm, that's a 5.005 thing. 23package My::Test; 24 25# This has to be a require or else the END block below runs before 26# Test::Builder's own and the ending diagnostics don't come out right. 27require Test::Builder; 28my $TB = Test::Builder->create; 29$TB->plan(tests => 81); 30 31sub like ($$;$) { 32 $TB->like(@_); 33} 34 35sub is ($$;$) { 36 $TB->is_eq(@_); 37} 38 39sub main::out_ok ($$) { 40 $TB->is_eq( $out->read, shift ); 41 $TB->is_eq( $err->read, shift ); 42} 43 44sub main::out_warn_ok ($$$) { 45 $TB->is_eq( $out->read, shift ); 46 $TB->is_eq( $err->read, shift ); 47 my $warning_expected = shift; 48 $warning_expected =~ s/^# //mg; 49 $TB->is_eq( $main::warning, $warning_expected ); 50} 51 52sub main::out_like ($$) { 53 my($output, $failure) = @_; 54 55 $TB->like( $out->read, qr/$output/ ); 56 $TB->like( $err->read, qr/$failure/ ); 57} 58 59 60package main; 61 62require Test::More; 63our $TODO; 64my $Total = 38; 65Test::More->import(tests => $Total); 66$out->read; # clear the plan from $out 67 68# This should all work in the presence of a __DIE__ handler. 69local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); }; 70local $SIG{__WARN__} = sub { $main::warning = $_[0]; }; 71 72my $tb = Test::More->builder; 73$tb->use_numbers(0); 74 75my $Filename = quotemeta $0; 76 77 78#line 38 79ok( 0, 'failing' ); 80out_ok( <<OUT, <<ERR ); 81not ok - failing 82OUT 83# Failed test 'failing' 84# at $0 line 38. 85ERR 86 87 88#line 40 89is( "foo", "bar", 'foo is bar?'); 90out_ok( <<OUT, <<ERR ); 91not ok - foo is bar? 92OUT 93# Failed test 'foo is bar?' 94# at $0 line 40. 95# got: 'foo' 96# expected: 'bar' 97ERR 98 99#line 89 100is( undef, '', 'undef is empty string?'); 101out_ok( <<OUT, <<ERR ); 102not ok - undef is empty string? 103OUT 104# Failed test 'undef is empty string?' 105# at $0 line 89. 106# got: undef 107# expected: '' 108ERR 109 110#line 99 111is( undef, 0, 'undef is 0?'); 112out_ok( <<OUT, <<ERR ); 113not ok - undef is 0? 114OUT 115# Failed test 'undef is 0?' 116# at $0 line 99. 117# got: undef 118# expected: '0' 119ERR 120 121#line 110 122is( '', 0, 'empty string is 0?' ); 123out_ok( <<OUT, <<ERR ); 124not ok - empty string is 0? 125OUT 126# Failed test 'empty string is 0?' 127# at $0 line 110. 128# got: '' 129# expected: '0' 130ERR 131 132#line 121 133isnt("foo", "foo", 'foo isnt foo?' ); 134out_ok( <<OUT, <<ERR ); 135not ok - foo isnt foo? 136OUT 137# Failed test 'foo isnt foo?' 138# at $0 line 121. 139# got: 'foo' 140# expected: anything else 141ERR 142 143#line 132 144isn::t("foo", "foo",'foo isn\'t foo?' ); 145out_warn_ok( <<OUT, <<ERR, <<WARN ); 146not ok - foo isn't foo? 147OUT 148# Failed test 'foo isn\'t foo?' 149# at $0 line 132. 150# got: 'foo' 151# expected: anything else 152ERR 153# Use of apostrophe as package separator was deprecated in Perl 5.37.9, 154# and will be removed in Perl 5.42.0. You should change code that uses 155# Test::More::isn't() to use Test::More::isnt() as a replacement at t/Legacy/fail-more.t line 132 156WARN 157 158#line 143 159isnt(undef, undef, 'undef isnt undef?'); 160out_ok( <<OUT, <<ERR ); 161not ok - undef isnt undef? 162OUT 163# Failed test 'undef isnt undef?' 164# at $0 line 143. 165# got: undef 166# expected: anything else 167ERR 168 169#line 154 170like( "foo", '/that/', 'is foo like that' ); 171out_ok( <<OUT, <<ERR ); 172not ok - is foo like that 173OUT 174# Failed test 'is foo like that' 175# at $0 line 154. 176# 'foo' 177# doesn't match '/that/' 178ERR 179 180#line 165 181unlike( "foo", '/foo/', 'is foo unlike foo' ); 182out_ok( <<OUT, <<ERR ); 183not ok - is foo unlike foo 184OUT 185# Failed test 'is foo unlike foo' 186# at $0 line 165. 187# 'foo' 188# matches '/foo/' 189ERR 190 191# Nick Clark found this was a bug. Fixed in 0.40. 192# line 177 193like( "bug", '/(%)/', 'regex with % in it' ); 194out_ok( <<OUT, <<ERR ); 195not ok - regex with % in it 196OUT 197# Failed test 'regex with % in it' 198# at $0 line 177. 199# 'bug' 200# doesn't match '/(%)/' 201ERR 202 203#line 188 204fail('fail()'); 205out_ok( <<OUT, <<ERR ); 206not ok - fail() 207OUT 208# Failed test 'fail()' 209# at $0 line 188. 210ERR 211 212#line 197 213can_ok('Mooble::Hooble::Yooble', qw(this that)); 214out_ok( <<OUT, <<ERR ); 215not ok - Mooble::Hooble::Yooble->can(...) 216OUT 217# Failed test 'Mooble::Hooble::Yooble->can(...)' 218# at $0 line 197. 219# Mooble::Hooble::Yooble->can('this') failed 220# Mooble::Hooble::Yooble->can('that') failed 221ERR 222 223#line 208 224can_ok('Mooble::Hooble::Yooble', ()); 225out_ok( <<OUT, <<ERR ); 226not ok - Mooble::Hooble::Yooble->can(...) 227OUT 228# Failed test 'Mooble::Hooble::Yooble->can(...)' 229# at $0 line 208. 230# can_ok() called with no methods 231ERR 232 233#line 218 234can_ok(undef, undef); 235out_ok( <<OUT, <<ERR ); 236not ok - ->can(...) 237OUT 238# Failed test '->can(...)' 239# at $0 line 218. 240# can_ok() called with empty class or reference 241ERR 242 243#line 228 244can_ok([], "foo"); 245out_ok( <<OUT, <<ERR ); 246not ok - ARRAY->can('foo') 247OUT 248# Failed test 'ARRAY->can('foo')' 249# at $0 line 228. 250# ARRAY->can('foo') failed 251ERR 252 253#line 238 254isa_ok(bless([], "Foo"), "Wibble"); 255out_ok( <<OUT, <<ERR ); 256not ok - An object of class 'Foo' isa 'Wibble' 257OUT 258# Failed test 'An object of class 'Foo' isa 'Wibble'' 259# at $0 line 238. 260# The object of class 'Foo' isn't a 'Wibble' 261ERR 262 263#line 248 264isa_ok(42, "Wibble", "My Wibble"); 265out_ok( <<OUT, <<ERR ); 266not ok - 'My Wibble' isa 'Wibble' 267OUT 268# Failed test ''My Wibble' isa 'Wibble'' 269# at $0 line 248. 270# 'My Wibble' isn't a 'Wibble' 271ERR 272 273#line 252 274isa_ok(42, "Wibble"); 275out_ok( <<OUT, <<ERR ); 276not ok - The class (or class-like) '42' isa 'Wibble' 277OUT 278# Failed test 'The class (or class-like) '42' isa 'Wibble'' 279# at $0 line 252. 280# The class (or class-like) '42' isn't a 'Wibble' 281ERR 282 283#line 258 284isa_ok(undef, "Wibble", "Another Wibble"); 285out_ok( <<OUT, <<ERR ); 286not ok - 'Another Wibble' isa 'Wibble' 287OUT 288# Failed test ''Another Wibble' isa 'Wibble'' 289# at $0 line 258. 290# 'Another Wibble' isn't defined 291ERR 292 293#line 268 294isa_ok([], "HASH"); 295out_ok( <<OUT, <<ERR ); 296not ok - A reference of type 'ARRAY' isa 'HASH' 297OUT 298# Failed test 'A reference of type 'ARRAY' isa 'HASH'' 299# at $0 line 268. 300# The reference of type 'ARRAY' isn't a 'HASH' 301ERR 302 303#line 278 304new_ok(undef); 305out_like( <<OUT, <<ERR ); 306not ok - undef->new\\(\\) died 307OUT 308# Failed test 'undef->new\\(\\) died' 309# at $Filename line 278. 310# Error was: Can't call method "new" on an undefined value at .* 311ERR 312 313#line 288 314new_ok( "Does::Not::Exist" ); 315out_like( <<OUT, <<ERR ); 316not ok - Does::Not::Exist->new\\(\\) died 317OUT 318# Failed test 'Does::Not::Exist->new\\(\\) died' 319# at $Filename line 288. 320# Error was: Can't locate object method "new" via package "Does::Not::Exist" .* 321ERR 322 323 324{ package Foo; sub new { } } 325{ package Bar; sub new { {} } } 326{ package Baz; sub new { bless {}, "Wibble" } } 327 328#line 303 329new_ok( "Foo" ); 330out_ok( <<OUT, <<ERR ); 331not ok - undef isa 'Foo' 332OUT 333# Failed test 'undef isa 'Foo'' 334# at $0 line 303. 335# undef isn't defined 336ERR 337 338# line 313 339new_ok( "Bar" ); 340out_ok( <<OUT, <<ERR ); 341not ok - A reference of type 'HASH' isa 'Bar' 342OUT 343# Failed test 'A reference of type 'HASH' isa 'Bar'' 344# at $0 line 313. 345# The reference of type 'HASH' isn't a 'Bar' 346ERR 347 348#line 323 349new_ok( "Baz" ); 350out_ok( <<OUT, <<ERR ); 351not ok - An object of class 'Wibble' isa 'Baz' 352OUT 353# Failed test 'An object of class 'Wibble' isa 'Baz'' 354# at $0 line 323. 355# The object of class 'Wibble' isn't a 'Baz' 356ERR 357 358#line 333 359new_ok( "Baz", [], "no args" ); 360out_ok( <<OUT, <<ERR ); 361not ok - 'no args' isa 'Baz' 362OUT 363# Failed test ''no args' isa 'Baz'' 364# at $0 line 333. 365# 'no args' isn't a 'Baz' 366ERR 367 368#line 343 369cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' ); 370out_ok( <<OUT, <<ERR ); 371not ok - cmp_ok eq 372OUT 373# Failed test 'cmp_ok eq' 374# at $0 line 343. 375# got: 'foo' 376# expected: 'bar' 377ERR 378 379#line 354 380cmp_ok( 42.1, '==', 23, , ' ==' ); 381out_ok( <<OUT, <<ERR ); 382not ok - == 383OUT 384# Failed test ' ==' 385# at $0 line 354. 386# got: 42.1 387# expected: 23 388ERR 389 390#line 365 391cmp_ok( 42, '!=', 42 , ' !=' ); 392out_ok( <<OUT, <<ERR ); 393not ok - != 394OUT 395# Failed test ' !=' 396# at $0 line 365. 397# got: 42 398# expected: anything else 399ERR 400 401#line 376 402cmp_ok( 1, '&&', 0 , ' &&' ); 403out_ok( <<OUT, <<ERR ); 404not ok - && 405OUT 406# Failed test ' &&' 407# at $0 line 376. 408# '1' 409# && 410# '0' 411ERR 412 413# line 388 414cmp_ok( 42, 'eq', "foo", ' eq with numbers' ); 415out_ok( <<OUT, <<ERR ); 416not ok - eq with numbers 417OUT 418# Failed test ' eq with numbers' 419# at $0 line 388. 420# got: '42' 421# expected: 'foo' 422ERR 423 424{ 425 my $warnings = ''; 426 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 427 428# line 415 429 cmp_ok( 42, '==', "foo", ' == with strings' ); 430 out_ok( <<OUT, <<ERR ); 431not ok - == with strings 432OUT 433# Failed test ' == with strings' 434# at $0 line 415. 435# got: 42 436# expected: foo 437ERR 438 My::Test::like( 439 $warnings, 440 qr/^Argument "foo" isn't numeric in .* at \(eval in cmp_ok\) $Filename line 415\.\n$/ 441 ); 442 $warnings = ''; 443} 444 445 446{ 447 my $warnings = ''; 448 local $SIG{__WARN__} = sub { $warnings .= join '', @_ }; 449 450#line 437 451 cmp_ok( undef, "ne", "", "undef ne empty string" ); 452 453 $TB->is_eq( $out->read, <<OUT ); 454not ok - undef ne empty string 455OUT 456 457 $TB->is_eq( $err->read, <<ERR ); 458# Failed test 'undef ne empty string' 459# at $0 line 437. 460# undef 461# ne 462# '' 463ERR 464 465 My::Test::like( 466 $warnings, 467 qr/^Use of uninitialized value.* in string ne at \(eval in cmp_ok\) $Filename line 437.\n\z/ 468 ); 469} 470 471 472# generate a $!, it changes its value by context. 473-e "wibblehibble"; 474my $Errno_Number = $!+0; 475my $Errno_String = $!.''; 476#line 425 477cmp_ok( $!, 'eq', '', ' eq with stringified errno' ); 478out_ok( <<OUT, <<ERR ); 479not ok - eq with stringified errno 480OUT 481# Failed test ' eq with stringified errno' 482# at $0 line 425. 483# got: '$Errno_String' 484# expected: '' 485ERR 486 487#line 436 488cmp_ok( $!, '==', -1, ' eq with numerified errno' ); 489out_ok( <<OUT, <<ERR ); 490not ok - eq with numerified errno 491OUT 492# Failed test ' eq with numerified errno' 493# at $0 line 436. 494# got: $Errno_Number 495# expected: -1 496ERR 497 498#line 447 499use_ok('Hooble::mooble::yooble'); 500my $more_err_re = <<ERR; 501# Failed test 'use Hooble::mooble::yooble;' 502# at $Filename line 447\\. 503# Tried to use 'Hooble::mooble::yooble'. 504# Error: Can't locate Hooble.* in \\\@INC .* 505ERR 506out_like( 507 qr/^\Qnot ok - use Hooble::mooble::yooble;\E\n\z/, 508 qr/^$more_err_re/ 509); 510 511#line 460 512require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); 513$more_err_re = <<ERR; 514# Failed test 'require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;' 515# at $Filename line 460\\. 516# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'. 517# Error: Can't locate ALL.* in \\\@INC .* 518ERR 519out_like( 520 qr/^\Qnot ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;\E\n\z/, 521 qr/^$more_err_re/ 522); 523 524 525END { 526 out_like( <<OUT, <<ERR ); 527OUT 528# Looks like you failed $Total tests of $Total. 529ERR 530 531 exit(0); 532} 533