Commit | Line | Data |
---|---|---|
2f3c5f77 NC |
1 | #!./perl -w |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | require './test.pl'; | |
7 | } | |
8 | use strict; | |
9 | ||
61e9f3fe | 10 | plan tests => 39; |
2f3c5f77 NC |
11 | |
12 | package aiieee; | |
13 | ||
14 | sub zlopp { | |
725a61d7 | 15 | (shift =~ m?zlopp?) ? 1 : 0; |
2f3c5f77 NC |
16 | } |
17 | ||
18 | sub reset_zlopp { | |
19 | reset; | |
20 | } | |
21 | ||
22 | package CLINK; | |
23 | ||
24 | sub ZZIP { | |
725a61d7 | 25 | shift =~ m?ZZIP? ? 1 : 0; |
2f3c5f77 NC |
26 | } |
27 | ||
28 | sub reset_ZZIP { | |
29 | reset; | |
30 | } | |
31 | ||
32 | package main; | |
33 | ||
34 | is(aiieee::zlopp(""), 0, "mismatch doesn't match"); | |
35 | is(aiieee::zlopp("zlopp"), 1, "match matches first time"); | |
36 | is(aiieee::zlopp(""), 0, "mismatch doesn't match"); | |
37 | is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time"); | |
38 | aiieee::reset_zlopp(); | |
39 | is(aiieee::zlopp("zlopp"), 1, "match matches after reset"); | |
40 | is(aiieee::zlopp(""), 0, "mismatch doesn't match"); | |
41 | ||
42 | aiieee::reset_zlopp(); | |
43 | ||
44 | is(aiieee::zlopp(""), 0, "mismatch doesn't match"); | |
45 | is(aiieee::zlopp("zlopp"), 1, "match matches first time"); | |
46 | is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); | |
47 | is(CLINK::ZZIP("ZZIP"), 1, "match matches first time"); | |
48 | is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); | |
49 | is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match second time"); | |
50 | is(aiieee::zlopp(""), 0, "mismatch doesn't match"); | |
51 | is(aiieee::zlopp("zlopp"), 0, "match doesn't match second time"); | |
52 | ||
53 | aiieee::reset_zlopp(); | |
54 | is(aiieee::zlopp("zlopp"), 1, "match matches after reset"); | |
55 | is(aiieee::zlopp(""), 0, "mismatch doesn't match"); | |
56 | ||
57 | is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); | |
58 | is(CLINK::ZZIP("ZZIP"), 0, "match doesn't match third time"); | |
59 | ||
60 | CLINK::reset_ZZIP(); | |
61 | is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset"); | |
62 | is(CLINK::ZZIP(""), 0, "mismatch doesn't match"); | |
a1f22e0c | 63 | |
ca826051 FC |
64 | sub match_foo{ |
65 | "foo" =~ m?foo?; | |
66 | } | |
67 | match_foo(); | |
68 | reset ""; | |
69 | ok !match_foo(), 'reset "" leaves patterns alone [perl #97958]'; | |
70 | ||
71 | $scratch::a = "foo"; | |
72 | $scratch::a2 = "bar"; | |
73 | $scratch::b = "baz"; | |
74 | package scratch { reset "a" } | |
75 | is 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"; | |
83 | package scratch { reset "bc" } | |
84 | is 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"; | |
93 | package scratch { reset "a-b" } | |
94 | is 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"; | |
101 | package scratch { reset "\0a" } | |
102 | is 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; | |
111 | package scratch { reset 'cqgvr' } | |
112 | is 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; | |
118 | package scratch { reset 'a' } | |
119 | is @scratch::an_array, 0, 'resetting an array'; | |
120 | is %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; | |
125 | package scratch { reset 'a' } | |
126 | is @scratch::an_array, 0, 'resetting array in the same gv as a ro scalar'; | |
127 | is @scratch::an_array, 0, 'resetting a hash in the same gv as a ro scalar'; | |
128 | is $scratch::an_array, 1, 'reset skips ro scalars in the same gv as av/hv'; | |
129 | ||
61e9f3fe FC |
130 | for 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 | ||
23083432 FC |
143 | # This used to crash under threaded builds, because pmops were remembering |
144 | # their stashes by name, rather than by pointer. | |
145 | fresh_perl_is( # it crashes more reliably with a smaller script | |
146 | 'package bar; | |
147 | sub foo { | |
148 | m??; | |
149 | BEGIN { *baz:: = *bar::; *bar:: = *foo:: } | |
150 | # The name "bar" no langer refers to the same package | |
151 | } | |
152 | undef &foo; # so freeing the op does not remove it from the stash’s list | |
153 | $_ = ""; | |
154 | push @_, ($_) x 10000; # and its memory is scribbled over | |
155 | reset; # so reset on the original package tries to reset an invalid op | |
156 | print "ok\n";', | |
157 | "ok\n", {}, | |
158 | "no crash if package is effectively renamed before op is freed"); | |
159 | ||
e39b51c6 FC |
160 | sub _117941 { package _117941; reset } |
161 | delete $::{"_117941::"}; | |
162 | _117941(); | |
163 | pass("no crash when current package is freed"); | |
a1f22e0c NC |
164 | |
165 | undef $/; | |
166 | my $prog = <DATA>; | |
167 | ||
168 | SKIP: | |
169 | { | |
170 | eval {require threads; 1} or | |
171 | skip "No threads", 4; | |
a1f22e0c NC |
172 | foreach my $eight ('/', '?') { |
173 | foreach my $nine ('/', '?') { | |
174 | my $copy = $prog; | |
175 | $copy =~ s/8/$eight/gm; | |
176 | $copy =~ s/9/$nine/gm; | |
177 | fresh_perl_is($copy, "pass", "", | |
178 | "first pattern $eight$eight, second $nine$nine"); | |
179 | } | |
180 | } | |
181 | } | |
182 | ||
183 | __DATA__ | |
184 | #!perl | |
185 | use warnings; | |
186 | use strict; | |
187 | ||
188 | # Note that there are no digits in this program, other than the placeholders | |
189 | sub a { | |
725a61d7 | 190 | m8one8; |
a1f22e0c NC |
191 | } |
192 | sub b { | |
725a61d7 | 193 | m9two9; |
a1f22e0c NC |
194 | } |
195 | ||
196 | use threads; | |
197 | use threads::shared; | |
198 | ||
199 | sub wipe { | |
ff8b4a37 | 200 | eval 'no warnings; sub b {}; 1' or die $@; |
a1f22e0c NC |
201 | } |
202 | ||
203 | sub lock_then_wipe { | |
204 | my $l_r = shift; | |
205 | lock $$l_r; | |
206 | cond_wait($$l_r) until $$l_r eq "B"; | |
207 | wipe; | |
208 | $$l_r = "C"; | |
209 | cond_signal $$l_r; | |
210 | } | |
211 | ||
212 | my $lock : shared = "A"; | |
213 | my $r = \$lock; | |
214 | ||
215 | my $t; | |
216 | { | |
217 | lock $$r; | |
218 | $t = threads->new(\&lock_then_wipe, $r); | |
219 | wipe; | |
220 | $lock = "B"; | |
221 | cond_signal $lock; | |
222 | } | |
223 | ||
224 | { | |
225 | lock $lock; | |
226 | cond_wait($lock) until $lock eq "C"; | |
227 | reset; | |
228 | } | |
229 | ||
230 | $t->join; | |
231 | print "pass\n"; |