X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ed6116ce9b9d13712ea252ee248b0400653db7f9..ba1129430d789b5089458f96b152e1635f5d15fc:/t/op/subst.t

diff --git a/t/op/subst.t b/t/op/subst.t
index 0f554b6..7dd7a1c 100755
--- a/t/op/subst.t
+++ b/t/op/subst.t
@@ -1,8 +1,12 @@
 #!./perl
 
-# $RCSfile: s.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:22 $
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require Config; import Config;
+}
 
-print "1..56\n";
+print "1..84\n";
 
 $x = 'foo';
 $_ = "x";
@@ -157,11 +161,11 @@ $x ne $x || s/bb/x/;
 print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
 
 $_ = 'abc123xyz';
-s/\d+/$&*2/e;              # yields 'abc246xyz'
+s/(\d+)/$1*2/e;              # yields 'abc246xyz'
 print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
-s/\d+/sprintf("%5d",$&)/e; # yields 'abc  246xyz'
+s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc  246xyz'
 print $_ eq 'abc  246xyz' ? "ok 41\n" : "not ok 41\n";
-s/\w/$& x 2/eg;            # yields 'aabbcc  224466xxyyzz'
+s/(\w)/$1 x 2/eg;            # yields 'aabbcc  224466xxyyzz'
 print $_ eq 'aabbcc  224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
 
 $_ = "aaaaa";
@@ -183,13 +187,22 @@ tr/a-z/A-Z/;
 print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n";
 
 # same as tr/A-Z/a-z/;
-y[\101-\132][\141-\172];
+if ($Config{ebcdic} eq 'define') {	# EBCDIC.
+    no utf8;
+    y[\301-\351][\201-\251];
+} else {		# Ye Olde ASCII.  Or something like it.
+    y[\101-\132][\141-\172];
+}
 
 print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n";
 
-$_ = '+,-';
-tr/+--/a-c/;
-print $_ eq 'abc' ? "ok 54\n" : "not ok 54\n";
+if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 &&
+    ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) {
+  $_ = '+,-';
+  tr/+--/a-c/;
+  print "not " unless $_ eq 'abc';
+}
+print "ok 54\n";
 
 $_ = '+,-';
 tr/+\--/a\/c/;
@@ -198,3 +211,171 @@ print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n";
 $_ = '+,-';
 tr/-+,/ab\-/;
 print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n";
