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