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