iseq("$1$2","foobar");
}
{
+ local $Message = "HORIZWS";
local $_="\t \r\n \n \t".chr(11)."\n";
s/\H/H/g;
s/\h/h/g;
iseq($_,"hhHHhHhhHH");
}
{
+ local $Message = "Various whitespace special patterns";
my @h=map { chr( $_ ) } (
0x09, 0x20, 0xa0, 0x1680, 0x180e, 0x2000, 0x2001, 0x2002,
0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200a,
my $ary=shift @$t;
foreach my $pat (@$t) {
foreach my $str (@$ary) {
- ok($str=~/($pat)/);
- iseq($1,$str);
+ ok($str=~/($pat)/,$pat);
+ iseq($1,$str,$pat);
utf8::upgrade($str);
- ok($str=~/($pat)/);
- iseq($1,$str);
+ ok($str=~/($pat)/,"Upgraded string - $pat");
+ iseq($1,$str,"Upgraded string - $pat");
}
}
}
}
+{
+ local $Message = "Check that \\xDF match properly in its various forms";
+ # test that \xDF matches properly. this is pretty hacky stuff,
+ # but its actually needed. the malarky with '-' is to prevent
+ # compilation caching from playing any role in the test.
+ my @df= (chr(0xDF),'-',chr(0xDF));
+ utf8::upgrade($df[2]);
+ my @strs= ('ss','sS','Ss','SS',chr(0xDF));
+ my @ss= map { ("$_", "$_") } @strs;
+ utf8::upgrade($ss[$_*2+1]) for 0..$#strs;
+
+ for my $ssi (0..$#ss) {
+ for my $dfi (0..$#df) {
+ my $pat= $df[$dfi];
+ my $str= $ss[$ssi];
+ my $utf_df= ($dfi > 1) ? 'utf8' : '';
+ my $utf_ss= ($ssi % 2) ? 'utf8' : '';
+ (my $sstr=$str)=~s/\xDF/\\xDF/;
+
+ if ($utf_df || $utf_ss || length($ss[$ssi])==1) {
+ my $ret= $str=~/$pat/i;
+ next if $pat eq '-';
+ ok($ret,
+ "\"$sstr\"=~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})");
+ } else {
+ my $ret= $str !~ /$pat/i;
+ next if $pat eq '-';
+ ok($ret,
+ "\"$sstr\"!~/\\xDF/i (str is @{[$utf_ss||'latin']}, pat is @{[$utf_df||'latin']})");
+ }
+ }
+ }
+}
+{
+ local $Message = "BBC(Bleadperl Breaks CPAN) Today: String::Multibyte";
+ my $re = qr/(?:[\x00-\xFF]{4})/;
+ my $hyp = "\0\0\0-";
+ my $esc = "\0\0\0\\";
+
+ my $str = "$esc$hyp$hyp$esc$esc";
+ my @a = ($str =~ /\G(?:\Q$esc$esc\E|\Q$esc$hyp\E|$re)/g);
+
+ iseq(0+@a,3);
+ iseq(join('=', @a),"$esc$hyp=$hyp=$esc$esc");
+}
+# test for keys in %+ and %-
+{
+ my $_ = "abcdef";
+ /(?<foo>a)|(?<foo>b)/;
+ iseq( (join ",", sort keys %+), "foo" );
+ iseq( (join ",", sort keys %-), "foo" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), "a " );
+ /(?<bar>a)(?<bar>b)(?<quux>.)/;
+ iseq( (join ",", sort keys %+), "bar,quux" );
+ iseq( (join ",", sort keys %-), "bar,quux" );
+ iseq( (join ",", sort values %+), "a,c" ); # leftmost
+ iseq( (join ",", sort map "@$_", values %-), "a b,c" );
+ /(?<un>a)(?<deux>c)?/; # second buffer won't capture
+ iseq( (join ",", sort keys %+), "un" );
+ iseq( (join ",", sort keys %-), "deux,un" );
+ iseq( (join ",", sort values %+), "a" );
+ iseq( (join ",", sort map "@$_", values %-), ",a" );
+}
+
+# length() on captures, the numbered ones end up in Perl_magic_len
+{
+ my $_ = "aoeu \xe6var ook";
+ /^ \w+ \s (?<eek>\S+)/x;
+
+ iseq( length($`), 0, 'length $`' );
+ iseq( length($'), 4, q[length $'] );
+ iseq( length($&), 9, 'length $&' );
+ iseq( length($1), 4, 'length $1' );
+ iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
+}
+
+{
+ my $ok=-1;
+
+ $ok=exists($-{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'bar'=~/(?<x>foo)|bar/;
+ iseq($ok,0,'$+{x} not exists after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 0, 'scalar %+ == 0 after "bar"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "bar"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($-{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$-{x} exists after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%+), 1, 'scalar %+ == 1 after "foo"=~/(?<x>foo)|bar/');
+ iseq(scalar(%-), 1, 'scalar %- == 1 after "foo"=~/(?<x>foo)|bar/');
+
+ $ok=-1;
+ $ok=exists($+{x}) ? 1 : 0
+ if 'foo'=~/(?<x>foo)|bar/;
+ iseq($ok,1,'$+{x} exists after "foo"=~/(?<x>foo)|bar/');
+}
+
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
iseq($_,"!Bang!1!Bang!2!Bang!3!Bang!");
}
-# test for keys in %+ and %-
-{
- my $_ = "abcdef";
- /(?<foo>a)|(?<foo>b)/;
- iseq( (join ",", sort keys %+), "foo" );
- iseq( (join ",", sort keys %-), "foo" );
- iseq( (join ",", sort values %+), "a" );
- iseq( (join ",", sort map "@$_", values %-), "a " );
- /(?<bar>a)(?<bar>b)(?<quux>.)/;
- iseq( (join ",", sort keys %+), "bar,quux" );
- iseq( (join ",", sort keys %-), "bar,quux" );
- iseq( (join ",", sort values %+), "a,c" ); # leftmost
- iseq( (join ",", sort map "@$_", values %-), "a b,c" );
- /(?<un>a)(?<deux>c)?/; # second buffer won't capture
- iseq( (join ",", sort keys %+), "un" );
- iseq( (join ",", sort keys %-), "deux,un" );
- iseq( (join ",", sort values %+), "a" );
- iseq( (join ",", sort map "@$_", values %-), ",a" );
-}
-
-# length() on captures, these end up in Perl_magic_len
-{
- my $_ = "aoeu \xe6var ook";
- /^ \w+ \s (?<eek>\S+)/x;
-
- iseq( length($`), 0, 'length $`' );
- iseq( length($'), 4, q[length $'] );
- iseq( length($&), 9, 'length $&' );
- iseq( length($1), 4, 'length $1' );
- iseq( length($+{eek}), 4, 'length $+{eek} == length $1' );
-}
-
# Put new tests above the dotted line about a page above this comment
iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 1928;
+ $::TestCount = 1960;
print "1..$::TestCount\n";
}
-
-
projects / p5sagit/p5-mst-13.2.git / blobdiff