perldelta: perldelta for previous commit
[perl.git] / t / op / reset.t
1 #!./perl -w
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8 use strict;
9
10 plan tests => 40;
11
12 package aiieee;
13
14 sub zlopp {
15     (shift =~ m?zlopp?) ? 1 : 0;
16 }
17
18 sub reset_zlopp {
19     reset;
20 }
21
22 package CLINK;
23
24 sub ZZIP {
25     shift =~ m?ZZIP? ? 1 : 0;
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");
63
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
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
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
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
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
143 package _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
153 # This used to crash under threaded builds, because pmops were remembering
154 # their stashes by name, rather than by pointer.
155 fresh_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    }
162    undef &foo; # so freeing the op does not remove it from the stash\'s list
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
170 sub _117941 { package _117941; reset }
171 delete $::{"_117941::"};
172 _117941();
173 pass("no crash when current package is freed");
174
175 undef $/;
176 my $prog = <DATA>;
177
178 SKIP:
179 {
180     eval {require threads; 1} or
181         skip "No threads", 4;
182     foreach my $eight ('/', '?') {
183         foreach my $nine ('/', '?') {
184             my $copy = $prog;
185             $copy =~ s/8/$eight/gm;
186             $copy =~ s/9/$nine/gm;
187             fresh_perl_is($copy, "pass", {},
188                           "first pattern $eight$eight, second $nine$nine");
189         }
190     }
191 }
192
193 __DATA__
194 #!perl
195 use warnings;
196 use strict;
197
198 # Note that there are no digits in this program, other than the placeholders
199 sub a {
200 m8one8;
201 }
202 sub b {
203 m9two9;
204 }
205
206 use threads;
207 use threads::shared;
208
209 sub wipe {
210     eval 'no warnings; sub b {}; 1' or die $@;
211 }
212
213 sub 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
222 my $lock : shared = "A";
223 my $r = \$lock;
224
225 my $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;
241 print "pass\n";