X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Fpat.t;h=90623fbfca62f091250d87f9b6e4b5ef52a9c1ae;hb=c70c8a0a59777ed7fb7075471185210bc2169b49;hp=5d8bf8ad7867ca09e7af7a81a1a44c7177570f77;hpb=cc6b73957505a73b130c87add7bf3d534f129041;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/pat.t b/t/op/pat.t index 5d8bf8a..90623fb 100755 --- a/t/op/pat.t +++ b/t/op/pat.t @@ -1,8 +1,18 @@ #!./perl +# +# This is a home for regular expression tests that don't fit into +# the format supported by op/regexp.t. If you want to add a test +# that does fit that format, add it to op/re_tests, not here. # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $ -print "1..101\n"; +print "1..130\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = "../lib" if -d "../lib"; +} +eval 'use Config'; # Defaults assumed if this fails $x = "abc\ndef\n"; @@ -67,7 +77,7 @@ $XXX{234} = 234; $XXX{345} = 345; @XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27'); -while ($_ = shift(XXX)) { +while ($_ = shift(@XXX)) { ?(.*)? && (print $1,"\n"); /not/ && reset; /not ok 26/ && reset 'X'; @@ -233,8 +243,56 @@ $_ = 'foobar1 bar2 foobar3 barfoobar5 foobar6'; print "not " if "@out" ne 'bar2 barf'; print "ok 65\n"; +# Tests which depend on REG_INFTY +$reg_infty = defined $Config{reg_infty} ? $Config{reg_infty} : 32767; +$reg_infty_m = $reg_infty - 1; $reg_infty_p = $reg_infty + 1; + +# As well as failing if the pattern matches do unexpected things, the +# next three tests will fail if you should have picked up a lower-than- +# default value for $reg_infty from Config.pm, but have not. + +undef $@; +print "not " if eval q(('aaa' =~ /(a{1,$reg_infty_m})/)[0] ne 'aaa') || $@; +print "ok 66\n"; + +undef $@; +print "not " if eval q(('a' x $reg_infty_m) !~ /a{$reg_infty_m}/) || $@; +print "ok 67\n"; + +undef $@; +print "not " if eval q(('a' x ($reg_infty_m - 1)) =~ /a{$reg_infty_m}/) || $@; +print "ok 68\n"; + +undef $@; +eval "'aaa' =~ /a{1,$reg_infty}/"; +print "not " if $@ !~ m%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%; +print "ok 69\n"; + +eval "'aaa' =~ /a{1,$reg_infty_p}/"; +print "not " + if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%; +print "ok 70\n"; +undef $@; + +# Poke a couple more parse failures + +$context = 'x' x 256; +eval qq("${context}y" =~ /(?<=$context)y/); +print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; +print "ok 71\n"; + +# This one will fail when POSIX character classes do get implemented +{ + my $w; + local $^W = 1; + local $SIG{__WARN__} = sub{$w = shift}; + eval q('a' =~ /[[:alpha:]]/); + print "not " if $w !~ /^\QCharacter class syntax [: :] is reserved/; +} +print "ok 72\n"; + # Long Monsters -$test = 66; +$test = 73; for $l (125, 140, 250, 270, 300000, 30) { # Ordered to free memory $a = 'a' x $l; print "# length=$l\nnot " unless "ba$a=" =~ /a$a=/; @@ -323,7 +381,26 @@ $test++; $code = '{$blah = 45}'; $blah = 12; -/(?$code)/; +eval { /(?$code)/ }; +print "not " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; +print "ok $test\n"; +$test++; + +for $code ('{$blah = 45}','=xx') { + $blah = 12; + $res = eval { "xx" =~ /(?$code)/o }; + if ($code eq '=xx') { + print "#'$@','$res','$blah'\nnot " unless not $@ and $res; + } else { + print "#'$@','$res','$blah'\nnot " unless $@ and $@ =~ /not allowed at runtime/ and $blah == 12; + } + print "ok $test\n"; + $test++; +} + +$code = '{$blah = 45}'; +$blah = 12; +eval "/(?$code)/"; print "not " if $blah != 45; print "ok $test\n"; $test++; @@ -354,3 +431,111 @@ $x =~ /.a/g; print "not " unless f(pos($x)) == 4; print "ok $test\n"; $test++; + +$x = $^R = 67; +'foot' =~ /foo(?{$x = 12; 75})[t]/; +print "not " unless $^R eq '75'; +print "ok $test\n"; +$test++; + +$x = $^R = 67; +'foot' =~ /foo(?{$x = 12; 75})[xy]/; +print "not " unless $^R eq '67' and $x eq '12'; +print "ok $test\n"; +$test++; + +$x = $^R = 67; +'foot' =~ /foo(?{ $^R + 12 })((?{ $x = 12; $^R + 17 })[xy])?/; +print "not " unless $^R eq '79' and $x eq '12'; +print "ok $test\n"; +$test++; + +# This should be changed to qr/\b\v$/ ASAP +print "not " unless study(/\b\v$/) eq '(?:\bv$)'; +print "ok $test\n"; +$test++; + +$_ = 'xabcx'; +foreach $ans ('', 'c') { + /(?<=(?=a)..)((?=c)|.)/g; + print "not " unless $1 eq $ans; + print "ok $test\n"; + $test++; +} + +$_ = 'a'; +foreach $ans ('', 'a', '') { + /^|a|$/g; + print "not " unless $& eq $ans; + print "ok $test\n"; + $test++; +} + +sub prefixify { + my($v,$a,$b,$res) = @_; + $v =~ s/\Q$a\E/$b/; + print "not " unless $res eq $v; + print "ok $test\n"; + $test++; +} +prefixify('/a/b/lib/arch', "/a/b/lib", 'X/lib', 'X/lib/arch'); +prefixify('/a/b/man/arch', "/a/b/man", 'X/man', 'X/man/arch'); + +$_ = 'var="foo"'; +/(\")/; +print "not " unless $1 and /$1/; +print "ok $test\n"; +$test++; + +$a=study/(?{++$b})/; +$b = 7; +/$a$a/; +print "not " unless $b eq '9'; +print "ok $test\n"; +$test++; + +$c="$a"; +/$a$a/; +print "not " unless $b eq '11'; +print "ok $test\n"; +$test++; + +{ + use re "eval"; + /$a$c$a/; + print "not " unless $b eq '14'; + print "ok $test\n"; + $test++; + + no re "eval"; + $match = eval { /$a$c$a/ }; + print "not " + unless $b eq '14' and $@ =~ /Eval-group not allowed/ and not $match; + print "ok $test\n"; + $test++; +} + +sub must_warn_pat { + my $warn_pat = shift; + return sub { print "not " unless $_[0] =~ /$warn_pat/ } +} + +sub must_warn { + my ($warn_pat, $code) = @_; + local $^W; local %SIG; + eval 'BEGIN { $^W = 1; $SIG{__WARN__} = $warn_pat };' . $code; + print "ok $test\n"; + $test++; +} + + +sub make_must_warn { + my $warn_pat = shift; + return sub { must_warn(must_warn_pat($warn_pat)) } +} + +my $for_future = make_must_warn('reserved for future extensions'); + +&$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); +&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); +&$for_future('q(a.[b].) =~ /[x[.foo.]]/');