t/op/pat.t

   1 #!./perl
   2
   3 # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $
   4
   5 print "1..101\n";
   6
   7 $x = "abc\ndef\n";
   8
   9 if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
  10 if ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
  11
  12 $* = 1;
  13 if ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
  14 $* = 0;
  15
  16 $_ = '123';
  17 if (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
  18
  19 if ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
  20 if ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
  21
  22 if ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
  23 if ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
  24
  25 if ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
  26 if ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
  27
  28 if ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
  29 if ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
  30
  31 $_ = 'aaabbbccc';
  32 if (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
  33         print "ok 13\n";
  34 } else {
  35         print "not ok 13\n";
  36 }
  37 if (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
  38         print "ok 14\n";
  39 } else {
  40         print "not ok 14\n";
  41 }
  42
  43 if (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
  44
  45 $_ = 'aaabccc';
  46 if (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
  47 if (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
  48
  49 $_ = 'aaaccc';
  50 if (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
  51 if (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
  52
  53 $_ = 'abcdef';
  54 if (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
  55 if (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
  56
  57 if (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
  58
  59 if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
  60
  61 $* = 1;         # test 3 only tested the optimized version--this one is for real
  62 if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
  63 $* = 0;
  64
  65 $XXX{123} = 123;
  66 $XXX{234} = 234;
  67 $XXX{345} = 345;
  68
  69 @XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
  70 while ($_ = shift(XXX)) {
  71     ?(.*)? && (print $1,"\n");
  72     /not/ && reset;
  73     /not ok 26/ && reset 'X';
  74 }
  75
  76 while (($key,$val) = each(%XXX)) {
  77     print "not ok 27\n";
  78     exit;
  79 }
  80
  81 print "ok 27\n";
  82
  83 'cde' =~ /[^ab]*/;
  84 'xyz' =~ //;
  85 if ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
  86
  87 $foo = '[^ab]*';
  88 'cde' =~ /$foo/;
  89 'xyz' =~ //;
  90 if ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
  91
  92 $foo = '[^ab]*';
  93 'cde' =~ /$foo/;
  94 'xyz' =~ /$null/;
  95 if ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
  96
  97 $_ = 'abcdefghi';
  98 /def/;          # optimized up to cmd
  99 if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
 100
 101 /cde/ + 0;      # optimized only to spat
 102 if ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
 103
 104 /[d][e][f]/;    # not optimized
 105 if ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
 106
 107 $_ = 'now is the {time for all} good men to come to.';
 108 / {([^}]*)}/;
 109 if ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
 110
 111 $_ = 'xxx {3,4}  yyy   zzz';
 112 print /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
 113 print $1 eq '   ' ? "ok 36\n" : "not ok 36\n";
 114 print /( {4,})/ ? "not ok 37\n" : "ok 37\n";
 115 print /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
 116 print $1 eq '  y' ? "ok 39\n" : "not ok 39\n";
 117 print /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
 118 print $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
 119 print /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
 120 print /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
 121
 122 $_ = "now is the time for all good men to come to.";
 123 @words = /(\w+)/g;
 124 print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
 125     ? "ok 44\n"
 126     : "not ok 44\n";
 127
 128 @words = ();
 129 while (/\w+/g) {
 130     push(@words, $&);
 131 }
 132 print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
 133     ? "ok 45\n"
 134     : "not ok 45\n";
 135
 136 @words = ();
 137 pos = 0;
 138 while (/to/g) {
 139     push(@words, $&);
 140 }
 141 print join(':',@words) eq "to:to"
 142     ? "ok 46\n"
 143     : "not ok 46 `@words'\n";
 144
 145 pos $_ = 0;
 146 @words = /to/g;
 147 print join(':',@words) eq "to:to"
 148     ? "ok 47\n"
 149     : "not ok 47 `@words'\n";
 150
 151 $_ = "abcdefghi";
 152
 153 $pat1 = 'def';
 154 $pat2 = '^def';
 155 $pat3 = '.def.';
 156 $pat4 = 'abc';
 157 $pat5 = '^abc';
 158 $pat6 = 'abc$';
 159 $pat7 = 'ghi';
 160 $pat8 = '\w*ghi';
 161 $pat9 = 'ghi$';
 162
 163 $t1=$t2=$t3=$t4=$t5=$t6=$t7=$t8=$t9=0;
 164
 165 for $iter (1..5) {
 166     $t1++ if /$pat1/o;
 167     $t2++ if /$pat2/o;
 168     $t3++ if /$pat3/o;
 169     $t4++ if /$pat4/o;
 170     $t5++ if /$pat5/o;
 171     $t6++ if /$pat6/o;
 172     $t7++ if /$pat7/o;
 173     $t8++ if /$pat8/o;
 174     $t9++ if /$pat9/o;
 175 }
 176
 177 $x = "$t1$t2$t3$t4$t5$t6$t7$t8$t9";
 178 print $x eq '505550555' ? "ok 48\n" : "not ok 48 $x\n";
 179
 180 $xyz = 'xyz';
 181 print "abc" =~ /^abc$|$xyz/ ? "ok 49\n" : "not ok 49\n";
 182
 183 # perl 4.009 says "unmatched ()"
 184 eval '"abc" =~ /a(bc$)|$xyz/; $result = "$&:$1"';
 185 print $@ eq "" ? "ok 50\n" : "not ok 50\n";
 186 print $result eq "abc:bc" ? "ok 51\n" : "not ok 51\n";
 187
 188
 189 $_="abcfooabcbar";
 190 $x=/abc/g;
 191 print $` eq "" ? "ok 52\n" : "not ok 52\n" if $x;
 192 $x=/abc/g;
 193 print $` eq "abcfoo" ? "ok 53\n" : "not ok 53\n" if $x;
 194 $x=/abc/g;
 195 print $x == 0 ? "ok 54\n" : "not ok 54\n";
 196 pos = 0;
 197 $x=/ABC/gi;
 198 print $` eq "" ? "ok 55\n" : "not ok 55\n" if $x;
 199 $x=/ABC/gi;
 200 print $` eq "abcfoo" ? "ok 56\n" : "not ok 56\n" if $x;
 201 $x=/ABC/gi;
 202 print $x == 0 ? "ok 57\n" : "not ok 57\n";
 203 pos = 0;
 204 $x=/abc/g;
 205 print $' eq "fooabcbar" ? "ok 58\n" : "not ok 58\n" if $x;
 206 $x=/abc/g;
 207 print $' eq "bar" ? "ok 59\n" : "not ok 59\n" if $x;
 208 $_ .= '';
 209 @x=/abc/g;
 210 print scalar @x == 2 ? "ok 60\n" : "not ok 60\n";
 211
 212 $_ = "abdc";
 213 pos $_ = 2;
 214 /\Gc/gc;
 215 print "not " if (pos $_) != 2;
 216 print "ok 61\n";
 217 /\Gc/g;
 218 print "not " if defined pos $_;
 219 print "ok 62\n";
 220
 221 $out = 1;
 222 'abc' =~ m'a(?{ $out = 2 })b';
 223 print "not " if $out != 2;
 224 print "ok 63\n";
 225
 226 $out = 1;
 227 'abc' =~ m'a(?{ $out = 3 })c';
 228 print "not " if $out != 1;
 229 print "ok 64\n";
 230
 231 $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6';
 232 @out = /(?<!foo)bar./g;
 233 print "not " if "@out" ne 'bar2 barf';
 234 print "ok 65\n";
 235
 236 # Long Monsters
 237 $test = 66;
 238 for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory
 239   $a = 'a' x $l;
 240   print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/;
 241   print "ok $test\n";
 242   $test++;
 243
 244   print "not " if "b$a=" =~ /a$a=/;
 245   print "ok $test\n";
 246   $test++;
 247 }
 248
 249 # 20000 nodes, each taking 3 words per string, and 1 per branch
 250 $long_constant_len = join '|', 12120 .. 32645;
 251 $long_var_len = join '|', 8120 .. 28645;
 252 %ans = ( 'ax13876y25677lbc' => 1,
 253          'ax13876y25677mcb' => 0, # not b.
 254          'ax13876y35677nbc' => 0, # Num too big
 255          'ax13876y25677y21378obc' => 1,
 256          'ax13876y25677y21378zbc' => 0, # Not followed by [k-o]
 257          'ax13876y25677y21378y21378kbc' => 1,
 258          'ax13876y25677y21378y21378kcb' => 0, # Not b.
 259          'ax13876y25677y21378y21378y21378kbc' => 0, # 5 runs
 260        );
 261
 262 for ( keys %ans ) {
 263   print "# const-len `$_' not =>  $ans{$_}\nnot "
 264     if $ans{$_} xor /a(?=([yx]($long_constant_len)){2,4}[k-o]).*b./o;
 265   print "ok $test\n";
 266   $test++;
 267   print "# var-len   `$_' not =>  $ans{$_}\nnot "
 268     if $ans{$_} xor /a(?=([yx]($long_var_len)){2,4}[k-o]).*b./o;
 269   print "ok $test\n";
 270   $test++;
 271 }
 272
 273 $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
 274 $expect = "(bla()) ((l)u((e))) (l(e)e)";
 275
 276 sub matchit {
 277   m/
 278      (
 279        \(
 280        (?{ $c = 1 })            # Initialize
 281        (?:
 282          (?(?{ $c == 0 })       # PREVIOUS iteration was OK, stop the loop
 283            (?!
 284            )                    # Fail: will unwind one iteration back
 285          )
 286          (?:
 287            [^()]+               # Match a big chunk
 288            (?=
 289              [()]
 290            )                    # Do not try to match subchunks
 291          |
 292            \(
 293            (?{ ++$c })
 294          |
 295            \)
 296            (?{ --$c })
 297          )
 298        )+                       # This may not match with different subblocks
 299      )
 300      (?(?{ $c != 0 })
 301        (?!
 302        )                        # Fail
 303      )                          # Otherwise the chunk 1 may succeed with $c>0
 304    /xg;
 305 }
 306
 307 push @ans, $res while $res = matchit;
 308
 309 print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1";
 310 print "ok $test\n";
 311 $test++;
 312
 313 @ans = matchit;
 314
 315 print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect;
 316 print "ok $test\n";
 317 $test++;
 318
 319 @ans = ('a/b' =~ m%(.*/)?(.*)%);        # Stack may be bad
 320 print "not " if "@ans" ne 'a/ b';
 321 print "ok $test\n";
 322 $test++;
 323
 324 $code = '{$blah = 45}';
 325 $blah = 12;
 326 /(?$code)/;
 327 print "not " if $blah != 45;
 328 print "ok $test\n";
 329 $test++;
 330
 331 $blah = 12;
 332 /(?{$blah = 45})/;
 333 print "not " if $blah != 45;
 334 print "ok $test\n";
 335 $test++;
 336
 337 $x = 'banana';
 338 $x =~ /.a/g;
 339 print "not " unless pos($x) == 2;
 340 print "ok $test\n";
 341 $test++;
 342
 343 $x =~ /.z/gc;
 344 print "not " unless pos($x) == 2;
 345 print "ok $test\n";
 346 $test++;
 347
 348 sub f {
 349     my $p = $_[0];
 350     return $p;
 351 }
 352
 353 $x =~ /.a/g;
 354 print "not " unless f(pos($x)) == 4;
 355 print "ok $test\n";
 356 $test++;