| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require Config; import Config; |
| 7 | } |
| 8 | |
| 9 | print "1..84\n"; |
| 10 | |
| 11 | $x = 'foo'; |
| 12 | $_ = "x"; |
| 13 | s/x/\$x/; |
| 14 | print "#1\t:$_: eq :\$x:\n"; |
| 15 | if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";} |
| 16 | |
| 17 | $_ = "x"; |
| 18 | s/x/$x/; |
| 19 | print "#2\t:$_: eq :foo:\n"; |
| 20 | if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";} |
| 21 | |
| 22 | $_ = "x"; |
| 23 | s/x/\$x $x/; |
| 24 | print "#3\t:$_: eq :\$x foo:\n"; |
| 25 | if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";} |
| 26 | |
| 27 | $b = 'cd'; |
| 28 | ($a = 'abcdef') =~ s<(b${b}e)>'\n$1'; |
| 29 | print "#4\t:$1: eq :bcde:\n"; |
| 30 | print "#4\t:$a: eq :a\\n\$1f:\n"; |
| 31 | if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";} |
| 32 | |
| 33 | $a = 'abacada'; |
| 34 | if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx') |
| 35 | {print "ok 5\n";} else {print "not ok 5\n";} |
| 36 | |
| 37 | if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx') |
| 38 | {print "ok 6\n";} else {print "not ok 6 $a\n";} |
| 39 | |
| 40 | if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx') |
| 41 | {print "ok 7\n";} else {print "not ok 7 $a\n";} |
| 42 | |
| 43 | $_ = 'ABACADA'; |
| 44 | if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";} |
| 45 | |
| 46 | $_ = '\\' x 4; |
| 47 | if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";} |
| 48 | s/\\/\\\\/g; |
| 49 | if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";} |
| 50 | |
| 51 | $_ = '\/' x 4; |
| 52 | if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";} |
| 53 | s/\//\/\//g; |
| 54 | if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";} |
| 55 | if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";} |
| 56 | |
| 57 | $_ = 'aaaXXXXbbb'; |
| 58 | s/^a//; |
| 59 | print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n"; |
| 60 | |
| 61 | $_ = 'aaaXXXXbbb'; |
| 62 | s/a//; |
| 63 | print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n"; |
| 64 | |
| 65 | $_ = 'aaaXXXXbbb'; |
| 66 | s/^a/b/; |
| 67 | print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n"; |
| 68 | |
| 69 | $_ = 'aaaXXXXbbb'; |
| 70 | s/a/b/; |
| 71 | print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n"; |
| 72 | |
| 73 | $_ = 'aaaXXXXbbb'; |
| 74 | s/aa//; |
| 75 | print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n"; |
| 76 | |
| 77 | $_ = 'aaaXXXXbbb'; |
| 78 | s/aa/b/; |
| 79 | print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n"; |
| 80 | |
| 81 | $_ = 'aaaXXXXbbb'; |
| 82 | s/b$//; |
| 83 | print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n"; |
| 84 | |
| 85 | $_ = 'aaaXXXXbbb'; |
| 86 | s/b//; |
| 87 | print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n"; |
| 88 | |
| 89 | $_ = 'aaaXXXXbbb'; |
| 90 | s/bb//; |
| 91 | print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n"; |
| 92 | |
| 93 | $_ = 'aaaXXXXbbb'; |
| 94 | s/aX/y/; |
| 95 | print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n"; |
| 96 | |
| 97 | $_ = 'aaaXXXXbbb'; |
| 98 | s/Xb/z/; |
| 99 | print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n"; |
| 100 | |
| 101 | $_ = 'aaaXXXXbbb'; |
| 102 | s/aaX.*Xbb//; |
| 103 | print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n"; |
| 104 | |
| 105 | $_ = 'aaaXXXXbbb'; |
| 106 | s/bb/x/; |
| 107 | print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n"; |
| 108 | |
| 109 | # now for some unoptimized versions of the same. |
| 110 | |
| 111 | $_ = 'aaaXXXXbbb'; |
| 112 | $x ne $x || s/^a//; |
| 113 | print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n"; |
| 114 | |
| 115 | $_ = 'aaaXXXXbbb'; |
| 116 | $x ne $x || s/a//; |
| 117 | print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n"; |
| 118 | |
| 119 | $_ = 'aaaXXXXbbb'; |
| 120 | $x ne $x || s/^a/b/; |
| 121 | print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n"; |
| 122 | |
| 123 | $_ = 'aaaXXXXbbb'; |
| 124 | $x ne $x || s/a/b/; |
| 125 | print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n"; |
| 126 | |
| 127 | $_ = 'aaaXXXXbbb'; |
| 128 | $x ne $x || s/aa//; |
| 129 | print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n"; |
| 130 | |
| 131 | $_ = 'aaaXXXXbbb'; |
| 132 | $x ne $x || s/aa/b/; |
| 133 | print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n"; |
| 134 | |
| 135 | $_ = 'aaaXXXXbbb'; |
| 136 | $x ne $x || s/b$//; |
| 137 | print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n"; |
| 138 | |
| 139 | $_ = 'aaaXXXXbbb'; |
| 140 | $x ne $x || s/b//; |
| 141 | print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n"; |
| 142 | |
| 143 | $_ = 'aaaXXXXbbb'; |
| 144 | $x ne $x || s/bb//; |
| 145 | print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n"; |
| 146 | |
| 147 | $_ = 'aaaXXXXbbb'; |
| 148 | $x ne $x || s/aX/y/; |
| 149 | print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n"; |
| 150 | |
| 151 | $_ = 'aaaXXXXbbb'; |
| 152 | $x ne $x || s/Xb/z/; |
| 153 | print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n"; |
| 154 | |
| 155 | $_ = 'aaaXXXXbbb'; |
| 156 | $x ne $x || s/aaX.*Xbb//; |
| 157 | print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n"; |
| 158 | |
| 159 | $_ = 'aaaXXXXbbb'; |
| 160 | $x ne $x || s/bb/x/; |
| 161 | print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n"; |
| 162 | |
| 163 | $_ = 'abc123xyz'; |
| 164 | s/(\d+)/$1*2/e; # yields 'abc246xyz' |
| 165 | print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n"; |
| 166 | s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc 246xyz' |
| 167 | print $_ eq 'abc 246xyz' ? "ok 41\n" : "not ok 41\n"; |
| 168 | s/(\w)/$1 x 2/eg; # yields 'aabbcc 224466xxyyzz' |
| 169 | print $_ eq 'aabbcc 224466xxyyzz' ? "ok 42\n" : "not ok 42\n"; |
| 170 | |
| 171 | $_ = "aaaaa"; |
| 172 | print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n"; |
| 173 | print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n"; |
| 174 | print y/b// == 5 ? "ok 45\n" : "not ok 45\n"; |
| 175 | print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n"; |
| 176 | print y/c// == 1 ? "ok 47\n" : "not ok 47\n"; |
| 177 | print y/c//d == 1 ? "ok 48\n" : "not ok 48\n"; |
| 178 | print $_ eq "" ? "ok 49\n" : "not ok 49\n"; |
| 179 | |
| 180 | $_ = "Now is the %#*! time for all good men..."; |
| 181 | print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n"); |
| 182 | print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n"; |
| 183 | |
| 184 | $_ = 'abcdefghijklmnopqrstuvwxyz0123456789'; |
| 185 | tr/a-z/A-Z/; |
| 186 | |
| 187 | print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; |
| 188 | |
| 189 | # same as tr/A-Z/a-z/; |
| 190 | if ($Config{ebcdic} eq 'define') { # EBCDIC. |
| 191 | no utf8; |
| 192 | y[\301-\351][\201-\251]; |
| 193 | } else { # Ye Olde ASCII. Or something like it. |
| 194 | y[\101-\132][\141-\172]; |
| 195 | } |
| 196 | |
| 197 | print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n"; |
| 198 | |
| 199 | if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 && |
| 200 | ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) { |
| 201 | $_ = '+,-'; |
| 202 | tr/+--/a-c/; |
| 203 | print "not " unless $_ eq 'abc'; |
| 204 | } |
| 205 | print "ok 54\n"; |
| 206 | |
| 207 | $_ = '+,-'; |
| 208 | tr/+\--/a\/c/; |
| 209 | print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n"; |
| 210 | |
| 211 | $_ = '+,-'; |
| 212 | tr/-+,/ab\-/; |
| 213 | print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n"; |
| 214 | |
| 215 | |
| 216 | # test recursive substitutions |
| 217 | # code based on the recursive expansion of makefile variables |
| 218 | |
| 219 | my %MK = ( |
| 220 | AAAAA => '$(B)', B=>'$(C)', C => 'D', # long->short |
| 221 | E => '$(F)', F=>'p $(G) q', G => 'HHHHH', # short->long |
| 222 | DIR => '$(UNDEFINEDNAME)/xxx', |
| 223 | ); |
| 224 | sub var { |
| 225 | my($var,$level) = @_; |
| 226 | return "\$($var)" unless exists $MK{$var}; |
| 227 | return exp_vars($MK{$var}, $level+1); # can recurse |
| 228 | } |
| 229 | sub exp_vars { |
| 230 | my($str,$level) = @_; |
| 231 | $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse |
| 232 | #warn "exp_vars $level = '$str'\n"; |
| 233 | $str; |
| 234 | } |
| 235 | |
| 236 | print exp_vars('$(AAAAA)',0) eq 'D' |
| 237 | ? "ok 57\n" : "not ok 57\n"; |
| 238 | print exp_vars('$(E)',0) eq 'p HHHHH q' |
| 239 | ? "ok 58\n" : "not ok 58\n"; |
| 240 | print exp_vars('$(DIR)',0) eq '$(UNDEFINEDNAME)/xxx' |
| 241 | ? "ok 59\n" : "not ok 59\n"; |
| 242 | print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar' |
| 243 | ? "ok 60\n" : "not ok 60\n"; |
| 244 | |
| 245 | # a match nested in the RHS of a substitution: |
| 246 | |
| 247 | $_ = "abcd"; |
| 248 | s/(..)/$x = $1, m#.#/eg; |
| 249 | print $x eq "cd" ? "ok 61\n" : "not ok 61\n"; |
| 250 | |
| 251 | # Subst and lookbehind |
| 252 | |
| 253 | $_="ccccc"; |
| 254 | s/(?<!x)c/x/g; |
| 255 | print $_ eq "xxxxx" ? "ok 62\n" : "not ok 62 # `$_' ne `xxxxx'\n"; |
| 256 | |
| 257 | $_="ccccc"; |
| 258 | s/(?<!x)(c)/x/g; |
| 259 | print $_ eq "xxxxx" ? "ok 63\n" : "not ok 63 # `$_' ne `xxxxx'\n"; |
| 260 | |
| 261 | $_="foobbarfoobbar"; |
| 262 | s/(?<!r)foobbar/foobar/g; |
| 263 | print $_ eq "foobarfoobbar" ? "ok 64\n" : "not ok 64 # `$_' ne `foobarfoobbar'\n"; |
| 264 | |
| 265 | $_="foobbarfoobbar"; |
| 266 | s/(?<!ar)(foobbar)/foobar/g; |
| 267 | print $_ eq "foobarfoobbar" ? "ok 65\n" : "not ok 65 # `$_' ne `foobarfoobbar'\n"; |
| 268 | |
| 269 | $_="foobbarfoobbar"; |
| 270 | s/(?<!ar)foobbar/foobar/g; |
| 271 | print $_ eq "foobarfoobbar" ? "ok 66\n" : "not ok 66 # `$_' ne `foobarfoobbar'\n"; |
| 272 | |
| 273 | # check parsing of split subst with comment |
| 274 | eval 's{foo} # this is a comment, not a delimiter |
| 275 | {bar};'; |
| 276 | print @? ? "not ok 67\n" : "ok 67\n"; |
| 277 | |
| 278 | # check if squashing works at the end of string |
| 279 | $_="baacbaa"; |
| 280 | tr/a/b/s; |
| 281 | print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n"; |
| 282 | |
| 283 | # XXX TODO: Most tests above don't test return values of the ops. They should. |
| 284 | $_ = "ab"; |
| 285 | print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n"); |
| 286 | |
| 287 | $_ = <<'EOL'; |
| 288 | $url = new URI::URL "http://www/"; die if $url eq "xXx"; |
| 289 | EOL |
| 290 | $^R = 'junk'; |
| 291 | |
| 292 | $foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' . |
| 293 | ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' . |
| 294 | ' lowercase $@%#MiXeD$@%# '; |
| 295 | |
| 296 | s{ \d+ \b [,.;]? (?{ 'digits' }) |
| 297 | | |
| 298 | [a-z]+ \b [,.;]? (?{ 'lowercase' }) |
| 299 | | |
| 300 | [A-Z]+ \b [,.;]? (?{ 'UPPERCASE' }) |
| 301 | | |
| 302 | [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' }) |
| 303 | | |
| 304 | [A-Za-z]+ \b [,.;]? (?{ 'MiXeD' }) |
| 305 | | |
| 306 | [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' }) |
| 307 | | |
| 308 | \s+ (?{ ' ' }) |
| 309 | | |
| 310 | [^A-Za-z0-9\s]+ (?{ '$@%#' }) |
| 311 | }{$^R}xg; |
| 312 | print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n"); |
| 313 | |
| 314 | $_ = 'x' x 20; |
| 315 | s/(\d*|x)/<$1>/g; |
| 316 | $foo = '<>' . ('<x><>' x 20) ; |
| 317 | print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); |
| 318 | |
| 319 | $t = 'aaaaaaaaa'; |
| 320 | |
| 321 | $_ = $t; |
| 322 | pos = 6; |
| 323 | s/\Ga/xx/g; |
| 324 | print "not " unless $_ eq 'aaaaaaxxxxxx'; |
| 325 | print "ok 72\n"; |
| 326 | |
| 327 | $_ = $t; |
| 328 | pos = 6; |
| 329 | s/\Ga/x/g; |
| 330 | print "not " unless $_ eq 'aaaaaaxxx'; |
| 331 | print "ok 73\n"; |
| 332 | |
| 333 | $_ = $t; |
| 334 | pos = 6; |
| 335 | s/\Ga/xx/; |
| 336 | print "not " unless $_ eq 'aaaaaaxxaa'; |
| 337 | print "ok 74\n"; |
| 338 | |
| 339 | $_ = $t; |
| 340 | pos = 6; |
| 341 | s/\Ga/x/; |
| 342 | print "not " unless $_ eq 'aaaaaaxaa'; |
| 343 | print "ok 75\n"; |
| 344 | |
| 345 | $_ = $t; |
| 346 | s/\Ga/xx/g; |
| 347 | print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx'; |
| 348 | print "ok 76\n"; |
| 349 | |
| 350 | $_ = $t; |
| 351 | s/\Ga/x/g; |
| 352 | print "not " unless $_ eq 'xxxxxxxxx'; |
| 353 | print "ok 77\n"; |
| 354 | |
| 355 | $_ = $t; |
| 356 | s/\Ga/xx/; |
| 357 | print "not " unless $_ eq 'xxaaaaaaaa'; |
| 358 | print "ok 78\n"; |
| 359 | |
| 360 | $_ = $t; |
| 361 | s/\Ga/x/; |
| 362 | print "not " unless $_ eq 'xaaaaaaaa'; |
| 363 | print "ok 79\n"; |
| 364 | |
| 365 | $_ = 'aaaa'; |
| 366 | s/\ba/./g; |
| 367 | print "#'$_'\nnot " unless $_ eq '.aaa'; |
| 368 | print "ok 80\n"; |
| 369 | |
| 370 | eval q% s/a/"b"}/e %; |
| 371 | print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n"); |
| 372 | eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; |
| 373 | print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n"; |
| 374 | $x = $x = 'interp'; |
| 375 | eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; |
| 376 | print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; |
| 377 | |
| 378 | $_ = "C:/"; |
| 379 | s/^([a-z]:)/\u$1/ and print "not "; |
| 380 | print "ok 84\n"; |
| 381 | |