Add missing bug numbers

[perl5.git] / t / re / subst.t

diff --git a/t/re/subst.t b/t/re/subst.t
index 042f67a..91c757a 100644 (file)
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -7,7 +7,86 @@ BEGIN {
 }
 
 require './test.pl';
-plan( tests => 143 );
+plan( tests => 170 );
+
+# Stolen from re/ReTest.pl. Can't just use the file since it doesn't support
+# like() and it conflicts with test.pl
+sub must_warn {
+    my ($code, $pattern, $name) = @_;
+    my $w;
+    local $SIG {__WARN__} = sub {$w .= join "" => @_};
+    use warnings 'all';
+    ref $code ? &$code : eval $code;
+    my $r = $w && $w =~ /$pattern/;
+    $w //= "UNDEF";
+    ok( $r, $name // "Got warning /$pattern/", $r ? undef :
+            "# expected: /$pattern/\n" .
+            "#   result: $w" );
+}
+
+$_ = 'david';
+$a = s/david/rules/r;
+ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' );
+
+$a = "david" =~ s/david/rules/r;
+ok( $a eq 'rules', 's///r with constant' );
+
+$a = "david" =~ s/david/"is"."great"/er;
+ok( $a eq 'isgreat', 's///er' );
+
+$a = "daviddavid" =~ s/david/cool/gr;
+ok( $a eq 'coolcool', 's///gr' );
+
+$a = 'david';
+$b = $a =~ s/david/sucks/r =~ s/sucks/rules/r;
+ok( $a eq 'david' && $b eq 'rules', 'chained s///r' );
+
+$a = 'david';
+$b = $a =~ s/xxx/sucks/r;
+ok( $a eq 'david' && $b eq 'david', 'non matching s///r' );
+
+$a = 'david';
+for (0..2) {
+    ok( 'david' =~ s/$a/rules/ro eq 'rules', 's///ro '.$_ );
+}
+
+$a = 'david';
+eval '$b = $a !~ s/david/is great/r';
+like( $@, qr{Using !~ with s///r doesn't make sense}, 's///r !~ operator gives error' );
+
+{
+        no warnings 'uninitialized';
+        $a = undef;
+        $b = $a =~ s/left/right/r;
+        ok ( !defined $a && !defined $b, 's///r with undef input' );
+
+        use warnings;
+        must_warn sub { $b = $a =~ s/left/right/r }, '^Use of uninitialized value', 's///r Uninitialized warning';
+
+        $a = 'david';
+        must_warn 's/david/sucks/r; 1',    '^Useless use of Non-destructive substitution', 's///r void context warning';
+}
+
+$a = '';
+$b = $a =~ s/david/rules/r;
+ok( $a eq '' && $b eq '', 's///r on empty string' );
+
+$_ = 'david';
+@b = s/david/rules/r;
+ok( $_ eq 'david' && $b[0] eq 'rules', 's///r in list context' );
+
+# Magic value and s///r
+require Tie::Scalar;
+tie $m, 'Tie::StdScalar';  # makes $a magical
+$m = "david";
+$b = $m =~ s/david/rules/r;
+ok( $m eq 'david' && $b eq 'rules', 's///r with magic input' );
+
+$m = $b =~ s/rules/david/r;
+ok( defined tied($m), 's///r magic isn\'t lost' );
+
+$b = $m =~ s/xxx/yyy/r;
+ok( ! defined tied($b), 's///r magic isn\'t contagious' );
 
 $x = 'foo';
 $_ = "x";
@@ -598,7 +677,7 @@ is($name, "cis", q[#22351 bug with 'e' substitution modifier]);
 fresh_perl_is( '$_=q(foo);s/(.)\G//g;print' => 'foo', '[perl #69056] positive GPOS regex segfault' );
 fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'aXX[c-e][e-f]f', 'positive GPOS regex substitution failure' );
 
-# [perl #~~~~~] $var =~ s/$qr//e calling get-magic on $_ as well as $var
+# [perl #71470] $var =~ s/$qr//e calling get-magic on $_ as well as $var
 {
  local *_;
  my $scratch;
@@ -614,3 +693,34 @@ fresh_perl_is( '$_="abcef"; s/bc|(.)\G(.)/$1 ? "[$1-$2]" : "XX"/ge; print' => 'a
   'bug: $var =~ s/$qr//e calling get-magic on $_ as well as $var',
  );
 }
+
+{ # Bug #41530; replacing non-utf8 with a utf8 causes problems
+    my $string = "a\x{a0}a";
+    my $sub_string = $string;
+    ok(! utf8::is_utf8($sub_string), "Verify that string isn't initially utf8");
+    $sub_string =~ s/a/\x{100}/g;
+    ok(utf8::is_utf8($sub_string),
+                        'Verify replace of non-utf8 with utf8 upgrades to utf8');
+    is($sub_string, "\x{100}\x{A0}\x{100}",
+                            'Verify #41530 fixed: replace of non-utf8 with utf8');
+
+    my $non_sub_string = $string;
+    ok(! utf8::is_utf8($non_sub_string),
+                                    "Verify that string isn't initially utf8");
+    $non_sub_string =~ s/b/\x{100}/g;
+    ok(! utf8::is_utf8($non_sub_string),
+            "Verify that failed substitute doesn't change string's utf8ness");
+    is($non_sub_string, $string,
+                        "Verify that failed substitute doesn't change string");
+}
+
+{ # Verify largish octal in replacement pattern
+
+    my $string = "a";
+    $string =~ s/a/\400/;
+    is($string, chr 0x100, "Verify that handles s/foo/\\400/");
+    $string =~ s/./\600/;
+    is($string, chr 0x180, "Verify that handles s/foo/\\600/");
+    $string =~ s/./\777/;
+    is($string, chr 0x1FF, "Verify that handles s/foo/\\777/");
+}