t/op/warn.t

   1 #!./perl
   2 #line 3 warn.t
   3
   4 BEGIN {
   5     chdir 't' if -d 't';
   6     @INC = '../lib';
   7     require './test.pl';
   8 }
   9
  10 plan 32;
  11
  12 my @warnings;
  13 my $wa = []; my $ea = [];
  14 $SIG{__WARN__} = sub { push @warnings, $_[0] };
  15
  16 @warnings = ();
  17 $@ = "";
  18 warn "foo\n";
  19 ok @warnings==1 && $warnings[0] eq "foo\n";
  20
  21 @warnings = ();
  22 $@ = "";
  23 warn "foo", "bar\n";
  24 ok @warnings==1 && $warnings[0] eq "foobar\n";
  25
  26 @warnings = ();
  27 $@ = "";
  28 warn "foo";
  29 ok @warnings==1 && $warnings[0] eq "foo at warn.t line 28.\n";
  30
  31 @warnings = ();
  32 $@ = "";
  33 warn $wa;
  34 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
  35
  36 @warnings = ();
  37 $@ = "";
  38 warn "";
  39 ok @warnings==1 &&
  40     $warnings[0] eq "Warning: something's wrong at warn.t line 38.\n";
  41
  42 @warnings = ();
  43 $@ = "";
  44 warn;
  45 ok @warnings==1 &&
  46     $warnings[0] eq "Warning: something's wrong at warn.t line 44.\n";
  47
  48 @warnings = ();
  49 $@ = "ERR\n";
  50 warn "foo\n";
  51 ok @warnings==1 && $warnings[0] eq "foo\n";
  52
  53 @warnings = ();
  54 $@ = "ERR\n";
  55 warn "foo", "bar\n";
  56 ok @warnings==1 && $warnings[0] eq "foobar\n";
  57
  58 @warnings = ();
  59 $@ = "ERR\n";
  60 warn "foo";
  61 ok @warnings==1 && $warnings[0] eq "foo at warn.t line 60.\n";
  62
  63 @warnings = ();
  64 $@ = "ERR\n";
  65 warn $wa;
  66 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
  67
  68 @warnings = ();
  69 $@ = "ERR\n";
  70 warn "";
  71 ok @warnings==1 &&
  72     $warnings[0] eq "ERR\n\t...caught at warn.t line 70.\n";
  73
  74 @warnings = ();
  75 $@ = "ERR\n";
  76 warn;
  77 ok @warnings==1 &&
  78     $warnings[0] eq "ERR\n\t...caught at warn.t line 76.\n";
  79
  80 @warnings = ();
  81 $@ = $ea;
  82 warn "foo\n";
  83 ok @warnings==1 && $warnings[0] eq "foo\n";
  84
  85 @warnings = ();
  86 $@ = $ea;
  87 warn "foo", "bar\n";
  88 ok @warnings==1 && $warnings[0] eq "foobar\n";
  89
  90 @warnings = ();
  91 $@ = $ea;
  92 warn "foo";
  93 ok @warnings==1 && $warnings[0] eq "foo at warn.t line 92.\n";
  94
  95 @warnings = ();
  96 $@ = $ea;
  97 warn $wa;
  98 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $wa;
  99
 100 @warnings = ();
 101 $@ = $ea;
 102 warn "";
 103 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
 104
 105 @warnings = ();
 106 $@ = $ea;
 107 warn;
 108 ok @warnings==1 && ref($warnings[0]) eq "ARRAY" && $warnings[0] == $ea;
 109
 110 fresh_perl_like(
 111  '
 112    $a = "\xee\n";
 113    print STDERR $a; warn $a;
 114    utf8::upgrade($a);
 115    print STDERR $a; warn $a;
 116  ',
 117   qr/^\xee(?:\r?\n\xee){3}/,
 118   { switches => [ "-C0" ] },
 119  'warn emits logical characters, not internal bytes [perl #45549]'
 120 );
 121
 122 SKIP: {
 123     skip_if_miniperl('miniperl ignores -C', 1);
 124 fresh_perl_like(
 125  '
 126    $a = "\xee\n";
 127    print STDERR $a; warn $a;
 128    utf8::upgrade($a);
 129    print STDERR $a; warn $a;
 130  ',
 131   qr/^\xc3\xae(?:\r?\n\xc3\xae){3}/,
 132   { switches => ['-CE'] },
 133  'warn respects :utf8 layer'
 134 );
 135 }
 136
 137 fresh_perl_like(
 138  'warn chr 300',
 139   qr/^Wide character in warn .*\n\xc4\xac at /,
 140   { switches => [ "-C0" ] },
 141  'Wide character in warn (not print)'
 142 );
 143
 144 fresh_perl_like(
 145  'warn []',
 146   qr/^ARRAY\(0x[\da-f]+\) at /a,
 147   { },
 148  'warn stringifies in the absence of $SIG{__WARN__}'
 149 );
 150
 151 use Tie::Scalar;
 152 tie $@, "Tie::StdScalar";
 153
 154 $@ = "foo\n";
 155 @warnings = ();
 156 warn;
 157 is @warnings, 1;
 158 like $warnings[0], qr/^foo\n\t\.\.\.caught at warn\.t /,
 159     '...caught is appended to tied $@';
 160
 161 $@ = \$_;
 162 @warnings = ();
 163 {
 164   local *{ref(tied $@) . "::STORE"} = sub {};
 165   undef $@;
 166 }
 167 warn;
 168 is @warnings, 1;
 169 is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used';
 170
 171 untie $@;
 172
 173 @warnings = ();
 174 {
 175   package o;
 176   use overload '""' => sub { "" };
 177 }
 178 tie $t, Tie::StdScalar;
 179 $t = bless [], o;
 180 {
 181   local *{ref(tied $t) . "::STORE"} = sub {};
 182   undef $t;
 183 }
 184 warn $t;
 185 is @warnings, 1;
 186 object_ok $warnings[0], 'o',
 187   'warn $tie_returning_object_that_stringifes_emptily';
 188
 189 @warnings = ();
 190 eval "#line 42 Cholmondeley\n \$\@ = '3'; warn";
 191 eval "#line 42 Cholmondeley\n \$\@ = 3; warn";
 192 is @warnings, 2;
 193 is $warnings[1], $warnings[0], 'warn treats $@=3 and $@="3" the same way';
 194
 195 fresh_perl_is(<<'EOF', "should be line 4 at - line 4.\n", {stderr => 1}, "");
 196 ${
 197     foo
 198 } = "should be line 4";
 199 warn $foo;
 200 EOF
 201
 202 TODO: {
 203     local $::TODO = "Line numbers don't yet match up for \${ EXPR }";
 204     my $expected = <<'EOF';
 205 line 1 at - line 1.
 206 line 4 at - line 3.
 207 also line 4 at - line 4.
 208 line 5 at - line 5.
 209 EOF
 210     fresh_perl_is(<<'EOF', $expected, {stderr => 1}, "");
 211 warn "line 1";
 212 (${
 213     foo
 214 } = "line 5") && warn("line 4"); warn("also line 4");
 215 warn $foo;
 216 EOF
 217 }
 218
 219 1;