This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Commit 6b00f562ed broke s/${\%x}{3}//e
[perl5.git] / t / base / lex.t
1 #!./perl
2
3 print "1..73\n";
4
5 $x = 'x';
6
7 print "#1       :$x: eq :x:\n";
8 if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
9
10 $x = $#[0];
11
12 if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
13
14 $x = $#x;
15
16 if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
17
18 $x = '\\'; # ';
19
20 if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
21
22 eval 'while (0) {
23     print "foo\n";
24 }
25 /^/ && (print "ok 5\n");
26 ';
27
28 eval '$foo{1} / 1;';
29 if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";}
30
31 eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
32
33 $foo = int($foo * 100 + .5);
34 if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";}
35
36 print <<'EOF';
37 ok 8
38 EOF
39
40 $foo = 'ok 9';
41 print <<EOF;
42 $foo
43 EOF
44
45 eval <<\EOE, print $@;
46 print <<'EOF';
47 ok 10
48 EOF
49
50 $foo = 'ok 11';
51 print <<EOF;
52 $foo
53 EOF
54 EOE
55
56 print <<'EOS' . <<\EOF;
57 ok 12 - make sure single quotes are honored \nnot ok
58 EOS
59 ok 13
60 EOF
61
62 print qq/ok 14\n/;
63 print qq(ok 15\n);
64
65 print qq
66 [ok 16\n]
67 ;
68
69 print q<ok 17
70 >;
71
72 print "ok 18 - was the test for the deprecated use of bare << to mean <<\"\"\n";
73 #print <<;   # Yow!
74 #ok 18
75 #
76 ## previous line intentionally left blank.
77
78 print <<E1 eq "foo\n\n" ? "ok 19\n" : "not ok 19\n";
79 @{[ <<E2 ]}
80 foo
81 E2
82 E1
83
84 print <<E1 eq "foo\n\n" ? "ok 20\n" : "not ok 20\n";
85 @{[
86   <<E2
87 foo
88 E2
89 ]}
90 E1
91
92 $foo = FOO;
93 $bar = BAR;
94 $foo{$bar} = BAZ;
95 $ary[0] = ABC;
96
97 print "$foo{$bar}" eq "BAZ" ? "ok 21\n" : "not ok 21\n";
98
99 print "${foo}{$bar}" eq "FOO{BAR}" ? "ok 22\n" : "not ok 22\n";
100 print "${foo{$bar}}" eq "BAZ" ? "ok 23\n" : "not ok 23\n";
101
102 print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n";
103 print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n";
104 print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n";
105
106 # MJD 19980425
107 ($X, @X) = qw(a b c d); 
108 print "d" =~ /^$X[-1]$/ ? "ok 27\n" : "not ok 27\n";
109 print "a1" !~ /^$X[-1]$/ ? "ok 28\n" : "not ok 28\n";
110
111 print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 29\n" : "not ok 29\n");
112
113
114 $foo = "not ok 30\n";
115 $foo =~ s/^not /substr(<<EOF, 0, 0)/e;
116   Ignored
117 EOF
118 print $foo;
119
120 # Tests for new extended control-character variables
121 # MJD 19990227
122
123 { my $CX = "\cX";
124   my $CXY  ="\cXY";
125   $ {$CX} = 17;
126   $ {$CXY} = 23;
127   if ($ {^XY} != 23) { print "not "  }
128   print "ok 31\n";
129  
130 # Does the syntax where we use the literal control character still work?
131   if (eval "\$ {\cX}" != 17 or $@) { print "not "  }
132   print "ok 32\n";
133
134   eval "\$\cQ = 24";                 # Literal control character
135   if ($@ or ${"\cQ"} != 24) {  print "not "  }
136   print "ok 33\n";
137   if ($^Q != 24) {  print "not "  }  # Control character escape sequence
138   print "ok 34\n";
139
140 # Does the old UNBRACED syntax still do what it used to?
141   if ("$^XY" ne "17Y") { print "not " }
142   print "ok 35\n";
143
144   sub XX () { 6 }
145   $ {"\cQ\cXX"} = 119; 
146   $^Q = 5; #  This should be an unused ^Var.
147   $N = 5;
148   # The second caret here should be interpreted as an xor
149   if (($^Q^XX) != 3) { print "not " } 
150   print "ok 36\n";
151 #  if (($N  ^  XX()) != 3) { print "not " } 
152 #  print "ok 32\n";
153
154   # These next two tests are trying to make sure that
155   # $^FOO is always global; it doesn't make sense to 'my' it.
156   # 
157
158   eval 'my $^X;';
159   print "not " unless index ($@, 'Can\'t use global $^X in "my"') > -1;
160   print "ok 37\n";
161 #  print "($@)\n" if $@;
162
163   eval 'my $ {^XYZ};';
164   print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
165   print "ok 38\n";
166 #  print "($@)\n" if $@;
167
168 # Now let's make sure that caret variables are all forced into the main package.
169   package Someother;
170   $^Q = 'Someother';
171   $ {^Quixote} = 'Someother 2';
172   $ {^M} = 'Someother 3';
173   package main;
174   print "not " unless $^Q eq 'Someother';
175   print "ok 39\n";
176   print "not " unless $ {^Quixote} eq 'Someother 2';
177   print "ok 40\n";
178   print "not " unless $ {^M} eq 'Someother 3';
179   print "ok 41\n";
180
181   
182 }
183
184 # see if eval '', s///e, and heredocs mix
185
186 sub T {
187     my ($where, $num) = @_;
188     my ($p,$f,$l) = caller;
189     print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/;
190     print "ok $num\n";
191 }
192
193 my $test = 42;
194
195 {
196 # line 42 "plink"
197     local $_ = "not ok ";
198     eval q{
199         s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++;
200 # uggedaboudit
201 EOT
202         print $_, $test++, "\n";
203         T('^main:\(eval \d+\):6$', $test++);
204 # line 1 "plunk"
205         T('^main:plunk:1$', $test++);
206     };
207     print "# $@\nnot ok $test\n" if $@;
208     T '^main:plink:53$', $test++;
209 }
210
211 # tests 47--51 start here
212 # tests for new array interpolation semantics:
213 # arrays now *always* interpolate into "..." strings.
214 # 20000522 MJD (mjd@plover.com)
215 {
216   my $test = 47;
217   eval(q(">@nosuch<" eq "><")) || print "# $@", "not ";
218   print "ok $test\n";
219   ++$test;
220
221   # Look at this!  This is going to be a common error in the future:
222   eval(q("fred@example.com" eq "fred.com")) || print "# $@", "not ";
223   print "ok $test\n";
224   ++$test;
225
226   # Let's make sure that normal array interpolation still works right
227   # For some reason, this appears not to be tested anywhere else.
228   my @a = (1,2,3);
229   print +((">@a<" eq ">1 2 3<") ? '' : 'not '), "ok $test\n";
230   ++$test;
231
232   # Ditto.
233   eval(q{@nosuch = ('a', 'b', 'c'); ">@nosuch<" eq ">a b c<"}) 
234       || print "# $@", "not ";
235   print "ok $test\n";
236   ++$test;
237
238   # This isn't actually a lex test, but it's testing the same feature
239   sub makearray {
240     my @array = ('fish', 'dog', 'carrot');
241     *R::crackers = \@array;
242   }
243
244   eval(q{makearray(); ">@R::crackers<" eq ">fish dog carrot<"})
245     || print "# $@", "not ";
246   print "ok $test\n";
247   ++$test;
248 }
249
250 # Tests 52-54
251 # => should only quote foo::bar if it isn't a real sub. AMS, 20010621
252
253 sub xyz::foo { "bar" }
254 my %str = (
255     foo      => 1,
256     xyz::foo => 1,
257     xyz::bar => 1,
258 );
259
260 my $test = 52;
261 print ((exists $str{foo}      ? "" : "not ")."ok $test\n"); ++$test;
262 print ((exists $str{bar}      ? "" : "not ")."ok $test\n"); ++$test;
263 print ((exists $str{xyz::bar} ? "" : "not ")."ok $test\n"); ++$test;
264
265 sub foo::::::bar { print "ok $test\n"; $test++ }
266 foo::::::bar;
267
268 eval "\$x =\xE2foo";
269 if ($@ =~ /Unrecognized character \\xE2; marked by <-- HERE after \$x =<-- HERE near column 5/) { print "ok $test\n"; } else { print "not ok $test\n"; }
270 $test++;
271
272 # Is "[~" scanned correctly?
273 @a = (1,2,3);
274 print "not " unless($a[~~2] == 3);
275 print "ok 57\n";
276
277 $_ = "";
278 eval 's/(?:)/"${\q||}".<<\END/e;
279 ok 58 - heredoc after "" in s/// in eval
280 END
281 ';
282 print $_ || "not ok 58\n";
283
284 $_ = "";
285 eval 's|(?:)|"${\<<\END}"
286 ok 59 - heredoc in "" in multiline s///e in eval
287 END
288 |e
289 ';
290 print $_ || "not ok 59\n";
291
292 $_ = "";
293 eval "s/(?:)/<<foo/e #\0
294 ok 60 - null on same line as heredoc in s/// in eval
295 foo
296 ";
297 print $_ || "not ok 60\n";
298
299 $_ = "";
300 eval ' s/(?:)/"${\<<END}"/e;
301 ok 61 - heredoc in "" in single-line s///e in eval
302 END
303 ';
304 print $_ || "not ok 61\n";
305
306 $_ = "";
307 s|(?:)|"${\<<END}"
308 ok 62 - heredoc in "" in multiline s///e outside eval
309 END
310 |e;
311 print $_ || "not ok 62\n";
312
313 $_ = "not ok 63 - s/// in s/// pattern\n";
314 s/${s|||;\""}not //;
315 print;
316
317 /(?{print <<END
318 ok 64 - here-doc in re-eval
319 END
320 })/;
321
322 eval '/(?{print <<END
323 ok 65 - here-doc in re-eval in string eval
324 END
325 })/';
326
327 eval 'print qq ;ok 66 - eval ending with semicolon\n;'
328   or print "not ok 66 - eval ending with semicolon\n";
329
330 print "not " unless qr/(?{<<END})/ eq '(?^:(?{<<END}))';
331 foo
332 END
333 print "ok 67 - here-doc in single-line re-eval\n";
334
335 $_ = qr/(?{"${<<END}"
336 foo
337 END
338 })/;
339 print "not " unless /foo/;
340 print "ok 68 - here-doc in quotes in multiline re-eval\n";
341
342 eval 's//<<END/e if 0; $_ = "a
343 END
344 b"';
345 print "not " if $_ =~ /\n\n/;
346 print "ok 69 - eval 's//<<END/' does not leave extra newlines\n";
347
348 $_ = a;
349 eval "s/a/'b\0'#/e";
350 print 'not ' unless $_ eq "b\0";
351 print "ok 70 - # after null in s/// repl\n";
352
353 s//"#" . <<END/e;
354 foo
355 END
356 print "ok 71 - s//'#' . <<END/e\n";
357
358 eval "s//3}->{3/e";
359 print "not " unless $@;
360 print "ok 72 - s//3}->{3/e\n";
361
362 $_ = "not ok 73";
363 $x{3} = "not ";
364 eval 's/${\%x}{3}//e';
365 print "$_ - s//\${\\%x}{3}/e\n";