X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/139a998acd6eae73587ff4f048925394f73682d9..b3de960c9ad0e39d5eff1c56932c46850c862067:/t/re/subst.t

diff --git a/t/re/subst.t b/t/re/subst.t
index f2bf0a2..334d6ad 100644
--- a/t/re/subst.t
+++ b/t/re/subst.t
@@ -5,11 +5,13 @@ BEGIN {
     require './test.pl';
     set_up_inc('../lib');
     require Config; import Config;
+    require constant;
+    constant->import(constcow => *Config::{NAME});
     require './charset_tools.pl';
     require './loc_tools.pl';
 }
 
-plan( tests => 267 );
+plan( tests => 274 );
 
 $_ = 'david';
 $a = s/david/rules/r;
@@ -18,6 +20,11 @@ ok( $_ eq 'david' && $a eq 'rules', 'non-destructive substitute' );
 $a = "david" =~ s/david/rules/r;
 ok( $a eq 'rules', 's///r with constant' );
 
+#[perl #127635] failed with -DPERL_NO_COW perl build (George smoker uses flag)
+#Modification of a read-only value attempted at ../t/re/subst.t line 23.
+$a = constcow =~ s/Config/David/r;
+ok( $a eq 'David::', 's///r with COW constant' );
+
 $a = "david" =~ s/david/"is"."great"/er;
 ok( $a eq 'isgreat', 's///er' );
 
@@ -265,10 +272,10 @@ if (defined $Config{ebcdic} && $Config{ebcdic} eq 'define') {	# EBCDIC.
 ok( $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' );
 
 SKIP: {
-    skip("not ASCII",1) unless (ord("+") == ord(",") - 1
-			     && ord(",") == ord("-") - 1
-			     && ord("a") == ord("b") - 1
-			     && ord("b") == ord("c") - 1);
+    skip("ASCII-centric test",1) unless (ord("+") == ord(",") - 1
+			              && ord(",") == ord("-") - 1
+			              && ord("a") == ord("b") - 1
+			              && ord("b") == ord("c") - 1);
     $_ = '+,-';
     tr/+--/a-c/;
     ok( $_ eq 'abc' );
@@ -458,9 +465,7 @@ $pv1 =~ s/A/\x{100}/;
 substr($pv2,0,1) = "\x{100}";
 is($pv1, $pv2);
 
-SKIP: {
-    skip("EBCDIC", 3) if ord("A") == 193; 
-
+{
     {   
 	# Gregor Chrupala <gregor.chrupala@star-group.net>
 	use utf8;
@@ -991,7 +996,7 @@ SKIP:{
 	/e;
     };
     is $locker{key}, '3', 'locking target in $hash{key} =~ s//.../e';
-    like $@, qr/^Modification of a read-only value/, 'err msg';
+    like $@, qr/^Modification of a read-only value/, 'err msg' . ($@ ? ": $@" : "");
 }
 delete $::{does_not_exist}; # just in case
 eval { no warnings; $::{does_not_exist}=~s/(?:)/*{"does_not_exist"}; 4/e };
@@ -1080,3 +1085,69 @@ SKIP: {
     $s1 =~ s/.?/$s1++/ge;
     is($s1, "01","RT #123954 s1");
 }
+{
+    # RT #126602 double free if the value being modified is freed in the replacement
+    fresh_perl_is('s//*_=0;s|0||;00.y0/e; print qq(ok\n)', "ok\n", { stderr => 1 },
+                  "[perl #126602] s//*_=0;s|0||/e crashes");
+}
+
+{
+    #RT 126260 gofs is in chars, not bytes
+
+    # in something like /..\G/, the engine should start matching two
+    # chars before pos(). At one point it was matching two bytes before.
+
+    my $s = "\x{121}\x{122}\x{123}";
+    pos($s) = 2;
+    $s =~ s/..\G//g;
+    is($s, "\x{123}", "#RT 126260 gofs");
+}
+
+SKIP: {
+    if (! locales_enabled('LC_CTYPE')) {
+        skip "Can't test locale", 1;
+    }
+
+    #  To cause breakeage, we need a locale in which \xff matches whatever
+    #  POSIX class is used in the pattern.  Easiest is C, with \W.
+    fresh_perl_is('    use POSIX qw(locale_h);
+                       setlocale(&POSIX::LC_CTYPE, "C");
+                       my $s = "\xff";
+                       $s =~ s/\W//l;
+                       print qq(ok$s\n)',
+                   "ok\n",
+                   {stderr => 1 },
+                   '[perl #129038 ] s/\xff//l no longer crashes');
+}
+
+ SKIP: {
+    skip("no Tie::Hash::NamedCapture under miniperl", 3) if is_miniperl;
+
+    # RT #23624 scoping of @+/@- when used with tie()
+    #! /usr/bin/perl -w
+
+    package Tie::Prematch;
+    sub TIEHASH { bless \my $dummy => __PACKAGE__ }
+    sub FETCH   { return substr $_[1], 0, $-[0] }
+
+    package main;
+
+    eval <<'__EOF__';
+    tie my %pre, 'Tie::Prematch';
+    my $foo = 'foobar';
+    $foo =~ s/.ob/$pre{ $foo }/;
+    is($foo, 'ffar', 'RT #23624');
+
+    $foo = 'foobar';
+    $foo =~ s/.ob/tied(%pre)->FETCH($foo)/e;
+    is($foo, 'ffar', 'RT #23624');
+
+    tie %-, 'Tie::Prematch';
+    $foo = 'foobar';
+    $foo =~ s/.ob/$-{$foo}/;
+    is($foo, 'ffar', 'RT #23624');
+
+    undef *Tie::Prematch::TIEHASH;
+    undef *Tie::Prematch::FETCH;
+__EOF__
+}