Commit | Line | Data |
---|---|---|
38b8243a GS |
1 | #!./perl |
2 | ||
bd6653b8 CK |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
7 | } | |
38b8243a | 8 | |
9aa00c80 NC |
9 | plan tests => 19; |
10 | ||
11 | eval { | |
12 | eval { | |
13 | die "Horribly\n"; | |
14 | }; | |
15 | die if $@; | |
16 | }; | |
17 | ||
aaa63dae AB |
18 | like($@, qr/^Horribly/, 'die with no args propagates $@'); |
19 | like($@, qr/\.{3}propagated at/, '... and appends a phrase'); | |
38b8243a | 20 | |
bd6653b8 CK |
21 | { |
22 | local $SIG{__DIE__} = sub { is( $_[0], "[\000]\n", 'Embedded null passed to signal handler' )}; | |
38b8243a | 23 | |
bd6653b8 CK |
24 | $err = "[\000]\n"; |
25 | eval { | |
26 | die $err; | |
27 | }; | |
28 | is( $@, $err, 'Embedded null passed back into $@' ); | |
29 | } | |
38b8243a | 30 | |
bd6653b8 | 31 | { |
9aa00c80 NC |
32 | local $SIG{__DIE__} = sub { |
33 | isa_ok( $_[0], 'ARRAY', 'pass an array ref as an argument' ); | |
34 | $_[0]->[0]++; | |
35 | }; | |
bd6653b8 CK |
36 | $x = [3]; |
37 | eval { die $x; }; | |
38 | ||
bd6653b8 | 39 | is( $x->[0], 4, 'actual array, not a copy, passed to signal handler' ); |
bd6653b8 | 40 | |
05423cc9 | 41 | eval { |
bd6653b8 CK |
42 | eval { |
43 | die [ 5 ]; | |
44 | }; | |
45 | die if $@; | |
05423cc9 | 46 | }; |
05423cc9 | 47 | |
bd6653b8 | 48 | is($@->[0], 7, 'die with no arguments propagates $@, but leaves references alone'); |
9aa00c80 NC |
49 | |
50 | eval { | |
51 | eval { | |
52 | die bless [ 7 ], "Error"; | |
53 | }; | |
54 | isa_ok( $@, 'Error', '$@ is an Error object' ); | |
55 | die if $@; | |
56 | }; | |
57 | ||
58 | isa_ok( $@, 'Out', 'returning a different object than what was passed in, via PROPAGATE' ); | |
59 | is($@->[0], 9, 'reference returned correctly'); | |
bd6653b8 | 60 | } |
05423cc9 | 61 | |
ff882698 AE |
62 | { |
63 | package Error; | |
05423cc9 | 64 | |
ff882698 | 65 | sub PROPAGATE { |
ff882698 AE |
66 | bless [$_[0]->[0]], "Out"; |
67 | } | |
68 | } | |
69 | ||
bd6653b8 | 70 | |
ff882698 AE |
71 | { |
72 | # die/warn and utf8 | |
73 | use utf8; | |
74 | local $SIG{__DIE__}; | |
75 | my $msg = "ce ºtii tu, bã ?\n"; | |
bd6653b8 CK |
76 | eval { die $msg }; |
77 | is( $@, $msg, "Literal passed to die" ); | |
ff882698 AE |
78 | our $err; |
79 | local $SIG{__WARN__} = $SIG{__DIE__} = sub { $err = shift }; | |
bd6653b8 CK |
80 | eval { die $msg }; |
81 | is( $err, $msg, 'die handler with utf8' ); | |
82 | eval { warn $msg }; | |
83 | is( $err, $msg, 'warn handler with utf8' ); | |
608b3986 | 84 | eval qq/ use strict; \$\x{3b1} /; |
bd6653b8 | 85 | like( $@, qr/Global symbol "\$\x{3b1}"/, 'utf8 symbol names show up in $@' ); |
05423cc9 | 86 | } |
dc8d642c DM |
87 | |
88 | # [perl #36470] got uninit warning if $@ was undef | |
89 | ||
90 | { | |
8b3945e7 | 91 | use warnings "uninitialized"; |
dc8d642c DM |
92 | my $ok = 1; |
93 | local $SIG{__DIE__}; | |
94 | local $SIG{__WARN__} = sub { $ok = 0 }; | |
95 | eval { undef $@; die }; | |
bd6653b8 | 96 | is( $ok, 1, 'no warnings if $@ is undef' ); |
dc8d642c | 97 | } |