This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dist/PathTools - fix possible VMS breakage
[perl5.git] / t / comp / require.t
1 #!./perl
2
3 # NOTE this script messes with the perl debugger flags, if you run
4 # it under the perl debugger (perl -d) it might not work as expected.
5 # Look for code related to $^P below and adjust accordingly.
6
7 BEGIN {
8     chdir 't' if -d 't';
9     @INC = '.';
10     push @INC, '../lib', '../ext/re';
11 }
12
13 sub do_require {
14     %INC = ();
15     write_file('bleah.pm',@_);
16     eval { require "bleah.pm" };
17     my @a; # magic guard for scope violations (must be first lexical in file)
18 }
19
20 # don't make this lexical
21 our $i = 1;
22
23 our @module_true_tests; # this is set up in a BEGIN later on.
24 our $module_true_test_count; # this is set up in a BEGIN later on.
25 my @files_to_delete = qw (bleah.pm bleah.do bleah.flg blorn.pm blunge.pm
26 urkkk.pm urkkk.pmc krunch.pm krunch.pmc whap.pm whap.pmc
27 Demo1.pm Demo2.pm Demo3.pm Demo4.pm);
28 push @files_to_delete, "$_->[0].pm" for @module_true_tests;
29
30 # there may be another copy of this test script running, or the files may
31 # just not have been deleted at the end of the last run; if the former, we
32 # wait a while so that creating and unlinking these files won't interfere
33 # with the other process; if the latter, then the delay is harmless.  As
34 # to why there might be multiple execution of this test file, I don't
35 # know; but this is an experiment to see if random smoke failures go away.
36
37 if (!$ENV{NO_SLEEP} and grep -e, @files_to_delete) {
38     print "# Sleeping for 20 secs waiting for other process to finish\n";
39     sleep 20;
40 }
41
42 my $Is_UTF8   = (${^OPEN} || "") =~ /:utf8/;
43 my $total_tests = 58 + $module_true_test_count;
44 if ($Is_UTF8) { $total_tests -= 3; }
45 print "1..$total_tests\n";
46
47 sub write_file {
48     my $f = shift;
49     open(REQ,">$f") or die "Can't write '$f': $!";
50     binmode REQ;
51     print REQ @_;
52     close REQ or die "Could not close $f: $!";
53 }
54
55 eval {require 5.005};
56 print "# $@\nnot " if $@;
57 print "ok ",$i++," - require 5.005 try 1\n";
58
59 eval { require 5.005 };
60 print "# $@\nnot " if $@;
61 print "ok ",$i++," - require 5.005 try 2\n";
62
63 eval { require 5.005; };
64 print "# $@\nnot " if $@;
65 print "ok ",$i++," - require 5.005 try 3\n";
66
67 eval {
68     require 5.005
69 };
70 print "# $@\nnot " if $@;
71 print "ok ",$i++," - require 5.005 try 4\n";
72
73 # new style version numbers
74
75 eval { require v5.5.630; };
76 print "# $@\nnot " if $@;
77 print "ok ",$i++," - require 5.5.630\n";
78
79 eval { require(v5.5.630); };
80 print "# $@\nnot " if $@;
81 print "ok ",$i++," - require(v5.5.630) with parens [perl #124153]\n";
82
83 sub v5 { die }
84 eval { require v5; };
85 print "# $@\nnot " if $@;
86 print "ok ",$i++," - require v5 ignores sub named v5\n";
87
88 eval { require 10.0.2; };
89 print "# $@\nnot " unless $@ =~ /^\QPerl v10.0.2 required\E/;
90 print "ok ",$i++," - require 10.0.2\n";
91
92 my $ver = 5.005_63;
93 eval { require $ver; };
94 print "# $@\nnot " if $@;
95 print "ok ",$i++," - require 5.005_63\n";
96
97 # check inaccurate fp
98 $ver = 10.2;
99 eval { require $ver; };
100 print "# $@\nnot " unless $@ =~ /^\QPerl v10.200.0 required\E/;
101 print "ok ",$i++," - require 10.2\n";
102
103 $ver = 10.000_02;
104 eval { require $ver; };
105 print "# $@\nnot " unless $@ =~ /^\QPerl v10.0.20 required\E/;
106 print "ok ",$i++," - require 10.000_02\n";
107
108 print "not " unless 5.5.1 gt v5.5;
109 print "ok ",$i++," - 5.5.1 gt v5.5\n";
110
111 {
112     print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}";
113     print "ok ",$i++," - v5.5.640 eq \\x{5}\\x{5}\\x{280}\n";
114
115     print "not " unless v7.15 eq "\x{7}\x{f}";
116     print "ok ",$i++," - v7.15 eq \\x{7}\\x{f}\n";
117
118     print "not "
119       unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}";
120     print "ok ",$i++," - v1.20.300.4000.50000.600000 eq ...\n";
121 }
122
123 # "use 5.11.0" (and higher) loads strictures.
124 # check that this doesn't happen with require
125 eval 'require 5.11.0; ${"foo"} = "bar";';
126 print "# $@\nnot " if $@;
127 print "ok ",$i++," - require 5.11.0\n";
128 eval 'BEGIN {require 5.11.0} ${"foo"} = "bar";';
129 print "# $@\nnot " if $@;
130 print "ok ",$i++,"\ - BEGIN { require 5.11.0}\n";
131
132 # interaction with pod (see the eof)
133 write_file('bleah.pm', "print 'ok $i - require bleah.pm\n'; 1;\n");
134 require "bleah.pm";
135 $i++;
136
137 # run-time failure in require
138 do_require "0;\n";
139 print "# $@\nnot " unless $@ =~ /did not return a true/;
140 print "ok ",$i++," - require returning 0\n";
141
142 print "not " if exists $INC{'bleah.pm'};
143 print "ok ",$i++," - %INC not updated\n";
144
145 my $flag_file = 'bleah.flg';
146 # run-time error in require
147 for my $expected_compile (1,0) {
148     write_file($flag_file, 1);
149     print "not " unless -e $flag_file;
150     print "ok ",$i++," - exp $expected_compile; bleah.flg\n";
151     write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n");
152     print "# $@\nnot " if eval { require 'bleah.pm' };
153     print "ok ",$i++," - exp $expected_compile; require bleah.pm with flag file\n";
154     print "not " unless -e $flag_file xor $expected_compile;
155     print "ok ",$i++," - exp $expected_compile; -e flag_file\n";
156     print "not " unless exists $INC{'bleah.pm'};
157     print "ok ",$i++," - exp $expected_compile; exists \$INC{'bleah.pm}\n";
158 }
159
160 # compile-time failure in require
161 do_require "1)\n";
162 # bison says 'parse error' instead of 'syntax error',
163 # various yaccs may or may not capitalize 'syntax'.
164 print "# $@\nnot " unless $@ =~ /(?:syntax|parse) error/mi;
165 print "ok ",$i++," - syntax error\n";
166
167 # previous failure cached in %INC
168 print "not " unless exists $INC{'bleah.pm'};
169 print "ok ",$i++," - cached %INC\n";
170 write_file($flag_file, 1);
171 write_file('bleah.pm', "unlink '$flag_file'; 1");
172 print "# $@\nnot " if eval { require 'bleah.pm' };
173 print "ok ",$i++," - eval { require 'bleah.pm' }\n";
174 print "# $@\nnot " unless $@ =~ /Compilation failed/i;
175 print "ok ",$i++," - Compilation failed\n";
176 print "not " unless -e $flag_file;
177 print "ok ",$i++," - -e flag_file\n";
178 print "not " unless exists $INC{'bleah.pm'};
179 print "ok ",$i++," - \$INC{'bleah.pm'}\n";
180
181 # successful require
182 do_require "1";
183 print "# $@\nnot " if $@;
184 print "ok ",$i++," - do_require '1';\n";
185
186 # do FILE shouldn't see any outside lexicals
187 my $x = "ok $i - bleah.do\n";
188 write_file("bleah.do", <<EOT);
189 \$x = "not ok $i - bleah.do\\n";
190 EOT
191 do "bleah.do" or die $@;
192 dofile();
193 sub dofile { do "bleah.do" or die $@; };
194 print $x;
195
196 # Test that scalar context is forced for require
197
198 write_file('bleah.pm', <<'**BLEAH**'
199 print "not " if !defined wantarray || wantarray ne '';
200 print "ok $i - require() context\n";
201 1;
202 **BLEAH**
203 );
204 my ($foo,@foo);
205                               delete $INC{"bleah.pm"}; ++$::i;
206 $foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
207 @foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
208        eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
209        eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i;
210        eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i;
211 $foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
212 @foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
213        eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
214
215 eval 'require ::bleah;';
216 print "# $@\nnot " unless $@ =~ /^Bareword in require must not start with a double-colon:/;
217 print "ok ", $i," - require ::bleah is banned\n";
218
219 # Test for fix of RT #24404 : "require $scalar" may load a directory
220 my $r = "threads";
221 eval { require $r };
222 $i++;
223 if($@ =~ /Can't locate threads in \@INC/) {
224     print "ok $i - RT #24404\n";
225 } else {
226     print "not ok - RT #24404$i\n";
227 }
228
229 # require CORE::foo
230 eval ' require CORE::lc "THREADS" ';
231 $i++;
232 if($@ =~ /Can't locate threads in \@INC/) {
233     print "ok $i - [perl #24482] require CORE::foo\n";
234 } else {
235     print "not ok - [perl #24482] require CORE::foo\n";
236 }
237
238
239 write_file('bleah.pm', qq(die "This is an expected error";\n));
240 delete $INC{"bleah.pm"}; ++$::i;
241 eval { CORE::require bleah; };
242 if ($@ =~ /^This is an expected error/) {
243     print "ok $i - expected error\n";
244 } else {
245     print "not ok $i - expected error\n";
246 }
247
248 sub write_file_not_thing {
249     my ($file, $thing, $test) = @_;
250     write_file($file, <<"EOT");
251     print "not ok $test - write_file_not_thing $file\n";
252     die "The $thing file should not be loaded";
253 EOT
254 }
255
256 {
257     # Right. We really really need Config here.
258     require Config;
259     die "Failed to load Config for some reason"
260         unless $Config::Config{version};
261
262     my $simple = ++$i;
263     my $pmc_older = ++$i;
264     my $pmc_dies = ++$i;
265     my $no_pmc;
266     foreach(Config::non_bincompat_options()) {
267         if($_ eq "PERL_DISABLE_PMC"){
268             $no_pmc = 1;
269             last;
270         }
271     }
272     if ($no_pmc) {
273         print "# .pmc files are ignored, so test that\n";
274         write_file_not_thing('krunch.pmc', '.pmc', $pmc_older);
275         write_file('urkkk.pm', qq(print "ok $simple - urkkk.pm branch A\n"));
276         write_file('whap.pmc', qq(die "This is not an expected error"));
277
278         print "# Sleeping for 2 seconds before creating some more files\n";
279         sleep 2;
280
281         write_file('krunch.pm', qq(print "ok $pmc_older - krunch.pm branch A\n"));
282         write_file_not_thing('urkkk.pmc', '.pmc', $simple);
283         write_file('whap.pm', qq(die "This is an expected error"));
284     } else {
285         print "# .pmc files should be loaded, so test that\n";
286         write_file('krunch.pmc', qq(print "ok $pmc_older - krunch.pm branch B\n";));
287         write_file_not_thing('urkkk.pm', '.pm', $simple);
288         write_file('whap.pmc', qq(die "This is an expected error"));
289
290         print "# Sleeping for 2 seconds before creating some more files\n";
291         sleep 2;
292
293         write_file_not_thing('krunch.pm', '.pm', $pmc_older);
294         write_file('urkkk.pmc', qq(print "ok $simple - urkkk.pm branch B\n";));
295         write_file_not_thing('whap.pm', '.pm', $pmc_dies);
296     }
297     require urkkk;
298     require krunch;
299     eval {CORE::require whap; 1} and die;
300
301     if ($@ =~ /^This is an expected error/) {
302         print "ok $pmc_dies - pmc_dies\n";
303     } else {
304         print "not ok $pmc_dies - pmc_dies\n";
305     }
306 }
307
308
309 {
310     # if we 'require "op"', since we're in the t/ directory and '.' is the
311     # first thing in @INC, it will try to load t/op/; it should fail and
312     # move onto the next path; however, the previous value of $! was
313     # leaking into implementation if it was EACCES and we're accessing a
314     # directory.
315
316     $! = eval 'use Errno qw(EACCES); EACCES' || 0;
317     eval q{require 'op'};
318     $i++;
319     print "not " if $@ =~ /Permission denied/;
320     print "ok $i - require op\n";
321 }
322
323 # Test "require func()" with abs path when there is no .pmc file.
324 ++$::i;
325 if (defined &DynaLoader::boot_DynaLoader) {
326     require Cwd;
327     require File::Spec::Functions;
328     eval {
329      CORE::require(File::Spec::Functions::catfile(Cwd::getcwd(),"bleah.pm"));
330     };
331     if ($@ =~ /^This is an expected error/) {
332         print "ok $i - require(func())\n";
333     } else {
334         print "not ok $i - require(func())\n";
335     }
336 } else {
337     print "ok $i # SKIP Cwd may not be available in miniperl\n";
338 }
339
340 {
341     BEGIN { ${^OPEN} = ":utf8\0"; }
342     %INC = ();
343     write_file('bleah.pm',"package F; \$x = '\xD1\x9E';\n");
344     eval { require "bleah.pm" };
345     $i++;
346     my $not = $F::x eq "\xD1\x9E" ? "" : "not ";
347     print "${not}ok $i - require ignores I/O layers\n";
348 }
349
350 {
351     BEGIN { ${^OPEN} = ":utf8\0"; }
352     %INC = ();
353     write_file('bleah.pm',"require re; re->import('/x'); 1;\n");
354     my $not = eval 'use bleah; "ab" =~ /a b/' ? "" : "not ";
355     $i++;
356     print "${not}ok $i - require does not localise %^H at run time\n";
357 }
358
359
360 BEGIN {
361     # These are the test for feature 'module_true', which when in effect
362     # avoids the requirement for a module to return a true value, and
363     # in fact forces the return value to be a simple "true"
364     # (eg, PL_sv_yes, aka 1).
365     # we have a lot of permutations of how this code might trigger, and
366     # etc. so we set up the test set here.
367
368     my @params = (
369             'use v5.37',
370             'use feature ":5.38"',
371             'use feature ":all"',
372             'use feature "module_true"',
373             'no feature "module_true"',
374             '',
375         );
376     my @module_code = (
377             '',
378             'sub foo {};',
379             'sub foo {}; 0;',
380             'sub foo {}; return 0;',
381             'sub foo {}; return (0,0,"some_true_value");',
382             'sub foo {}; return ("some_true_value",1,1);',
383             'sub foo {}; (0, return 0);',
384             'sub foo {}; "some_true_value";',
385             'sub foo {}; return "some_true_value";',
386             'sub foo {}; (0, return "some_true_value");',
387             'sub foo {}; (0, return "some_true_value");',
388             undef,
389         );
390     my @eval_code = (
391             'use PACK;',
392             'require PACK;',
393             '$return_val = require PACK;',
394             '@return_val = require PACK;',
395             'require "PACK.pm";',
396             '$return_val = require "PACK.pm";',
397             '@return_val = require "PACK.pm";',
398     );
399
400     # build a list of tuples. for now this just keeps the test
401     # indent level reasonable for the main test loop, but we could
402     # compute this at BEGIN time and then add the number of tests
403     # to the total count
404     my %seen;
405     foreach my $debugger_state (0,0xA) {
406         foreach my $param_str (@params) {
407             foreach my $mod_code (@module_code) {
408                 foreach my $eval_code (@eval_code) {
409                     my $pack_name= sprintf "mttest%d", 0+@module_true_tests;
410                     my $eval_code_munged= $eval_code=~s/PACK/$pack_name/r;
411                     # this asks the debugger to preserve lines from evals.
412                     # it causes nextstate ops to convert to dbstate ops,
413                     # and we need to check that we can handle both cases.
414                     $eval_code_munged= '$^P = ' . $debugger_state .
415                                        '; ' . $eval_code_munged
416                         if $debugger_state;
417
418                     my $param_str_munged = $param_str;
419                     $param_str_munged .= ";\n" if $param_str;
420
421                     my $this_code= defined($mod_code)
422                         ? "package PACK;\n$param_str_munged$mod_code\n"
423                         : "";
424
425                     next if $seen{$eval_code_munged . "|" . $this_code}++;
426                     $this_code=~s/PACK/$pack_name/g;
427
428                     push @module_true_tests,
429                         [$pack_name, $param_str, $this_code, $mod_code, $eval_code_munged];
430
431                     if ($this_code!~/use/ and $this_code !~ /some_true_value/) {
432                         $module_true_test_count += 2;
433                     } elsif ($eval_code_munged=~/return_val/) {
434                         $module_true_test_count += 2;
435                     } else {
436                         $module_true_test_count += 1;
437                     }
438                 }
439             }
440         }
441     }
442
443     # and more later on
444     $module_true_test_count += 12;
445 }
446
447 {
448     foreach my $tuple (@module_true_tests) {
449         my ($pack_name, $param_str, $this_code, $mod_code, $eval_code)= @$tuple;
450
451         write_file("$pack_name.pm", $this_code);
452         %INC = ();
453         # these might be assigned to in the $eval_code
454         my $return_val;
455         my @return_val;
456
457         my $descr= !$this_code ? "empty file loaded" :
458                   !$mod_code ? "default behavior with `$mod_code`" :
459                   "`$param_str` with `$mod_code`";
460         $descr .= " via `$eval_code`";
461
462         my $not = eval "$eval_code 1" ? "" : "not ";
463         my $err= $not ? $@ : "";
464         $^P = 0; # turn the debugger off after the eval.
465
466         if ($this_code=~/use/) {
467             # test the various ways the feature can be turned on
468             $i++;
469             print "${not}ok $i - (AA) $descr did not blow up\n";
470             if ($not) {
471                 # we died, show the error:
472                 print "# error: $_\n" for split /\n/, $err;
473             }
474             if ($eval_code=~/\$return_val/) {
475                 $not = ($return_val && $return_val eq '1') ? "" : "not ";
476                 $i++;
477                 print "${not}ok $i - (AB) scalar return value "
478                       . "is simple true value <$return_val>\n";
479             }
480             elsif ($eval_code=~/\@return_val/) {
481                 $not = (@return_val && $return_val[0] eq '1') ? "" : "not ";
482                 $i++;
483                 print "${not}ok $i - (AB) list return value "
484                       . "is simple true value <$return_val[0]>\n";
485             }
486         } elsif ($this_code!~/some_true_value/) {
487             # test cases where the feature is not on and return false
488             my $not= $not ? "" : "not ";
489             $i++;
490             print "${not}ok $i - (BA) $descr should die\n";
491             if ($not) {
492                 print "# error: $_\n" for split /\n/, $err;
493                 print "# code: $_\n" for split /\n/, $this_code || "NO CODE";
494             }
495             $not= $err=~/did not return a true value/ ? "" : "not ";
496             $i++;
497             print "${not}ok $i - (BB) saw expected error\n";
498         } else {
499             #test cases where the feature is not on and return true
500             $i++;
501             print "${not}ok $i - (CA) $descr should not die\n";
502             if ($eval_code=~/return_val/) {
503                 $not = ($return_val || @return_val) ? "" : "not ";
504                 $i++;
505                 print "${not}ok $i - (CB) returned expected value\n";
506             }
507             if ($not) {
508                 print "# error: $_\n" for split /\n/, $err;
509                 print "# code: $_\n" for split /\n/, $this_code || "NO CODE";
510             }
511         }
512     }
513
514     {
515         write_file('blorn.pm', "package blorn;\nuse v5.37;\nsub foo {};\nno feature 'module_true';\n");
516
517         local $@;
518         my $result = 0;
519         my $not = eval "\$result = require 'blorn.pm'; 1" ? 'not ' : '';
520         $i++;
521         print "${not}ok $i - disabling module_true should not return a true value ($result)\n";
522         $not = $@ =~ /did not return a true value/ ? '' : 'not ';
523         $i++;
524         print "${not}ok $i - ... and should fail to compile without a true return value\n";
525     }
526
527     {
528         write_file('blunge.pm', "package blunge;\nuse feature ':5.38';\n".
529                                 "sub bar {};\nno feature 'module_true';\n3;\n");
530
531         local $@;
532         my $result = 0;
533         eval "\$result = require 'blunge.pm'; 1";
534         my $not = $result == 3 ? '' : 'not ';
535         $i++;
536         print "${not}ok $i - disabling 'module_true' and should not override module's return value ($result)\n";
537         $not = $@ eq '' ? '' : 'not ';
538         $i++;
539         print "${not}ok $i - ... but should compile successfully with a provided return value\n";
540     }
541     for $main::test_mode (1..4) {
542         my $pack= "Demo$main::test_mode";
543         write_file("$pack.pm", sprintf(<<'CODE', $pack)=~s/^#//mgr);
544 #package %s;
545 #use feature 'module_true';
546 #
547 #return 1 if $main::test_mode == 1;
548 #return 0 if $main::test_mode == 2;
549 #
550 #{
551 #  no feature 'module_true';
552 #  return 0 if $main::test_mode == 3;
553 #}
554 #no feature 'module_true';
555 CODE
556         local $@;
557         my $result = 0;
558         my $ok= eval "\$result = require '$pack.pm'; 1";
559         my $err= $ok ? "" : $@;
560         if ($main::test_mode >= 3) {
561             my $not = $ok  ? 'not ' : '';
562             $i++;
563             print "${not}ok $i - in $pack disabling module_true "
564                   . "should not return a true value ($result)\n";
565             $not = $err =~ /did not return a true value/ ? '' : 'not ';
566             $i++;
567             print "${not}ok $i - ... and should throw the expected error\n";
568             if ($not) {
569                 print "# $_\n" for split /\n/, $err;
570             }
571         } else {
572             my $not = $ok ? '' : 'not ';
573             $i++;
574             print "${not}ok $i - in $pack enabling module_true "
575                   . "should not return a true value ($result)\n";
576             $not = $result == 1 ? "" : "not ";
577             $i++;
578             print "${not}ok $i - ... and should return a simple true value\n";
579         }
580     }
581
582 }
583
584 ##########################################
585 # What follows are UTF-8 specific tests. #
586 # Add generic tests before this point.   #
587 ##########################################
588
589 # UTF-encoded things - skipped on UTF-8 input
590
591 if ($Is_UTF8) { exit; }
592
593 my %templates = (
594                  'UTF-8'    => 'C0U',
595                  'UTF-16BE' => 'n',
596                  'UTF-16LE' => 'v',
597                 );
598
599 sub bytes_to_utf {
600     my ($enc, $content, $do_bom) = @_;
601     my $template = $templates{$enc};
602     die "Unsupported encoding $enc" unless $template;
603     return pack "$template*", ($do_bom ? 0xFEFF : ()), unpack "C*", $content;
604 }
605
606 foreach (sort keys %templates) {
607     $i++; do_require(bytes_to_utf($_, qq(print "ok $i # $_\\n"; 1;\n), 1));
608     if ($@ =~ /^(Unsupported script encoding \Q$_\E)/) {
609         print "ok $i # skip $1\n";
610     }
611 }
612
613 END {
614     foreach my $file (@files_to_delete) {
615         1 while unlink $file;
616     }
617 }
618
619 # ***interaction with pod (don't put any thing after here)***
620
621 =pod