#!./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..67\n";
+print "1..84\n";
$x = 'foo';
$_ = "x";
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/;
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";
+