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