+
+
+# test recursive substitutions
+# code based on the recursive expansion of makefile variables
+
+my %MK = (
+    AAAAA => '$(B)', B=>'$(C)', C => 'D',			# long->short
+    E     => '$(F)', F=>'p $(G) q', G => 'HHHHH',	# short->long
+    DIR => '$(UNDEFINEDNAME)/xxx',
+);
+sub var { 
+    my($var,$level) = @_;
+    return "\$($var)" unless exists $MK{$var};
+    return exp_vars($MK{$var}, $level+1); # can recurse
+}
+sub exp_vars { 
+    my($str,$level) = @_;
+    $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse
+    #warn "exp_vars $level = '$str'\n";
+    $str;
+}
+
+print exp_vars('$(AAAAA)',0)           eq 'D'
+	? "ok 57\n" : "not ok 57\n";
+print exp_vars('$(E)',0)               eq 'p HHHHH q'
+	? "ok 58\n" : "not ok 58\n";
+print exp_vars('$(DIR)',0)             eq '$(UNDEFINEDNAME)/xxx'
+	? "ok 59\n" : "not ok 59\n";
+print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar'
+	? "ok 60\n" : "not ok 60\n";
+
+# a match nested in the RHS of a substitution:
+
+$_ = "abcd";
+s/(..)/$x = $1, m#.#/eg;
+print $x eq "cd" ? "ok 61\n" : "not ok 61\n";
+
+# Subst and lookbehind
+
+$_="ccccc";
+s/(?<!x)c/x/g;
+print $_ eq "xxxxx" ? "ok 62\n" : "not ok 62 # `$_' ne `xxxxx'\n";
+
+$_="ccccc";
+s/(?<!x)(c)/x/g;
+print $_ eq "xxxxx" ? "ok 63\n" : "not ok 63 # `$_' ne `xxxxx'\n";
+
+$_="foobbarfoobbar";
+s/(?<!r)foobbar/foobar/g;
+print $_ eq "foobarfoobbar" ? "ok 64\n" : "not ok 64 # `$_' ne `foobarfoobbar'\n";
+
+$_="foobbarfoobbar";
+s/(?<!ar)(foobbar)/foobar/g;
+print $_ eq "foobarfoobbar" ? "ok 65\n" : "not ok 65 # `$_' ne `foobarfoobbar'\n";
+
+$_="foobbarfoobbar";
+s/(?<!ar)foobbar/foobar/g;
+print $_ eq "foobarfoobbar" ? "ok 66\n" : "not ok 66 # `$_' ne `foobarfoobbar'\n";
+
+# check parsing of split subst with comment
+eval 's{foo} # this is a comment, not a delimiter
+       {bar};';
+print @? ? "not ok 67\n" : "ok 67\n";
+
+# check if squashing works at the end of string
+$_="baacbaa";
+tr/a/b/s;
+print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n";
+
+# XXX TODO: Most tests above don't test return values of the ops. They should.
+$_ = "ab";
+print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n");
+
+$_ = <<'EOL';
+     $url = new URI::URL "http://www/";   die if $url eq "xXx";
+EOL
+$^R = 'junk';
+
+$foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' .
+  ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' .
+  ' lowercase $@%#MiXeD$@%# ';
+
+s{  \d+          \b [,.;]? (?{ 'digits' })
+   |
+    [a-z]+       \b [,.;]? (?{ 'lowercase' })
+   |
+    [A-Z]+       \b [,.;]? (?{ 'UPPERCASE' })
+   |
+    [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' })
+   |
+    [A-Za-z]+    \b [,.;]? (?{ 'MiXeD' })
+   |
+    [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' })
+   |
+    \s+                    (?{ ' ' })
+   |
+    [^A-Za-z0-9\s]+          (?{ '$@%#' })
+}{$^R}xg;
+print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n");
+
+$_ = 'x' x 20; 
+s/(\d*|x)/<$1>/g; 
+$foo = '<>' . ('<x><>' x 20) ;
+print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n");
+
+$t = 'aaaaaaaaa'; 
+
+$_ = $t;
+pos = 6;
+s/\Ga/xx/g;
+print "not " unless $_ eq 'aaaaaaxxxxxx';
+print "ok 72\n";
+
+$_ = $t;
+pos = 6;
+s/\Ga/x/g;
+print "not " unless $_ eq 'aaaaaaxxx';
+print "ok 73\n";
+
+$_ = $t;
+pos = 6;
+s/\Ga/xx/;
+print "not " unless $_ eq 'aaaaaaxxaa';
+print "ok 74\n";
+
+$_ = $t;
+pos = 6;
+s/\Ga/x/;
+print "not " unless $_ eq 'aaaaaaxaa';
+print "ok 75\n";
+
+$_ = $t;
+s/\Ga/xx/g;
+print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx';
+print "ok 76\n";
+
+$_ = $t;
+s/\Ga/x/g;
+print "not " unless $_ eq 'xxxxxxxxx';
+print "ok 77\n";
+
+$_ = $t;
+s/\Ga/xx/;
+print "not " unless $_ eq 'xxaaaaaaaa';
+print "ok 78\n";
+
+$_ = $t;
+s/\Ga/x/;
+print "not " unless $_ eq 'xaaaaaaaa';
+print "ok 79\n";
+
+$_ = 'aaaa';
+s/\ba/./g;
+print "#'$_'\nnot " unless $_ eq '.aaa';
+print "ok 80\n";
+
+eval q% s/a/"b"}/e %;
+print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n");
+eval q% ($_ = "x") =~ s/(.)/"$1 "/e %;
+print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n";
+$x = $x = 'interp';
+eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %;
+print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n";
+
+$_ = "C:/";
+s/^([a-z]:)/\u$1/ and print "not ";
+print "ok 84\n";
+