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
|
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '.';
push @INC, '../lib';
}
# don't make this lexical
$i = 1;
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
my $total_tests = 44;
if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 41; }
print "1..$total_tests\n";
sub do_require {
%INC = ();
write_file('bleah.pm',@_);
eval { require "bleah.pm" };
my @a; # magic guard for scope violations (must be first lexical in file)
}
sub write_file {
my $f = shift;
open(REQ,">$f") or die "Can't write '$f': $!";
binmode REQ;
use bytes;
print REQ @_;
close REQ or die "Could not close $f: $!";
}
eval {require 5.005};
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval { require 5.005 };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval { require 5.005; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval {
require 5.005
};
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# new style version numbers
eval { require v5.5.630; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval { require 10.0.2; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
print "ok ",$i++,"\n";
eval q{ use v5.5.630; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval q{ use 10.0.2; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
print "ok ",$i++,"\n";
my $ver = 5.005_63;
eval { require $ver; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# check inaccurate fp
$ver = 10.2;
eval { require $ver; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.200 required/;
print "ok ",$i++,"\n";
$ver = 10.000_02;
eval { require $ver; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/;
print "ok ",$i++,"\n";
print "not " unless 5.5.1 gt v5.5;
print "ok ",$i++,"\n";
{
print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}";
print "ok ",$i++,"\n";
print "not " unless v7.15 eq "\x{7}\x{f}";
print "ok ",$i++,"\n";
print "not "
unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}";
print "ok ",$i++,"\n";
}
# interaction with pod (see the eof)
write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
require "bleah.pm";
$i++;
# run-time failure in require
do_require "0;\n";
print "# $@\nnot " unless $@ =~ /did not return a true/;
print "ok ",$i++,"\n";
print "not " if exists $INC{'bleah.pm'};
print "ok ",$i++,"\n";
my $flag_file = 'bleah.flg';
# run-time error in require
for my $expected_compile (1,0) {
write_file($flag_file, 1);
print "not " unless -e $flag_file;
print "ok ",$i++,"\n";
write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n");
print "# $@\nnot " if eval { require 'bleah.pm' };
print "ok ",$i++,"\n";
print "not " unless -e $flag_file xor $expected_compile;
print "ok ",$i++,"\n";
print "not " unless exists $INC{'bleah.pm'};
print "ok ",$i++,"\n";
}
# compile-time failure in require
do_require "1)\n";
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi;
print "ok ",$i++,"\n";
# previous failure cached in %INC
print "not " unless exists $INC{'bleah.pm'};
print "ok ",$i++,"\n";
write_file($flag_file, 1);
write_file('bleah.pm', "unlink '$flag_file'; 1");
print "# $@\nnot " if eval { require 'bleah.pm' };
print "ok ",$i++,"\n";
print "# $@\nnot " unless $@ =~ /Compilation failed/i;
print "ok ",$i++,"\n";
print "not " unless -e $flag_file;
print "ok ",$i++,"\n";
print "not " unless exists $INC{'bleah.pm'};
print "ok ",$i++,"\n";
# successful require
do_require "1";
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# do FILE shouldn't see any outside lexicals
my $x = "ok $i\n";
write_file("bleah.do", <<EOT);
\$x = "not ok $i\\n";
EOT
do "bleah.do";
dofile();
sub dofile { do "bleah.do"; };
print $x;
# Test that scalar context is forced for require
write_file('bleah.pm', <<'**BLEAH**'
print "not " if !defined wantarray || wantarray ne '';
print "ok $i - require() context\n";
1;
**BLEAH**
);
delete $INC{"bleah.pm"}; ++$::i;
$foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i;
$foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval {require bleah};
# UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input
if ($Is_EBCDIC || $Is_UTF8) { exit; }
my $utf8 = chr(0xFEFF);
$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
sub bytes_to_utf16 {
my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16;
}
$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE
END {
1 while unlink 'bleah.pm';
1 while unlink 'bleah.do';
1 while unlink 'bleah.flg';
}
# ***interaction with pod (don't put any thing after here)***
=pod
|
