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