1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9plan tests => 21; 10 11use utf8; # Tell EBCDIC translator to make this UTF-8, 12 13eval { 14 eval { 15 die "Horribly\n"; 16 }; 17 die if $@; 18}; 19 20like($@, qr/^Horribly/, 'die with no args propagates $@'); 21like($@, qr/\.{3}propagated at/, '... and appends a phrase'); 22 23{ 24 local $SIG{__DIE__} = sub { is( $_[0], "[\000]\n", 'Embedded null passed to signal handler' )}; 25 26 $err = "[\000]\n"; 27 eval { 28 die $err; 29 }; 30 is( $@, $err, 'Embedded null passed back into $@' ); 31} 32 33{ 34 local $SIG{__DIE__} = sub { 35 isa_ok( $_[0], 'ARRAY', 'pass an array ref as an argument' ); 36 $_[0]->[0]++; 37 }; 38 $x = [3]; 39 eval { die $x; }; 40 41 is( $x->[0], 4, 'actual array, not a copy, passed to signal handler' ); 42 43 eval { 44 eval { 45 die [ 5 ]; 46 }; 47 die if $@; 48 }; 49 50 is($@->[0], 7, 'die with no arguments propagates $@, but leaves references alone'); 51 52 eval { 53 eval { 54 die bless [ 7 ], "Error"; 55 }; 56 isa_ok( $@, 'Error', '$@ is an Error object' ); 57 die if $@; 58 }; 59 60 isa_ok( $@, 'Out', 'returning a different object than what was passed in, via PROPAGATE' ); 61 is($@->[0], 9, 'reference returned correctly'); 62} 63 64{ 65 package Error; 66 67 sub PROPAGATE { 68 bless [$_[0]->[0]], "Out"; 69 } 70} 71 72 73{ 74 # die/warn and utf8 75 use utf8; 76 local $SIG{__DIE__}; 77 my $msg = "ce ºtii tu, bã ?\n"; 78 eval { die $msg }; 79 is( $@, $msg, "Literal passed to die" ); 80 our $err; 81 local $SIG{__WARN__} = $SIG{__DIE__} = sub { $err = shift }; 82 eval { die $msg }; 83 is( $err, $msg, 'die handler with utf8' ); 84 eval { warn $msg }; 85 is( $err, $msg, 'warn handler with utf8' ); 86 eval qq/ use strict; \$\x{3b1} /; 87 like( $@, qr/Global symbol "\$\x{3b1}"/, 'utf8 symbol names show up in $@' ); 88} 89 90# [perl #36470] got uninit warning if $@ was undef 91 92{ 93 use warnings "uninitialized"; 94 my $ok = 1; 95 local $SIG{__DIE__}; 96 local $SIG{__WARN__} = sub { $ok = 0 }; 97 eval { undef $@; die }; 98 is( $ok, 1, 'no warnings if $@ is undef' ); 99 100 eval { $@ = 100; die }; 101 like($@."", qr/100\t\.{3}propagated at/, 102 'check non-PVs in $@ are propagated'); 103} 104 105TODO: { 106 local $TODO = 'RT #4821: die qr{x} does not check termination'; 107 my $out = runperl(prog => 'die qr{x}', stderr => 1); 108 like($out, qr/at -e line 1./, 'RT #4821: output from die qr{x}'); 109} 110 111