This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[RT #128574] Missed one incorrect usage of fresh_perl_
[perl5.git] / t / op / reset.t
CommitLineData
2f3c5f77
NC
1#!./perl -w
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
7}
8use strict;
9
fcd13069 10plan tests => 40;
2f3c5f77
NC
11
12package aiieee;
13
14sub zlopp {
725a61d7 15 (shift =~ m?zlopp?) ? 1 : 0;
2f3c5f77
NC
16}
17
18sub reset_zlopp {
19 reset;
20}
21
22package CLINK;
23
24sub ZZIP {
725a61d7 25 shift =~ m?ZZIP? ? 1 : 0;
2f3c5f77
NC
26}
27
28sub reset_ZZIP {
29 reset;
30}
31
32package main;
33
34is(aiieee::zlopp(""), 0, "mismatch doesn't match");
35is(aiieee::zlopp("zlopp"), 1, "match matches first time");
36is(aiieee::zlopp(""), 0, "mismatch doesn't match");
37is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time");
38aiieee::reset_zlopp();
39is(aiieee::zlopp("zlopp"), 1, "match matches after reset");
40is(aiieee::zlopp(""), 0, "mismatch doesn't match");
41
42aiieee::reset_zlopp();
43
44is(aiieee::zlopp(""), 0, "mismatch doesn't match");
45is(aiieee::zlopp("zlopp"), 1, "match matches first time");
46is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
47is(CLINK::ZZIP("ZZIP"), 1, "match matches first time");
48is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
49is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match second time");
50is(aiieee::zlopp(""), 0, "mismatch doesn't match");
51is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time");
52
53aiieee::reset_zlopp();
54is(aiieee::zlopp("zlopp"), 1, "match matches after reset");
55is(aiieee::zlopp(""), 0, "mismatch doesn't match");
56
57is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
58is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match third time");
59
60CLINK::reset_ZZIP();
61is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset");
62is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
a1f22e0c 63
ca826051
FC
64sub match_foo{
65 "foo" =~ m?foo?;
66}
67match_foo();
68reset "";
69ok !match_foo(), 'reset "" leaves patterns alone [perl #97958]';
70
71$scratch::a = "foo";
72$scratch::a2 = "bar";
73$scratch::b = "baz";
74package scratch { reset "a" }
75is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u'),
76 "u-u-baz",
77 'reset "char"';
78
79$scratch::a = "foo";
80$scratch::a2 = "bar";
81$scratch::b = "baz";
82$scratch::c = "sea";
83package scratch { reset "bc" }
84is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
85 $scratch::c//'u'),
86 "foo-bar-u-u",
87 'reset "chars"';
88
89$scratch::a = "foo";
90$scratch::a2 = "bar";
91$scratch::b = "baz";
92$scratch::c = "sea";
93package scratch { reset "a-b" }
94is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
95 $scratch::c//'u'),
96 "u-u-u-sea",
97 'reset "range"';
98
99{ no strict; ${"scratch::\0foo"} = "bar" }
100$scratch::a = "foo";
101package scratch { reset "\0a" }
102is join("-", $scratch::a//'u', do { no strict; ${"scratch::\0foo"} }//'u'),
103 "u-u",
104 'reset "\0char"';
105
d6987b29
FC
106$scratch::cow = __PACKAGE__;
107$scratch::qr = ${qr//};
108$scratch::v = v6;
109$scratch::glob = *is;
110*scratch::ro = \1;
111package scratch { reset 'cqgvr' }
112is join ("-", map $_//'u', $scratch::cow, $scratch::qr, $scratch::v,
113 $scratch::glob,$scratch::ro), 'u-u-u-u-1',
114 'cow, qr, vstring, glob, ro test';
115
df70e763
FC
116@scratch::an_array = 1..3;
117%scratch::a_hash = 1..4;
118package scratch { reset 'a' }
119is @scratch::an_array, 0, 'resetting an array';
120is %scratch::a_hash, 0, 'resetting a hash';
121
c165afe3
FC
122@scratch::an_array = 1..3;
123%scratch::an_array = 1..4;
124*scratch::an_array = \1;
125package scratch { reset 'a' }
126is @scratch::an_array, 0, 'resetting array in the same gv as a ro scalar';
127is @scratch::an_array, 0, 'resetting a hash in the same gv as a ro scalar';
128is $scratch::an_array, 1, 'reset skips ro scalars in the same gv as av/hv';
129
61e9f3fe
FC
130for our $z (*_) {
131 {
132 local *_;
133 reset "z";
134 $z = 3;
135 () = *_{SCALAR};
136 no warnings;
137 () = "$_"; # used to crash
138 }
139 is ref\$z, "GLOB", 'reset leaves real-globs-as-scalars as GLOBs';
140 is $z, "*main::_", 'And the glob still has the right value';
141}
142
fcd13069
FC
143package _128106 {
144 # Crash on non-globs in the stash.
145 sub u; # stub without proto
146 sub v($); # proto stub
147 sub w{}; # as of 5.22, $::{w} == \&w
148 $::{x} = undef;
149 reset 'u-x';
150 ::ok (1, "no crash on non-globs in the stash");
151}
152
23083432
FC
153# This used to crash under threaded builds, because pmops were remembering
154# their stashes by name, rather than by pointer.
155fresh_perl_is( # it crashes more reliably with a smaller script
156 'package bar;
157 sub foo {
158 m??;
159 BEGIN { *baz:: = *bar::; *bar:: = *foo:: }
160 # The name "bar" no langer refers to the same package
161 }
f298f061 162 undef &foo; # so freeing the op does not remove it from the stash\'s list
23083432
FC
163 $_ = "";
164 push @_, ($_) x 10000; # and its memory is scribbled over
165 reset; # so reset on the original package tries to reset an invalid op
166 print "ok\n";',
167 "ok\n", {},
168 "no crash if package is effectively renamed before op is freed");
169
e39b51c6
FC
170sub _117941 { package _117941; reset }
171delete $::{"_117941::"};
172_117941();
173pass("no crash when current package is freed");
a1f22e0c
NC
174
175undef $/;
176my $prog = <DATA>;
177
178SKIP:
179{
180 eval {require threads; 1} or
181 skip "No threads", 4;
a1f22e0c
NC
182 foreach my $eight ('/', '?') {
183 foreach my $nine ('/', '?') {
184 my $copy = $prog;
185 $copy =~ s/8/$eight/gm;
186 $copy =~ s/9/$nine/gm;
ec6a838b 187 fresh_perl_is($copy, "pass", {},
a1f22e0c
NC
188 "first pattern $eight$eight, second $nine$nine");
189 }
190 }
191}
192
193__DATA__
194#!perl
195use warnings;
196use strict;
197
198# Note that there are no digits in this program, other than the placeholders
199sub a {
725a61d7 200m8one8;
a1f22e0c
NC
201}
202sub b {
725a61d7 203m9two9;
a1f22e0c
NC
204}
205
206use threads;
207use threads::shared;
208
209sub wipe {
ff8b4a37 210 eval 'no warnings; sub b {}; 1' or die $@;
a1f22e0c
NC
211}
212
213sub lock_then_wipe {
214 my $l_r = shift;
215 lock $$l_r;
216 cond_wait($$l_r) until $$l_r eq "B";
217 wipe;
218 $$l_r = "C";
219 cond_signal $$l_r;
220}
221
222my $lock : shared = "A";
223my $r = \$lock;
224
225my $t;
226{
227 lock $$r;
228 $t = threads->new(\&lock_then_wipe, $r);
229 wipe;
230 $lock = "B";
231 cond_signal $lock;
232}
233
234{
235 lock $lock;
236 cond_wait($lock) until $lock eq "C";
237 reset;
238}
239
240$t->join;
241print "pass\n";