t/op/reset.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8 use strict;
   9
  10 plan tests => 29;
  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
 107 undef $/;
 108 my $prog = <DATA>;
 109
 110 SKIP:
 111 {
 112     eval {require threads; 1} or
 113         skip "No threads", 4;
 114     foreach my $eight ('/', '?') {
 115         foreach my $nine ('/', '?') {
 116             my $copy = $prog;
 117             $copy =~ s/8/$eight/gm;
 118             $copy =~ s/9/$nine/gm;
 119             fresh_perl_is($copy, "pass", "",
 120                           "first pattern $eight$eight, second $nine$nine");
 121         }
 122     }
 123 }
 124
 125 __DATA__
 126 #!perl
 127 use warnings;
 128 use strict;
 129
 130 # Note that there are no digits in this program, other than the placeholders
 131 sub a {
 132 m8one8;
 133 }
 134 sub b {
 135 m9two9;
 136 }
 137
 138 use threads;
 139 use threads::shared;
 140
 141 sub wipe {
 142     eval 'no warnings; sub b {}; 1' or die $@;
 143 }
 144
 145 sub lock_then_wipe {
 146     my $l_r = shift;
 147     lock $$l_r;
 148     cond_wait($$l_r) until $$l_r eq "B";
 149     wipe;
 150     $$l_r = "C";
 151     cond_signal $$l_r;
 152 }
 153
 154 my $lock : shared = "A";
 155 my $r = \$lock;
 156
 157 my $t;
 158 {
 159     lock $$r;
 160     $t = threads->new(\&lock_then_wipe, $r);
 161     wipe;
 162     $lock = "B";
 163     cond_signal $lock;
 164 }
 165
 166 {
 167     lock $lock;
 168     cond_wait($lock) until $lock eq "C";
 169     reset;
 170 }
 171
 172 $t->join;
 173 print "pass\n";