Lots of consting

[p5sagit/p5-mst-13.2.git] / t / op / subst.t

diff --git a/t/op/subst.t b/t/op/subst.t
index 026a940..148b5db 100755 (executable)
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 108 );
+plan( tests => 130 );
 
 $x = 'foo';
 $_ = "x";
@@ -380,26 +380,30 @@ $pv1 =~ s/A/\x{100}/;
 substr($pv2,0,1) = "\x{100}";
 is($pv1, $pv2);
 
-{   
-    # Gregor Chrupala <gregor.chrupala@star-group.net>
-    use utf8;
-    $a = 'Espa&ntilde;a';
-    $a =~ s/&ntilde;/ñ/;
-    like($a, qr/ñ/, "use utf8 RHS");
-}
-
-{
-    use utf8;
-    $a = 'España España';
-    $a =~ s/ñ/&ntilde;/;
-    like($a, qr/ñ/, "use utf8 LHS");
-}
-
-{
-    use utf8;
-    $a = 'España';
-    $a =~ s/ñ/ñ/;
-    like($a, qr/ñ/, "use utf8 LHS and RHS");
+SKIP: {
+    skip("EBCDIC", 3) if ord("A") == 193; 
+
+    {   
+       # Gregor Chrupala <gregor.chrupala@star-group.net>
+       use utf8;
+       $a = 'Espa&ntilde;a';
+       $a =~ s/&ntilde;/ñ/;
+       like($a, qr/ñ/, "use utf8 RHS");
+    }
+
+    {
+       use utf8;
+       $a = 'España España';
+       $a =~ s/ñ/&ntilde;/;
+       like($a, qr/ñ/, "use utf8 LHS");
+    }
+
+    {
+       use utf8;
+       $a = 'España';
+       $a =~ s/ñ/ñ/;
+       like($a, qr/ñ/, "use utf8 LHS and RHS");
+    }
 }
 
 {
@@ -408,7 +412,7 @@ is($pv1, $pv2);
     $a = "\x{100}\x{101}";
     $a =~ s/\x{101}/\xFF/;
     like($a, qr/\xFF/);
-    is(length($a), 2);
+    is(length($a), 2, "SADAHIRO utf8 s///");
 
     $a = "\x{100}\x{101}";
     $a =~ s/\x{101}/"\xFF"/e;
@@ -445,3 +449,93 @@ is($pv1, $pv2);
     like($a, qr/\x{100}/);
     is(length($a), 1);
 }
+
+{
+    # subst with mixed utf8/non-utf8 type
+    my($ua, $ub, $uc, $ud) = ("\x{101}", "\x{102}", "\x{103}", "\x{104}");
+    my($na, $nb) = ("\x{ff}", "\x{fe}");
+    my $a = "$ua--$ub";
+    my $b;
+    ($b = $a) =~ s/--/$na/;
+    is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8");
+    ($b = $a) =~ s/--/--$na--/;
+    is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8");
+    ($b = $a) =~ s/--/$uc/;
+    is($b, "$ua$uc$ub", "s///: replace utf8 into utf8");
+    ($b = $a) =~ s/--/--$uc--/;
+    is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8");
+    $a = "$na--$nb";
+    ($b = $a) =~ s/--/$ua/;
+    is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8");
+    ($b = $a) =~ s/--/--$ua--/;
+    is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8");
+
+    # now with utf8 pattern
+    $a = "$ua--$ub";
+    ($b = $a) =~ s/-($ud)?-/$na/;
+    is($b, "$ua$na$ub", "s///: replace non-utf8 into utf8 (utf8 pattern)");
+    ($b = $a) =~ s/-($ud)?-/--$na--/;
+    is($b, "$ua--$na--$ub", "s///: replace long non-utf8 into utf8 (utf8 pattern)");
+    ($b = $a) =~ s/-($ud)?-/$uc/;
+    is($b, "$ua$uc$ub", "s///: replace utf8 into utf8 (utf8 pattern)");
+    ($b = $a) =~ s/-($ud)?-/--$uc--/;
+    is($b, "$ua--$uc--$ub", "s///: replace long utf8 into utf8 (utf8 pattern)");
+    $a = "$na--$nb";
+    ($b = $a) =~ s/-($ud)?-/$ua/;
+    is($b, "$na$ua$nb", "s///: replace utf8 into non-utf8 (utf8 pattern)");
+    ($b = $a) =~ s/-($ud)?-/--$ua--/;
+    is($b, "$na--$ua--$nb", "s///: replace long utf8 into non-utf8 (utf8 pattern)");
+    ($b = $a) =~ s/-($ud)?-/$na/;
+    is($b, "$na$na$nb", "s///: replace non-utf8 into non-utf8 (utf8 pattern)");
+    ($b = $a) =~ s/-($ud)?-/--$na--/;
+    is($b, "$na--$na--$nb", "s///: replace long non-utf8 into non-utf8 (utf8 pattern)");
+}
+
+$_ = 'aaaa';
+$r = 'x';
+$s = s/a(?{})/$r/g;
+is("<$_> <$s>", "<xxxx> <4>", "[perl #7806]");
+
+$_ = 'aaaa';
+$s = s/a(?{})//g;
+is("<$_> <$s>", "<> <4>", "[perl #7806]");
+
+# [perl #19048] Coredump in silly replacement
+{
+    local $^W = 0;
+    $_="abcdef\n";
+    s!.!!eg;
+    is($_, "\n", "[perl #19048]");
+}
+
+# [perl #17757] interaction between saw_ampersand and study
+{
+    my $f = eval q{ $& };
+    $f = "xx";
+    study $f;
+    $f =~ s/x/y/g;
+    is($f, "yy", "[perl #17757]");
+}
+
+# [perl #20684] returned a zero count
+$_ = "1111";
+is(s/(??{1})/2/eg, 4, '#20684 s/// with (??{..}) inside');
+
+# [perl #20682] @- not visible in replacement
+$_ = "123";
+/(2)/; # seed @- with something else
+s/(1)(2)(3)/$#- (@-)/;
+is($_, "3 (0 0 1 2)", '#20682 @- not visible in replacement');
+
+# [perl #20682] $^N not visible in replacement
+$_ = "abc";
+/(a)/; s/(b)|(c)/-$^N/g;
+is($_,'a-b-c','#20682 $^N not visible in replacement');
+
+# [perl #22351] perl bug with 'e' substitution modifier
+my $name = "chris";
+{
+    no warnings 'uninitialized';
+    $name =~ s/hr//e;
+}
+is($name, "cis", q[#22351 bug with 'e' substitution modifier]);