| 1 | #!./perl |
| 2 | |
| 3 | print "1..66\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 | # fuggedaboudit |
| 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"; |