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";