1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
#!./perl
print "1..46\n";
$x = 'x';
print "#1 :$x: eq :x:\n";
if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
$x = $#; # this is the register $#
if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
$x = $#x;
if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
$x = '\\'; # ';
if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
eval 'while (0) {
print "foo\n";
}
/^/ && (print "ok 5\n");
';
eval '$foo{1} / 1;';
if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";}
eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
$foo = int($foo * 100 + .5);
if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";}
print <<'EOF';
ok 8
EOF
$foo = 'ok 9';
print <<EOF;
$foo
EOF
eval <<\EOE, print $@;
print <<'EOF';
ok 10
EOF
$foo = 'ok 11';
print <<EOF;
$foo
EOF
EOE
print <<`EOS` . <<\EOF;
echo ok 12
EOS
ok 13
EOF
print qq/ok 14\n/;
print qq(ok 15\n);
print qq
[ok 16\n]
;
print q<ok 17
>;
print <<; # Yow!
ok 18
# previous line intentionally left blank.
print <<E1 eq "foo\n\n" ? "ok 19\n" : "not ok 19\n";
@{[ <<E2 ]}
foo
E2
E1
print <<E1 eq "foo\n\n" ? "ok 20\n" : "not ok 20\n";
@{[
<<E2
foo
E2
]}
E1
$foo = FOO;
$bar = BAR;
$foo{$bar} = BAZ;
$ary[0] = ABC;
print "$foo{$bar}" eq "BAZ" ? "ok 21\n" : "not ok 21\n";
print "${foo}{$bar}" eq "FOO{BAR}" ? "ok 22\n" : "not ok 22\n";
print "${foo{$bar}}" eq "BAZ" ? "ok 23\n" : "not ok 23\n";
print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n";
print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n";
print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n";
# MJD 19980425
($X, @X) = qw(a b c d);
print "d" =~ /^$X[-1]$/ ? "ok 27\n" : "not ok 27\n";
print "a1" !~ /^$X[-1]$/ ? "ok 28\n" : "not ok 28\n";
print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 29\n" : "not ok 29\n");
$foo = "not ok 30\n";
$foo =~ s/^not /substr(<<EOF, 0, 0)/e;
Ignored
EOF
print $foo;
# Tests for new extended control-character variables
# MJD 19990227
{ my $CX = "\cX";
my $CXY ="\cXY";
$ {$CX} = 17;
$ {$CXY} = 23;
if ($ {^XY} != 23) { print "not " }
print "ok 31\n";
# Does the syntax where we use the literal control character still work?
if (eval "\$ {\cX}" != 17 or $@) { print "not " }
print "ok 32\n";
eval "\$\cN = 24"; # Literal control character
if ($@ or ${"\cN"} != 24) { print "not " }
print "ok 33\n";
if ($^N != 24) { print "not " } # Control character escape sequence
print "ok 34\n";
# Does the old UNBRACED syntax still do what it used to?
if ("$^XY" ne "17Y") { print "not " }
print "ok 35\n";
sub XX () { 6 }
$ {"\cN\cXX"} = 119;
$^N = 5; # This should be an unused ^Var.
$N = 5;
# The second caret here should be interpreted as an xor
if (($^N^XX) != 3) { print "not " }
print "ok 36\n";
# if (($N ^ XX()) != 3) { print "not " }
# print "ok 32\n";
# These next two tests are trying to make sure that
# $^FOO is always global; it doesn't make sense to `my' it.
#
eval 'my $^X;';
print "not " unless index ($@, 'Can\'t use global $^X in "my"') > -1;
print "ok 37\n";
# print "($@)\n" if $@;
eval 'my $ {^XYZ};';
print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
print "ok 38\n";
# print "($@)\n" if $@;
# Now let's make sure that caret variables are all forced into the main package.
package Someother;
$^N = 'Someother';
$ {^Nostril} = 'Someother 2';
$ {^M} = 'Someother 3';
package main;
print "not " unless $^N eq 'Someother';
print "ok 39\n";
print "not " unless $ {^Nostril} eq 'Someother 2';
print "ok 40\n";
print "not " unless $ {^M} eq 'Someother 3';
print "ok 41\n";
}
# see if eval '', s///e, and heredocs mix
sub T {
my ($where, $num) = @_;
my ($p,$f,$l) = caller;
print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/;
print "ok $num\n";
}
my $test = 42;
{
# line 42 "plink"
local $_ = "not ok ";
eval q{
s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++;
# fuggedaboudit
EOT
print $_, $test++, "\n";
T('^main:\(eval \d+\):6$', $test++);
# line 1 "plunk"
T('^main:plunk:1$', $test++);
};
print "# $@\nnot ok $test\n" if $@;
T '^main:plink:53$', $test++;
}
|
