1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '.'; 6 push @INC, '../lib', '../ext/re'; 7} 8 9sub 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 19my @files_to_delete = qw (bleah.pm bleah.do bleah.flg urkkk.pm urkkk.pmc 20krunch.pm krunch.pmc whap.pm whap.pmc); 21 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 29if (grep -e, @files_to_delete) { 30 print "# Sleeping for 20 secs waiting for other process to finish\n"; 31 sleep 20; 32} 33 34 35my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; 36my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; 37my $total_tests = 58; 38if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } 39print "1..$total_tests\n"; 40 41sub write_file { 42 my $f = shift; 43 open(REQ,">$f") or die "Can't write '$f': $!"; 44 binmode REQ; 45 print REQ @_; 46 close REQ or die "Could not close $f: $!"; 47} 48 49eval {require 5.005}; 50print "# $@\nnot " if $@; 51print "ok ",$i++," - require 5.005 try 1\n"; 52 53eval { require 5.005 }; 54print "# $@\nnot " if $@; 55print "ok ",$i++," - require 5.005 try 2\n"; 56 57eval { require 5.005; }; 58print "# $@\nnot " if $@; 59print "ok ",$i++," - require 5.005 try 3\n"; 60 61eval { 62 require 5.005 63}; 64print "# $@\nnot " if $@; 65print "ok ",$i++," - require 5.005 try 4\n"; 66 67# new style version numbers 68 69eval { require v5.5.630; }; 70print "# $@\nnot " if $@; 71print "ok ",$i++," - require 5.5.630\n"; 72 73eval { require(v5.5.630); }; 74print "# $@\nnot " if $@; 75print "ok ",$i++," - require(v5.5.630) with parens [perl #124153]\n"; 76 77sub v5 { die } 78eval { require v5; }; 79print "# $@\nnot " if $@; 80print "ok ",$i++," - require v5 ignores sub named v5\n"; 81 82eval { require 10.0.2; }; 83print "# $@\nnot " unless $@ =~ /^\QPerl v10.0.2 required\E/; 84print "ok ",$i++," - require 10.0.2\n"; 85 86my $ver = 5.005_63; 87eval { require $ver; }; 88print "# $@\nnot " if $@; 89print "ok ",$i++," - require 5.005_63\n"; 90 91# check inaccurate fp 92$ver = 10.2; 93eval { require $ver; }; 94print "# $@\nnot " unless $@ =~ /^\QPerl v10.200.0 required\E/; 95print "ok ",$i++," - require 10.2\n"; 96 97$ver = 10.000_02; 98eval { require $ver; }; 99print "# $@\nnot " unless $@ =~ /^\QPerl v10.0.20 required\E/; 100print "ok ",$i++," - require 10.000_02\n"; 101 102print "not " unless 5.5.1 gt v5.5; 103print "ok ",$i++," - 5.5.1 gt v5.5\n"; 104 105{ 106 print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}"; 107 print "ok ",$i++," - v5.5.640 eq \\x{5}\\x{5}\\x{280}\n"; 108 109 print "not " unless v7.15 eq "\x{7}\x{f}"; 110 print "ok ",$i++," - v7.15 eq \\x{7}\\x{f}\n"; 111 112 print "not " 113 unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}"; 114 print "ok ",$i++," - v1.20.300.4000.50000.600000 eq ...\n"; 115} 116 117# "use 5.11.0" (and higher) loads strictures. 118# check that this doesn't happen with require 119eval 'require 5.11.0; ${"foo"} = "bar";'; 120print "# $@\nnot " if $@; 121print "ok ",$i++," - require 5.11.0\n"; 122eval 'BEGIN {require 5.11.0} ${"foo"} = "bar";'; 123print "# $@\nnot " if $@; 124print "ok ",$i++,"\ - BEGIN { require 5.11.0}\n"; 125 126# interaction with pod (see the eof) 127write_file('bleah.pm', "print 'ok $i - require bleah.pm\n'; 1;\n"); 128require "bleah.pm"; 129$i++; 130 131# run-time failure in require 132do_require "0;\n"; 133print "# $@\nnot " unless $@ =~ /did not return a true/; 134print "ok ",$i++," - require returning 0\n"; 135 136print "not " if exists $INC{'bleah.pm'}; 137print "ok ",$i++," - %INC not updated\n"; 138 139my $flag_file = 'bleah.flg'; 140# run-time error in require 141for my $expected_compile (1,0) { 142 write_file($flag_file, 1); 143 print "not " unless -e $flag_file; 144 print "ok ",$i++," - exp $expected_compile; bleah.flg\n"; 145 write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n"); 146 print "# $@\nnot " if eval { require 'bleah.pm' }; 147 print "ok ",$i++," - exp $expected_compile; require bleah.pm with flag file\n"; 148 print "not " unless -e $flag_file xor $expected_compile; 149 print "ok ",$i++," - exp $expected_compile; -e flag_file\n"; 150 print "not " unless exists $INC{'bleah.pm'}; 151 print "ok ",$i++," - exp $expected_compile; exists \$INC{'bleah.pm}\n"; 152} 153 154# compile-time failure in require 155do_require "1)\n"; 156# bison says 'parse error' instead of 'syntax error', 157# various yaccs may or may not capitalize 'syntax'. 158print "# $@\nnot " unless $@ =~ /(?:syntax|parse) error/mi; 159print "ok ",$i++," - syntax error\n"; 160 161# previous failure cached in %INC 162print "not " unless exists $INC{'bleah.pm'}; 163print "ok ",$i++," - cached %INC\n"; 164write_file($flag_file, 1); 165write_file('bleah.pm', "unlink '$flag_file'; 1"); 166print "# $@\nnot " if eval { require 'bleah.pm' }; 167print "ok ",$i++," - eval { require 'bleah.pm' }\n"; 168print "# $@\nnot " unless $@ =~ /Compilation failed/i; 169print "ok ",$i++," - Compilation failed\n"; 170print "not " unless -e $flag_file; 171print "ok ",$i++," - -e flag_file\n"; 172print "not " unless exists $INC{'bleah.pm'}; 173print "ok ",$i++," - \$INC{'bleah.pm'}\n"; 174 175# successful require 176do_require "1"; 177print "# $@\nnot " if $@; 178print "ok ",$i++," - do_require '1';\n"; 179 180# do FILE shouldn't see any outside lexicals 181my $x = "ok $i - bleah.do\n"; 182write_file("bleah.do", <<EOT); 183\$x = "not ok $i - bleah.do\\n"; 184EOT 185do "bleah.do" or die $@; 186dofile(); 187sub dofile { do "bleah.do" or die $@; }; 188print $x; 189 190# Test that scalar context is forced for require 191 192write_file('bleah.pm', <<'**BLEAH**' 193print "not " if !defined wantarray || wantarray ne ''; 194print "ok $i - require() context\n"; 1951; 196**BLEAH** 197); 198 delete $INC{"bleah.pm"}; ++$::i; 199$foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; 200@foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; 201 eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; 202 eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i; 203 eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i; 204$foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; 205@foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; 206 eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; 207 208eval 'require ::bleah;'; 209print "# $@\nnot " unless $@ =~ /^Bareword in require must not start with a double-colon:/; 210print "ok ", $i," - require ::bleah is banned\n"; 211 212# Test for fix of RT #24404 : "require $scalar" may load a directory 213my $r = "threads"; 214eval { require $r }; 215$i++; 216if($@ =~ /Can't locate threads in \@INC/) { 217 print "ok $i - RT #24404\n"; 218} else { 219 print "not ok - RT #24404$i\n"; 220} 221 222# require CORE::foo 223eval ' require CORE::lc "THREADS" '; 224$i++; 225if($@ =~ /Can't locate threads in \@INC/) { 226 print "ok $i - [perl #24482] require CORE::foo\n"; 227} else { 228 print "not ok - [perl #24482] require CORE::foo\n"; 229} 230 231 232write_file('bleah.pm', qq(die "This is an expected error";\n)); 233delete $INC{"bleah.pm"}; ++$::i; 234eval { CORE::require bleah; }; 235if ($@ =~ /^This is an expected error/) { 236 print "ok $i - expected error\n"; 237} else { 238 print "not ok $i - expected error\n"; 239} 240 241sub write_file_not_thing { 242 my ($file, $thing, $test) = @_; 243 write_file($file, <<"EOT"); 244 print "not ok $test - write_file_not_thing $file\n"; 245 die "The $thing file should not be loaded"; 246EOT 247} 248 249{ 250 # Right. We really really need Config here. 251 require Config; 252 die "Failed to load Config for some reason" 253 unless $Config::Config{version}; 254 255 my $simple = ++$i; 256 my $pmc_older = ++$i; 257 my $pmc_dies = ++$i; 258 my $no_pmc; 259 foreach(Config::non_bincompat_options()) { 260 if($_ eq "PERL_DISABLE_PMC"){ 261 $no_pmc = 1; 262 last; 263 } 264 } 265 if ($no_pmc) { 266 print "# .pmc files are ignored, so test that\n"; 267 write_file_not_thing('krunch.pmc', '.pmc', $pmc_older); 268 write_file('urkkk.pm', qq(print "ok $simple - urkkk.pm branch A\n")); 269 write_file('whap.pmc', qq(die "This is not an expected error")); 270 271 print "# Sleeping for 2 seconds before creating some more files\n"; 272 sleep 2; 273 274 write_file('krunch.pm', qq(print "ok $pmc_older - krunch.pm branch A\n")); 275 write_file_not_thing('urkkk.pmc', '.pmc', $simple); 276 write_file('whap.pm', qq(die "This is an expected error")); 277 } else { 278 print "# .pmc files should be loaded, so test that\n"; 279 write_file('krunch.pmc', qq(print "ok $pmc_older - krunch.pm branch B\n";)); 280 write_file_not_thing('urkkk.pm', '.pm', $simple); 281 write_file('whap.pmc', qq(die "This is an expected error")); 282 283 print "# Sleeping for 2 seconds before creating some more files\n"; 284 sleep 2; 285 286 write_file_not_thing('krunch.pm', '.pm', $pmc_older); 287 write_file('urkkk.pmc', qq(print "ok $simple - urkkk.pm branch B\n";)); 288 write_file_not_thing('whap.pm', '.pm', $pmc_dies); 289 } 290 require urkkk; 291 require krunch; 292 eval {CORE::require whap; 1} and die; 293 294 if ($@ =~ /^This is an expected error/) { 295 print "ok $pmc_dies - pmc_dies\n"; 296 } else { 297 print "not ok $pmc_dies - pmc_dies\n"; 298 } 299} 300 301 302{ 303 # if we 'require "op"', since we're in the t/ directory and '.' is the 304 # first thing in @INC, it will try to load t/op/; it should fail and 305 # move onto the next path; however, the previous value of $! was 306 # leaking into implementation if it was EACCES and we're accessing a 307 # directory. 308 309 $! = eval 'use Errno qw(EACCES); EACCES' || 0; 310 eval q{require 'op'}; 311 $i++; 312 print "not " if $@ =~ /Permission denied/; 313 print "ok $i - require op\n"; 314} 315 316# Test "require func()" with abs path when there is no .pmc file. 317++$::i; 318if (defined &DynaLoader::boot_DynaLoader) { 319 require Cwd; 320 require File::Spec::Functions; 321 eval { 322 CORE::require(File::Spec::Functions::catfile(Cwd::getcwd(),"bleah.pm")); 323 }; 324 if ($@ =~ /^This is an expected error/) { 325 print "ok $i - require(func())\n"; 326 } else { 327 print "not ok $i - require(func())\n"; 328 } 329} else { 330 print "ok $i # SKIP Cwd may not be available in miniperl\n"; 331} 332 333{ 334 BEGIN { ${^OPEN} = ":utf8\0"; } 335 %INC = (); 336 write_file('bleah.pm',"package F; \$x = '\xD1\x9E';\n"); 337 eval { require "bleah.pm" }; 338 $i++; 339 my $not = $F::x eq "\xD1\x9E" ? "" : "not "; 340 print "${not}ok $i - require ignores I/O layers\n"; 341} 342 343{ 344 BEGIN { ${^OPEN} = ":utf8\0"; } 345 %INC = (); 346 write_file('bleah.pm',"require re; re->import('/x'); 1;\n"); 347 my $not = eval 'use bleah; "ab" =~ /a b/' ? "" : "not "; 348 $i++; 349 print "${not}ok $i - require does not localise %^H at run time\n"; 350} 351 352########################################## 353# What follows are UTF-8 specific tests. # 354# Add generic tests before this point. # 355########################################## 356 357# UTF-encoded things - skipped on UTF-8 input 358 359if ($Is_UTF8) { exit; } 360 361my %templates = ( 362 'UTF-8' => 'C0U', 363 'UTF-16BE' => 'n', 364 'UTF-16LE' => 'v', 365 ); 366 367sub bytes_to_utf { 368 my ($enc, $content, $do_bom) = @_; 369 my $template = $templates{$enc}; 370 die "Unsupported encoding $enc" unless $template; 371 return pack "$template*", ($do_bom ? 0xFEFF : ()), unpack "C*", $content; 372} 373 374foreach (sort keys %templates) { 375 $i++; do_require(bytes_to_utf($_, qq(print "ok $i # $_\\n"; 1;\n), 1)); 376 if ($@ =~ /^(Unsupported script encoding \Q$_\E)/) { 377 print "ok $i # skip $1\n"; 378 } 379} 380 381END { 382 foreach my $file (@files_to_delete) { 383 1 while unlink $file; 384 } 385} 386 387# ***interaction with pod (don't put any thing after here)*** 388 389=pod 390