Commit | Line | Data |
f46d017c |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '.'; |
6 | push @INC, '../lib'; |
f46d017c |
7 | } |
8 | |
9e7c6af3 |
9 | sub do_require { |
10 | %INC = (); |
11 | write_file('bleah.pm',@_); |
12 | eval { require "bleah.pm" }; |
13 | my @a; # magic guard for scope violations (must be first lexical in file) |
14 | } |
15 | |
f46d017c |
16 | # don't make this lexical |
17 | $i = 1; |
d2f5bb60 |
18 | |
b0927e10 |
19 | my @fjles_to_delete = qw (bleah.pm bleah.do bleah.flg urkkk.pm urkkk.pmc |
20 | krunch.pm krunch.pmc whap.pm whap.pmc); |
21 | |
22 | |
d2f5bb60 |
23 | my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; |
8a220075 |
24 | my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; |
5255f1f4 |
25 | my $total_tests = 49; |
76b0784a |
26 | if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } |
d2f5bb60 |
27 | print "1..$total_tests\n"; |
f46d017c |
28 | |
4a9ae47a |
29 | sub write_file { |
30 | my $f = shift; |
31 | open(REQ,">$f") or die "Can't write '$f': $!"; |
9f82a649 |
32 | binmode REQ; |
4a9ae47a |
33 | print REQ @_; |
d1e4d418 |
34 | close REQ or die "Could not close $f: $!"; |
4a9ae47a |
35 | } |
36 | |
9f3d182e |
37 | eval {require 5.005}; |
38 | print "# $@\nnot " if $@; |
39 | print "ok ",$i++,"\n"; |
40 | |
41 | eval { require 5.005 }; |
42 | print "# $@\nnot " if $@; |
43 | print "ok ",$i++,"\n"; |
44 | |
45 | eval { require 5.005; }; |
46 | print "# $@\nnot " if $@; |
47 | print "ok ",$i++,"\n"; |
48 | |
49 | eval { |
50 | require 5.005 |
51 | }; |
52 | print "# $@\nnot " if $@; |
53 | print "ok ",$i++,"\n"; |
54 | |
a7cb1f99 |
55 | # new style version numbers |
56 | |
57 | eval { require v5.5.630; }; |
58 | print "# $@\nnot " if $@; |
59 | print "ok ",$i++,"\n"; |
60 | |
dd629d5b |
61 | eval { require 10.0.2; }; |
a7cb1f99 |
62 | print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; |
63 | print "ok ",$i++,"\n"; |
64 | |
44dcb63b |
65 | my $ver = 5.005_63; |
a7cb1f99 |
66 | eval { require $ver; }; |
67 | print "# $@\nnot " if $@; |
68 | print "ok ",$i++,"\n"; |
69 | |
44dcb63b |
70 | # check inaccurate fp |
dbe7b177 |
71 | $ver = 10.2; |
72 | eval { require $ver; }; |
9137345a |
73 | print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/; |
dbe7b177 |
74 | print "ok ",$i++,"\n"; |
44dcb63b |
75 | |
76 | $ver = 10.000_02; |
a7cb1f99 |
77 | eval { require $ver; }; |
44dcb63b |
78 | print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/; |
a7cb1f99 |
79 | print "ok ",$i++,"\n"; |
80 | |
dd629d5b |
81 | print "not " unless 5.5.1 gt v5.5; |
a7cb1f99 |
82 | print "ok ",$i++,"\n"; |
83 | |
a7cb1f99 |
84 | { |
a7cb1f99 |
85 | print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; |
86 | print "ok ",$i++,"\n"; |
87 | |
88 | print "not " unless v7.15 eq "\x{7}\x{f}"; |
89 | print "ok ",$i++,"\n"; |
90 | |
91 | print "not " |
92 | unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; |
93 | print "ok ",$i++,"\n"; |
94 | } |
95 | |
91937335 |
96 | # "use 5.11.0" (and higher) loads strictures. |
97 | # check that this doesn't happen with require |
98 | eval 'require 5.11.0; ${"foo"} = "bar";'; |
99 | print "# $@\nnot " if $@; |
100 | print "ok ",$i++,"\n"; |
101 | |
4a9ae47a |
102 | # interaction with pod (see the eof) |
103 | write_file('bleah.pm', "print 'ok $i\n'; 1;\n"); |
104 | require "bleah.pm"; |
105 | $i++; |
106 | |
f46d017c |
107 | # run-time failure in require |
108 | do_require "0;\n"; |
109 | print "# $@\nnot " unless $@ =~ /did not return a true/; |
110 | print "ok ",$i++,"\n"; |
111 | |
4d8b06f1 |
112 | print "not " if exists $INC{'bleah.pm'}; |
113 | print "ok ",$i++,"\n"; |
114 | |
115 | my $flag_file = 'bleah.flg'; |
116 | # run-time error in require |
117 | for my $expected_compile (1,0) { |
118 | write_file($flag_file, 1); |
119 | print "not " unless -e $flag_file; |
120 | print "ok ",$i++,"\n"; |
121 | write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n"); |
122 | print "# $@\nnot " if eval { require 'bleah.pm' }; |
123 | print "ok ",$i++,"\n"; |
124 | print "not " unless -e $flag_file xor $expected_compile; |
125 | print "ok ",$i++,"\n"; |
27bcc0a7 |
126 | print "not " unless exists $INC{'bleah.pm'}; |
127 | print "ok ",$i++,"\n"; |
4d8b06f1 |
128 | } |
129 | |
f46d017c |
130 | # compile-time failure in require |
131 | do_require "1)\n"; |
f0ec1f9a |
132 | # bison says 'parse error' instead of 'syntax error', |
d91e2bdb |
133 | # various yaccs may or may not capitalize 'syntax'. |
f0ec1f9a |
134 | print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; |
f46d017c |
135 | print "ok ",$i++,"\n"; |
136 | |
27bcc0a7 |
137 | # previous failure cached in %INC |
138 | print "not " unless exists $INC{'bleah.pm'}; |
139 | print "ok ",$i++,"\n"; |
4d8b06f1 |
140 | write_file($flag_file, 1); |
141 | write_file('bleah.pm', "unlink '$flag_file'; 1"); |
142 | print "# $@\nnot " if eval { require 'bleah.pm' }; |
143 | print "ok ",$i++,"\n"; |
144 | print "# $@\nnot " unless $@ =~ /Compilation failed/i; |
145 | print "ok ",$i++,"\n"; |
146 | print "not " unless -e $flag_file; |
147 | print "ok ",$i++,"\n"; |
27bcc0a7 |
148 | print "not " unless exists $INC{'bleah.pm'}; |
4d8b06f1 |
149 | print "ok ",$i++,"\n"; |
150 | |
f46d017c |
151 | # successful require |
152 | do_require "1"; |
153 | print "# $@\nnot " if $@; |
154 | print "ok ",$i++,"\n"; |
155 | |
faa7e5bb |
156 | # do FILE shouldn't see any outside lexicals |
157 | my $x = "ok $i\n"; |
158 | write_file("bleah.do", <<EOT); |
159 | \$x = "not ok $i\\n"; |
160 | EOT |
e81465be |
161 | do "bleah.do" or die $@; |
faa7e5bb |
162 | dofile(); |
e81465be |
163 | sub dofile { do "bleah.do" or die $@; }; |
faa7e5bb |
164 | print $x; |
faa7e5bb |
165 | |
a89be09a |
166 | # Test that scalar context is forced for require |
167 | |
168 | write_file('bleah.pm', <<'**BLEAH**' |
169 | print "not " if !defined wantarray || wantarray ne ''; |
021f53de |
170 | print "ok $i - require() context\n"; |
a89be09a |
171 | 1; |
172 | **BLEAH** |
173 | ); |
174 | delete $INC{"bleah.pm"}; ++$::i; |
175 | $foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
176 | @foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
177 | eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
0c58d367 |
178 | eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
5255f1f4 |
179 | eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
a89be09a |
180 | $foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
181 | @foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
182 | eval {require bleah}; |
183 | |
2d6f15ea |
184 | # Test for fix of RT #24404 : "require $scalar" may load a directory |
185 | my $r = "threads"; |
186 | eval { require $r }; |
187 | $i++; |
6b845e56 |
188 | if($@ =~ /Can't locate threads in \@INC/) { |
2d6f15ea |
189 | print "ok $i\n"; |
190 | } else { |
191 | print "not ok $i\n"; |
192 | } |
193 | |
57f3ff92 |
194 | |
195 | write_file('bleah.pm', qq(die "This is an expected error";\n)); |
196 | delete $INC{"bleah.pm"}; ++$::i; |
197 | eval { CORE::require bleah; }; |
198 | if ($@ =~ /^This is an expected error/) { |
199 | print "ok $i\n"; |
200 | } else { |
201 | print "not ok $i\n"; |
202 | } |
203 | |
b0927e10 |
204 | sub write_file_not_thing { |
205 | my ($file, $thing, $test) = @_; |
206 | write_file($file, <<"EOT"); |
207 | print "not ok $test\n"; |
208 | die "The $thing file should not be loaded"; |
209 | EOT |
210 | } |
211 | |
212 | { |
213 | # Right. We really really need Config here. |
214 | require Config; |
215 | die "Failed to load Config for some reason" |
216 | unless $Config::Config{version}; |
217 | my $ccflags = $Config::Config{ccflags}; |
218 | die "Failed to get ccflags for some reason" unless defined $ccflags; |
219 | |
220 | my $simple = ++$i; |
221 | my $pmc_older = ++$i; |
222 | my $pmc_dies = ++$i; |
223 | if ($ccflags =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/) { |
224 | print "# .pmc files are ignored, so test that\n"; |
225 | write_file_not_thing('krunch.pmc', '.pmc', $pmc_older); |
226 | write_file('urkkk.pm', qq(print "ok $simple\n")); |
227 | write_file('whap.pmc', qq(die "This is not an expected error")); |
228 | |
229 | print "# Sleeping for 2 seconds before creating some more files\n"; |
230 | sleep 2; |
231 | |
232 | write_file('krunch.pm', qq(print "ok $pmc_older\n")); |
233 | write_file_not_thing('urkkk.pmc', '.pmc', $simple); |
234 | write_file('whap.pm', qq(die "This is an expected error")); |
235 | } else { |
236 | print "# .pmc files should be loaded, so test that\n"; |
237 | write_file('krunch.pmc', qq(print "ok $pmc_older\n";)); |
238 | write_file_not_thing('urkkk.pm', '.pm', $simple); |
239 | write_file('whap.pmc', qq(die "This is an expected error")); |
240 | |
241 | print "# Sleeping for 2 seconds before creating some more files\n"; |
242 | sleep 2; |
243 | |
244 | write_file_not_thing('krunch.pm', '.pm', $pmc_older); |
245 | write_file('urkkk.pmc', qq(print "ok $simple\n";)); |
246 | write_file_not_thing('whap.pm', '.pm', $pmc_dies); |
247 | } |
248 | require urkkk; |
249 | require krunch; |
250 | eval {CORE::require whap; 1} and die; |
251 | |
252 | if ($@ =~ /^This is an expected error/) { |
253 | print "ok $pmc_dies\n"; |
254 | } else { |
255 | print "not ok $pmc_dies\n"; |
256 | } |
257 | } |
258 | |
d20ea72b |
259 | ########################################## |
260 | # What follows are UTF-8 specific tests. # |
261 | # Add generic tests before this point. # |
262 | ########################################## |
2d6f15ea |
263 | |
8a220075 |
264 | # UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input |
d2f5bb60 |
265 | |
8a220075 |
266 | if ($Is_EBCDIC || $Is_UTF8) { exit; } |
d2f5bb60 |
267 | |
b6357110 |
268 | my %templates = ( |
ee6ba15d |
269 | 'UTF-8' => 'C0U', |
270 | 'UTF-16BE' => 'n', |
271 | 'UTF-16LE' => 'v', |
b6357110 |
272 | ); |
273 | |
274 | sub bytes_to_utf { |
275 | my ($enc, $content, $do_bom) = @_; |
276 | my $template = $templates{$enc}; |
277 | die "Unsupported encoding $enc" unless $template; |
278 | return pack "$template*", ($do_bom ? 0xFEFF : ()), unpack "C*", $content; |
279 | } |
dea0fc0b |
280 | |
b6357110 |
281 | foreach (sort keys %templates) { |
91229223 |
282 | $i++; do_require(bytes_to_utf($_, qq(print "ok $i # $_\\n"; 1;\n), 1)); |
ee6ba15d |
283 | if ($@ =~ /^(Unsupported script encoding \Q$_\E)/) { |
284 | print "ok $i # skip $1\n"; |
285 | } |
dea0fc0b |
286 | } |
287 | |
4d8b06f1 |
288 | END { |
b0927e10 |
289 | foreach my $file (@fjles_to_delete) { |
290 | 1 while unlink $file; |
291 | } |
4d8b06f1 |
292 | } |
4a9ae47a |
293 | |
294 | # ***interaction with pod (don't put any thing after here)*** |
295 | |
296 | =pod |