1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8use strict; 9 10plan tests => 30; 11 12package aiieee; 13 14sub zlopp { 15 (shift =~ m?zlopp?) ? 1 : 0; 16} 17 18sub reset_zlopp { 19 reset; 20} 21 22package CLINK; 23 24sub ZZIP { 25 shift =~ m?ZZIP? ? 1 : 0; 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"); 63 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 106# This used to crash under threaded builds, because pmops were remembering 107# their stashes by name, rather than by pointer. 108fresh_perl_is( # it crashes more reliably with a smaller script 109 'package bar; 110 sub foo { 111 m??; 112 BEGIN { *baz:: = *bar::; *bar:: = *foo:: } 113 # The name "bar" no langer refers to the same package 114 } 115 undef &foo; # so freeing the op does not remove it from the stash’s list 116 $_ = ""; 117 push @_, ($_) x 10000; # and its memory is scribbled over 118 reset; # so reset on the original package tries to reset an invalid op 119 print "ok\n";', 120 "ok\n", {}, 121 "no crash if package is effectively renamed before op is freed"); 122 123 124undef $/; 125my $prog = <DATA>; 126 127SKIP: 128{ 129 eval {require threads; 1} or 130 skip "No threads", 4; 131 foreach my $eight ('/', '?') { 132 foreach my $nine ('/', '?') { 133 my $copy = $prog; 134 $copy =~ s/8/$eight/gm; 135 $copy =~ s/9/$nine/gm; 136 fresh_perl_is($copy, "pass", "", 137 "first pattern $eight$eight, second $nine$nine"); 138 } 139 } 140} 141 142__DATA__ 143#!perl 144use warnings; 145use strict; 146 147# Note that there are no digits in this program, other than the placeholders 148sub a { 149m8one8; 150} 151sub b { 152m9two9; 153} 154 155use threads; 156use threads::shared; 157 158sub wipe { 159 eval 'no warnings; sub b {}; 1' or die $@; 160} 161 162sub lock_then_wipe { 163 my $l_r = shift; 164 lock $$l_r; 165 cond_wait($$l_r) until $$l_r eq "B"; 166 wipe; 167 $$l_r = "C"; 168 cond_signal $$l_r; 169} 170 171my $lock : shared = "A"; 172my $r = \$lock; 173 174my $t; 175{ 176 lock $$r; 177 $t = threads->new(\&lock_then_wipe, $r); 178 wipe; 179 $lock = "B"; 180 cond_signal $lock; 181} 182 183{ 184 lock $lock; 185 cond_wait($lock) until $lock eq "C"; 186 reset; 187} 188 189$t->join; 190print "pass\n"; 191