Perl_op_sibling_splice(0 remove dead code
[perl.git] / t / op / warn.t
1 #!./perl
2 #line 3 warn.t
3
4 BEGIN {
5     chdir 't' if -d 't';
6     require './test.pl'; require './charset_tools.pl';
7     set_up_inc('../lib');
8 }
9
10 plan 33;
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    $ee = uni_to_native("\xee");
125    $bytes = byte_utf8a_to_utf8n("\xc3\xae");
126 fresh_perl_like(
127  "
128    \$a = \"$ee\n\";
129    print STDERR \$a; warn \$a;
130    utf8::upgrade(\$a);
131    print STDERR \$a; warn \$a;
132  ",
133   qr/^$bytes(?:\r?\n$bytes){3}/,
134   { switches => ['-CE'] },
135  'warn respects :utf8 layer'
136 );
137 }
138
139 $bytes = byte_utf8a_to_utf8n("\xc4\xac");
140 fresh_perl_like(
141  'warn chr 300',
142   qr/^Wide character in warn .*\n$bytes at /,
143   { switches => [ "-C0" ] },
144  'Wide character in warn (not print)'
145 );
146
147 fresh_perl_like(
148  'warn []',
149   qr/^ARRAY\(0x[\da-f]+\) at /a,
150   { },
151  'warn stringifies in the absence of $SIG{__WARN__}'
152 );
153
154 use Tie::Scalar;
155 tie $@, "Tie::StdScalar";
156
157 $@ = "foo\n";
158 @warnings = ();
159 warn;
160 is @warnings, 1;
161 like $warnings[0], qr/^foo\n\t\.\.\.caught at warn\.t /,
162     '...caught is appended to tied $@';
163
164 $@ = \$_;
165 @warnings = ();
166 {
167   local *{ref(tied $@) . "::STORE"} = sub {};
168   undef $@;
169 }
170 warn;
171 is @warnings, 1;
172 is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used';
173
174 untie $@;
175
176 @warnings = ();
177 {
178   package o;
179   use overload '""' => sub { "" };
180 }
181 tie $t, Tie::StdScalar;
182 $t = bless [], o;
183 {
184   local *{ref(tied $t) . "::STORE"} = sub {};
185   undef $t;
186 }
187 warn $t;
188 is @warnings, 1;
189 object_ok $warnings[0], 'o',
190   'warn $tie_returning_object_that_stringifes_emptily';
191
192 @warnings = ();
193 eval "#line 42 Cholmondeley\n \$\@ = '3'; warn";
194 eval "#line 42 Cholmondeley\n \$\@ = 3; warn";
195 is @warnings, 2;
196 is $warnings[1], $warnings[0], 'warn treats $@=3 and $@="3" the same way';
197
198 fresh_perl_is(<<'EOF', "should be line 4 at - line 4.\n", {stderr => 1}, "");
199 ${
200     foo
201 } = "should be line 4";
202 warn $foo;
203 EOF
204
205 TODO: {
206     local $::TODO = "Line numbers don't yet match up for \${ EXPR }";
207     my $expected = <<'EOF';
208 line 1 at - line 1.
209 line 4 at - line 3.
210 also line 4 at - line 4.
211 line 5 at - line 5.
212 EOF
213     fresh_perl_is(<<'EOF', $expected, {stderr => 1}, "");
214 warn "line 1";
215 (${
216     foo
217 } = "line 5") && warn("line 4"); warn("also line 4");
218 warn $foo;
219 EOF
220 }
221
222 1;
223 # RT #132602 pp_warn in scalar context was extending the stack then
224 # setting SP back to the old, freed stack frame
225
226 fresh_perl_is(<<'EOF', "OK\n", {stderr => 1}, "RT #132602");
227 $SIG{__WARN__} = sub {};
228
229 my (@a, @b);
230 for my $i (1..300) {
231     push @a, $i;
232     () = (@a, warn);
233 }
234
235 # mess with the stack some more for ASan's benefit
236 for my $i (1..100) {
237     push @a, $i;
238     @b = @a;
239 }
240 print "OK\n";
241 EOF