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