xref: /openbsd/gnu/usr.bin/perl/t/op/warn.t (revision 09467b48) 
1#!./perl
2#line 3 warn.t
3
4BEGIN {
5    chdir 't' if -d 't';
6    require './test.pl'; require './charset_tools.pl';
7    set_up_inc('../lib');
8}
9
10plan 33;
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);
124   $ee = uni_to_native("\xee");
125   $bytes = byte_utf8a_to_utf8n("\xc3\xae");
126fresh_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");
140fresh_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
147fresh_perl_like(
148 'warn []',
149  qr/^ARRAY\(0x[\da-f]+\) at /a,
150  { },
151 'warn stringifies in the absence of $SIG{__WARN__}'
152);
153
154use Tie::Scalar;
155tie $@, "Tie::StdScalar";
156
157$@ = "foo\n";
158@warnings = ();
159warn;
160is @warnings, 1;
161like $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}
170warn;
171is @warnings, 1;
172is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used';
173
174untie $@;
175
176@warnings = ();
177{
178  package o;
179  use overload '""' => sub { "" };
180}
181tie $t, Tie::StdScalar;
182$t = bless [], o;
183{
184  local *{ref(tied $t) . "::STORE"} = sub {};
185  undef $t;
186}
187warn $t;
188is @warnings, 1;
189object_ok $warnings[0], 'o',
190  'warn $tie_returning_object_that_stringifes_emptily';
191
192@warnings = ();
193eval "#line 42 Cholmondeley\n \$\@ = '3'; warn";
194eval "#line 42 Cholmondeley\n \$\@ = 3; warn";
195is @warnings, 2;
196is $warnings[1], $warnings[0], 'warn treats $@=3 and $@="3" the same way';
197
198fresh_perl_is(<<'EOF', "should be line 4 at - line 4.\n", {stderr => 1}, "");
199${
200    foo
201} = "should be line 4";
202warn $foo;
203EOF
204
205TODO: {
206    local $::TODO = "Line numbers don't yet match up for \${ EXPR }";
207    my $expected = <<'EOF';
208line 1 at - line 1.
209line 4 at - line 3.
210also line 4 at - line 4.
211line 5 at - line 5.
212EOF
213    fresh_perl_is(<<'EOF', $expected, {stderr => 1}, "");
214warn "line 1";
215(${
216    foo
217} = "line 5") && warn("line 4"); warn("also line 4");
218warn $foo;
219EOF
220}
221
2221;
223# RT #132602 pp_warn in scalar context was extending the stack then
224# setting SP back to the old, freed stack frame
225
226fresh_perl_is(<<'EOF', "OK\n", {stderr => 1}, "RT #132602");
227$SIG{__WARN__} = sub {};
228
229my (@a, @b);
230for my $i (1..300) {
231    push @a, $i;
232    () = (@a, warn);
233}
234
235# mess with the stack some more for ASan's benefit
236for my $i (1..100) {
237    push @a, $i;
238    @b = @a;
239}
240print "OK\n";
241EOF
242