Commit | Line | Data |
---|---|---|
f46d017c GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
20822f61 MG |
5 | @INC = '.'; |
6 | push @INC, '../lib'; | |
f46d017c GS |
7 | } |
8 | ||
9e7c6af3 NC |
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 GS |
16 | # don't make this lexical |
17 | $i = 1; | |
d2f5bb60 | 18 | |
c106f444 | 19 | my @files_to_delete = qw (bleah.pm bleah.do bleah.flg urkkk.pm urkkk.pmc |
b0927e10 NC |
20 | krunch.pm krunch.pmc whap.pm whap.pmc); |
21 | ||
c106f444 DM |
22 | # there may be another copy of this test script running, or the files may |
23 | # just not have been deleted at the end of the last run; if the former, we | |
24 | # wait a while so that creating and unlinking these files won't interfere | |
25 | # with the other process; if the latter, then the delay is harmless. As | |
26 | # to why there might be multiple execution of this test file, I don't | |
27 | # know; but this is an experiment to see if random smoke failures go away. | |
28 | ||
29 | if (grep -e, @files_to_delete) { | |
30 | print "# Sleeping for 20 secs waiting for other process to finish\n"; | |
31 | sleep 20; | |
32 | } | |
33 | ||
b0927e10 | 34 | |
d2f5bb60 | 35 | my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; |
8a220075 | 36 | my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; |
01b5ef50 | 37 | my $total_tests = 55; |
76b0784a | 38 | if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } |
d2f5bb60 | 39 | print "1..$total_tests\n"; |
f46d017c | 40 | |
4a9ae47a GS |
41 | sub write_file { |
42 | my $f = shift; | |
43 | open(REQ,">$f") or die "Can't write '$f': $!"; | |
9f82a649 | 44 | binmode REQ; |
4a9ae47a | 45 | print REQ @_; |
d1e4d418 | 46 | close REQ or die "Could not close $f: $!"; |
4a9ae47a GS |
47 | } |
48 | ||
9f3d182e GS |
49 | eval {require 5.005}; |
50 | print "# $@\nnot " if $@; | |
b3008037 | 51 | print "ok ",$i++," - require 5.005 try 1\n"; |
9f3d182e GS |
52 | |
53 | eval { require 5.005 }; | |
54 | print "# $@\nnot " if $@; | |
b3008037 | 55 | print "ok ",$i++," - require 5.005 try 2\n"; |
9f3d182e GS |
56 | |
57 | eval { require 5.005; }; | |
58 | print "# $@\nnot " if $@; | |
b3008037 | 59 | print "ok ",$i++," - require 5.005 try 3\n"; |
9f3d182e GS |
60 | |
61 | eval { | |
62 | require 5.005 | |
63 | }; | |
64 | print "# $@\nnot " if $@; | |
b3008037 | 65 | print "ok ",$i++," - require 5.005 try 4\n"; |
9f3d182e | 66 | |
a7cb1f99 GS |
67 | # new style version numbers |
68 | ||
69 | eval { require v5.5.630; }; | |
70 | print "# $@\nnot " if $@; | |
b3008037 | 71 | print "ok ",$i++," - require 5.5.630\n"; |
a7cb1f99 | 72 | |
1647a8f2 FC |
73 | sub v5 { die } |
74 | eval { require v5; }; | |
75 | print "# $@\nnot " if $@; | |
76 | print "ok ",$i++," - require v5 ignores sub named v5\n"; | |
77 | ||
dd629d5b | 78 | eval { require 10.0.2; }; |
a7cb1f99 | 79 | print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/; |
b3008037 | 80 | print "ok ",$i++," - require 10.0.2\n"; |
a7cb1f99 | 81 | |
44dcb63b | 82 | my $ver = 5.005_63; |
a7cb1f99 GS |
83 | eval { require $ver; }; |
84 | print "# $@\nnot " if $@; | |
b3008037 | 85 | print "ok ",$i++," - require 5.005_63\n"; |
a7cb1f99 | 86 | |
44dcb63b | 87 | # check inaccurate fp |
dbe7b177 GS |
88 | $ver = 10.2; |
89 | eval { require $ver; }; | |
9137345a | 90 | print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/; |
b3008037 | 91 | print "ok ",$i++," - require 10.2\n"; |
44dcb63b GS |
92 | |
93 | $ver = 10.000_02; | |
a7cb1f99 | 94 | eval { require $ver; }; |
44dcb63b | 95 | print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/; |
b3008037 | 96 | print "ok ",$i++," - require 10.000_02\n"; |
a7cb1f99 | 97 | |
dd629d5b | 98 | print "not " unless 5.5.1 gt v5.5; |
b3008037 | 99 | print "ok ",$i++," - 5.5.1 gt v5.5\n"; |
a7cb1f99 | 100 | |
a7cb1f99 | 101 | { |
a7cb1f99 | 102 | print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; |
b3008037 | 103 | print "ok ",$i++," - v5.5.640 eq \\x{5}\\x{5}\\x{280}\n"; |
a7cb1f99 GS |
104 | |
105 | print "not " unless v7.15 eq "\x{7}\x{f}"; | |
b3008037 | 106 | print "ok ",$i++," - v7.15 eq \\x{7}\\x{f}\n"; |
a7cb1f99 GS |
107 | |
108 | print "not " | |
109 | unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; | |
b3008037 | 110 | print "ok ",$i++," - v1.20.300.4000.50000.600000 eq ...\n"; |
a7cb1f99 GS |
111 | } |
112 | ||
91937335 NC |
113 | # "use 5.11.0" (and higher) loads strictures. |
114 | # check that this doesn't happen with require | |
115 | eval 'require 5.11.0; ${"foo"} = "bar";'; | |
116 | print "# $@\nnot " if $@; | |
b3008037 | 117 | print "ok ",$i++," - require 5.11.0\n"; |
88e9444c NC |
118 | eval 'BEGIN {require 5.11.0} ${"foo"} = "bar";'; |
119 | print "# $@\nnot " if $@; | |
b3008037 | 120 | print "ok ",$i++,"\ - BEGIN { require 5.11.0}\n"; |
91937335 | 121 | |
4a9ae47a | 122 | # interaction with pod (see the eof) |
b3008037 | 123 | write_file('bleah.pm', "print 'ok $i - require bleah.pm\n'; 1;\n"); |
4a9ae47a GS |
124 | require "bleah.pm"; |
125 | $i++; | |
126 | ||
f46d017c GS |
127 | # run-time failure in require |
128 | do_require "0;\n"; | |
129 | print "# $@\nnot " unless $@ =~ /did not return a true/; | |
b3008037 | 130 | print "ok ",$i++," - require returning 0\n"; |
f46d017c | 131 | |
4d8b06f1 | 132 | print "not " if exists $INC{'bleah.pm'}; |
b3008037 | 133 | print "ok ",$i++," - %INC not updated\n"; |
4d8b06f1 RD |
134 | |
135 | my $flag_file = 'bleah.flg'; | |
136 | # run-time error in require | |
137 | for my $expected_compile (1,0) { | |
138 | write_file($flag_file, 1); | |
139 | print "not " unless -e $flag_file; | |
b3008037 | 140 | print "ok ",$i++," - exp $expected_compile; bleah.flg\n"; |
4d8b06f1 RD |
141 | write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n"); |
142 | print "# $@\nnot " if eval { require 'bleah.pm' }; | |
b3008037 | 143 | print "ok ",$i++," - exp $expected_compile; require bleah.pm with flag file\n"; |
4d8b06f1 | 144 | print "not " unless -e $flag_file xor $expected_compile; |
b3008037 | 145 | print "ok ",$i++," - exp $expected_compile; -e flag_file\n"; |
27bcc0a7 | 146 | print "not " unless exists $INC{'bleah.pm'}; |
b3008037 | 147 | print "ok ",$i++," - exp $expected_compile; exists \$INC{'bleah.pm}\n"; |
4d8b06f1 RD |
148 | } |
149 | ||
f46d017c GS |
150 | # compile-time failure in require |
151 | do_require "1)\n"; | |
f0ec1f9a | 152 | # bison says 'parse error' instead of 'syntax error', |
d91e2bdb | 153 | # various yaccs may or may not capitalize 'syntax'. |
f0ec1f9a | 154 | print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; |
b3008037 | 155 | print "ok ",$i++," - syntax error\n"; |
f46d017c | 156 | |
27bcc0a7 RGS |
157 | # previous failure cached in %INC |
158 | print "not " unless exists $INC{'bleah.pm'}; | |
b3008037 | 159 | print "ok ",$i++," - cached %INC\n"; |
4d8b06f1 RD |
160 | write_file($flag_file, 1); |
161 | write_file('bleah.pm', "unlink '$flag_file'; 1"); | |
162 | print "# $@\nnot " if eval { require 'bleah.pm' }; | |
b3008037 | 163 | print "ok ",$i++," - eval { require 'bleah.pm' }\n"; |
4d8b06f1 | 164 | print "# $@\nnot " unless $@ =~ /Compilation failed/i; |
b3008037 | 165 | print "ok ",$i++," - Compilation failed\n"; |
4d8b06f1 | 166 | print "not " unless -e $flag_file; |
b3008037 | 167 | print "ok ",$i++," - -e flag_file\n"; |
27bcc0a7 | 168 | print "not " unless exists $INC{'bleah.pm'}; |
b3008037 | 169 | print "ok ",$i++," - \$INC{'bleah.pm'}\n"; |
4d8b06f1 | 170 | |
f46d017c GS |
171 | # successful require |
172 | do_require "1"; | |
173 | print "# $@\nnot " if $@; | |
b3008037 | 174 | print "ok ",$i++," - do_require '1';\n"; |
f46d017c | 175 | |
faa7e5bb | 176 | # do FILE shouldn't see any outside lexicals |
b3008037 | 177 | my $x = "ok $i - bleah.do\n"; |
faa7e5bb | 178 | write_file("bleah.do", <<EOT); |
b3008037 | 179 | \$x = "not ok $i - bleah.do\\n"; |
faa7e5bb | 180 | EOT |
e81465be | 181 | do "bleah.do" or die $@; |
faa7e5bb | 182 | dofile(); |
e81465be | 183 | sub dofile { do "bleah.do" or die $@; }; |
faa7e5bb | 184 | print $x; |
faa7e5bb | 185 | |
a89be09a RGS |
186 | # Test that scalar context is forced for require |
187 | ||
188 | write_file('bleah.pm', <<'**BLEAH**' | |
189 | print "not " if !defined wantarray || wantarray ne ''; | |
021f53de | 190 | print "ok $i - require() context\n"; |
a89be09a RGS |
191 | 1; |
192 | **BLEAH** | |
193 | ); | |
194 | delete $INC{"bleah.pm"}; ++$::i; | |
195 | $foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; | |
196 | @foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; | |
197 | eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; | |
0c58d367 | 198 | eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
5255f1f4 | 199 | eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
a89be09a RGS |
200 | $foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; |
201 | @foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; | |
202 | eval {require bleah}; | |
203 | ||
2d6f15ea NC |
204 | # Test for fix of RT #24404 : "require $scalar" may load a directory |
205 | my $r = "threads"; | |
206 | eval { require $r }; | |
207 | $i++; | |
6b845e56 | 208 | if($@ =~ /Can't locate threads in \@INC/) { |
b3008037 | 209 | print "ok $i - RT #24404\n"; |
2d6f15ea | 210 | } else { |
b3008037 | 211 | print "not ok - RT #24404$i\n"; |
2d6f15ea NC |
212 | } |
213 | ||
01b5ef50 FC |
214 | # require CORE::foo |
215 | eval ' require CORE::lc "THREADS" '; | |
216 | $i++; | |
217 | if($@ =~ /Can't locate threads in \@INC/) { | |
218 | print "ok $i - [perl #24482] require CORE::foo\n"; | |
219 | } else { | |
220 | print "not ok - [perl #24482] require CORE::foo\n"; | |
221 | } | |
222 | ||
57f3ff92 NC |
223 | |
224 | write_file('bleah.pm', qq(die "This is an expected error";\n)); | |
225 | delete $INC{"bleah.pm"}; ++$::i; | |
226 | eval { CORE::require bleah; }; | |
227 | if ($@ =~ /^This is an expected error/) { | |
b3008037 | 228 | print "ok $i - expected error\n"; |
57f3ff92 | 229 | } else { |
b3008037 | 230 | print "not ok $i - expected error\n"; |
57f3ff92 NC |
231 | } |
232 | ||
b0927e10 NC |
233 | sub write_file_not_thing { |
234 | my ($file, $thing, $test) = @_; | |
235 | write_file($file, <<"EOT"); | |
b3008037 | 236 | print "not ok $test - write_file_not_thing $file\n"; |
b0927e10 NC |
237 | die "The $thing file should not be loaded"; |
238 | EOT | |
239 | } | |
240 | ||
241 | { | |
242 | # Right. We really really need Config here. | |
243 | require Config; | |
244 | die "Failed to load Config for some reason" | |
245 | unless $Config::Config{version}; | |
246 | my $ccflags = $Config::Config{ccflags}; | |
247 | die "Failed to get ccflags for some reason" unless defined $ccflags; | |
248 | ||
249 | my $simple = ++$i; | |
250 | my $pmc_older = ++$i; | |
251 | my $pmc_dies = ++$i; | |
252 | if ($ccflags =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/) { | |
253 | print "# .pmc files are ignored, so test that\n"; | |
254 | write_file_not_thing('krunch.pmc', '.pmc', $pmc_older); | |
b3008037 | 255 | write_file('urkkk.pm', qq(print "ok $simple - urkkk.pm branch A\n")); |
b0927e10 NC |
256 | write_file('whap.pmc', qq(die "This is not an expected error")); |
257 | ||
258 | print "# Sleeping for 2 seconds before creating some more files\n"; | |
259 | sleep 2; | |
260 | ||
b3008037 | 261 | write_file('krunch.pm', qq(print "ok $pmc_older - krunch.pm branch A\n")); |
b0927e10 NC |
262 | write_file_not_thing('urkkk.pmc', '.pmc', $simple); |
263 | write_file('whap.pm', qq(die "This is an expected error")); | |
264 | } else { | |
265 | print "# .pmc files should be loaded, so test that\n"; | |
b3008037 | 266 | write_file('krunch.pmc', qq(print "ok $pmc_older - krunch.pm branch B\n";)); |
b0927e10 NC |
267 | write_file_not_thing('urkkk.pm', '.pm', $simple); |
268 | write_file('whap.pmc', qq(die "This is an expected error")); | |
269 | ||
270 | print "# Sleeping for 2 seconds before creating some more files\n"; | |
271 | sleep 2; | |
272 | ||
273 | write_file_not_thing('krunch.pm', '.pm', $pmc_older); | |
b3008037 | 274 | write_file('urkkk.pmc', qq(print "ok $simple - urkkk.pm branch B\n";)); |
b0927e10 NC |
275 | write_file_not_thing('whap.pm', '.pm', $pmc_dies); |
276 | } | |
277 | require urkkk; | |
278 | require krunch; | |
279 | eval {CORE::require whap; 1} and die; | |
280 | ||
281 | if ($@ =~ /^This is an expected error/) { | |
b3008037 | 282 | print "ok $pmc_dies - pmc_dies\n"; |
b0927e10 | 283 | } else { |
b3008037 | 284 | print "not ok $pmc_dies - pmc_dies\n"; |
b0927e10 NC |
285 | } |
286 | } | |
287 | ||
eb70bb4a FC |
288 | # Test "require func()" with abs path when there is no .pmc file. |
289 | ++$::i; | |
3712c77b TC |
290 | if (defined &DynaLoader::boot_DynaLoader) { |
291 | require Cwd; | |
292 | require File::Spec::Functions; | |
293 | eval { | |
294 | CORE::require(File::Spec::Functions::catfile(Cwd::getcwd(),"bleah.pm")); | |
295 | }; | |
296 | if ($@ =~ /^This is an expected error/) { | |
b3008037 | 297 | print "ok $i - require(func())\n"; |
3712c77b | 298 | } else { |
b3008037 | 299 | print "not ok $i - require(func())\n"; |
3712c77b | 300 | } |
eb70bb4a | 301 | } else { |
3712c77b | 302 | print "ok $i # SKIP Cwd may not be available in miniperl\n"; |
eb70bb4a FC |
303 | } |
304 | ||
6406c527 FC |
305 | { |
306 | BEGIN { ${^OPEN} = ":utf8\0"; } | |
307 | %INC = (); | |
308 | write_file('bleah.pm',"package F; \$x = '\xD1\x9E';\n"); | |
309 | eval { require "bleah.pm" }; | |
310 | $i++; | |
311 | my $not = $F::x eq "\xD1\x9E" ? "" : "not "; | |
312 | print "${not}ok $i - require ignores I/O layers\n"; | |
313 | } | |
314 | ||
f45b078d FC |
315 | { |
316 | BEGIN { ${^OPEN} = ":utf8\0"; } | |
317 | %INC = (); | |
318 | write_file('bleah.pm',"require re; re->import('/x'); 1;\n"); | |
319 | my $not = eval 'use bleah; "ab" =~ /a b/' ? "" : "not "; | |
320 | $i++; | |
321 | print "${not}ok $i - require does not localise %^H at run time\n"; | |
322 | } | |
eb70bb4a | 323 | |
d20ea72b RGS |
324 | ########################################## |
325 | # What follows are UTF-8 specific tests. # | |
326 | # Add generic tests before this point. # | |
327 | ########################################## | |
2d6f15ea | 328 | |
8a220075 | 329 | # UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input |
d2f5bb60 | 330 | |
8a220075 | 331 | if ($Is_EBCDIC || $Is_UTF8) { exit; } |
d2f5bb60 | 332 | |
b6357110 | 333 | my %templates = ( |
ee6ba15d EB |
334 | 'UTF-8' => 'C0U', |
335 | 'UTF-16BE' => 'n', | |
336 | 'UTF-16LE' => 'v', | |
b6357110 NC |
337 | ); |
338 | ||
339 | sub bytes_to_utf { | |
340 | my ($enc, $content, $do_bom) = @_; | |
341 | my $template = $templates{$enc}; | |
342 | die "Unsupported encoding $enc" unless $template; | |
343 | return pack "$template*", ($do_bom ? 0xFEFF : ()), unpack "C*", $content; | |
344 | } | |
dea0fc0b | 345 | |
b6357110 | 346 | foreach (sort keys %templates) { |
91229223 | 347 | $i++; do_require(bytes_to_utf($_, qq(print "ok $i # $_\\n"; 1;\n), 1)); |
ee6ba15d EB |
348 | if ($@ =~ /^(Unsupported script encoding \Q$_\E)/) { |
349 | print "ok $i # skip $1\n"; | |
350 | } | |
dea0fc0b JH |
351 | } |
352 | ||
4d8b06f1 | 353 | END { |
c106f444 | 354 | foreach my $file (@files_to_delete) { |
b0927e10 NC |
355 | 1 while unlink $file; |
356 | } | |
4d8b06f1 | 357 | } |
4a9ae47a GS |
358 | |
359 | # ***interaction with pod (don't put any thing after here)*** | |
360 | ||
361 | =pod |