t/op/die.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 plan tests => 26;
  10
  11 use utf8;   # Tell EBCDIC translator to make this UTF-8,
  12
  13 eval {
  14     eval {
  15         die "Horribly\n";
  16     };
  17     die if $@;
  18 };
  19
  20 like($@, qr/^Horribly/, 'die with no args propagates $@');
  21 like($@, 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 {
 105     my @error;
 106     local $SIG{__DIE__}= sub { push @error, @_ };
 107     use strict;
 108     my $ok= eval '$intentionally_missing+1';
 109     my $eval_error= $@;
 110     is($ok,undef,"eval should return undef");
 111     is(0+@error,1,"we should have captured 1 error via __DIE__");
 112     like( $error[0],
 113           qr/Global symbol \"\$intentionally_missing\"/,
 114           "The __DIE__ handler should have seen this message");
 115     like( $eval_error,
 116           qr/Global symbol \"\$intentionally_missing\"/,
 117           "The eval error in '\$@' should contain this message");
 118     is( $error[0], $eval_error,
 119         "__DIE__ handler and \$@ should be the same");
 120 }
 121
 122 TODO: {
 123     local $TODO = 'RT #4821: die qr{x} does not check termination';
 124     my $out = runperl(prog => 'die qr{x}', stderr => 1);
 125     like($out, qr/at -e line 1./, 'RT #4821: output from die qr{x}');
 126 }