1#!perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc( qw(../lib) ); 7} 8 9use strict; 10use warnings; 11 12plan(tests => 73); 13 14 15# Dedupe @INC. In a future patch we /may/ refuse to process items 16# more than once and deduping here will prevent the tests from failing 17# should we make that change. 18my %seen; @INC = grep {!$seen{$_}++} @INC; 19 20my $nonfile = tempfile(); 21 22# The tests for ' ' and '.h' never did fail, but previously the error reporting 23# code would read memory before the start of the SV's buffer 24 25for my $file ($nonfile, ' ') { 26 eval { 27 require $file; 28 }; 29 30 like $@, qr/^Can't locate $file in \@INC \(\@INC[\w ]+: \Q@INC\E\) at/, 31 "correct error message for require '$file'"; 32} 33 34# Check that the "(you may need to install..) hint is included in the 35# error message where (and only where) appropriate. 36# 37# Basically the hint should be issued for any filename where converting 38# back from Foo/Bar.pm to Foo::Bar gives you a legal bare word which could 39# follow "require" in source code. 40 41{ 42 43 # may be any letter of an identifier 44 my $I = "\x{393}"; # "\N{GREEK CAPITAL LETTER GAMMA}" 45 # Continuation char: may only be 2nd+ letter of an identifier 46 my $C = "\x{387}"; # "\N{GREEK ANO TELEIA}" 47 48 for my $test_data ( 49 # thing to require pathname in err mesg err includes hint? 50 [ "No::Such::Module1", "No/Such/Module1.pm", 1 ], 51 [ "'No/Such/Module1.pm'", "No/Such/Module1.pm", 1 ], 52 [ "_No::Such::Module1", "_No/Such/Module1.pm", 1 ], 53 [ "'_No/Such/Module1.pm'", "_No/Such/Module1.pm", 1 ], 54 [ "'No/Such./Module.pm'", "No/Such./Module.pm", 0 ], 55 [ "No::1Such::Module", "No/1Such/Module.pm", 1 ], 56 [ "'No/1Such/Module.pm'", "No/1Such/Module.pm", 1 ], 57 [ "1No::Such::Module", undef, 0 ], 58 [ "'1No/Such/Module.pm'", "1No/Such/Module.pm", 0 ], 59 60 # utf8 variants 61 [ "No::Such${I}::Module1", "No/Such${I}/Module1.pm", 1 ], 62 [ "'No/Such${I}/Module1.pm'", "No/Such${I}/Module1.pm", 1 ], 63 [ "_No::Such${I}::Module1", "_No/Such${I}/Module1.pm", 1 ], 64 [ "'_No/Such${I}/Module1.pm'", "_No/Such${I}/Module1.pm", 1 ], 65 [ "'No/Such${I}./Module.pm'", "No/Such${I}./Module.pm", 0 ], 66 [ "No::1Such${I}::Module", "No/1Such${I}/Module.pm", 1 ], 67 [ "'No/1Such${I}/Module.pm'", "No/1Such${I}/Module.pm", 1 ], 68 [ "1No::Such${I}::Module", undef, 0 ], 69 [ "'1No/Such${I}/Module.pm'", "1No/Such${I}/Module.pm", 0 ], 70 71 # utf8 with continuation char in 1st position 72 [ "No::${C}Such::Module1", undef, 0 ], 73 [ "'No/${C}Such/Module1.pm'", "No/${C}Such/Module1.pm", 0 ], 74 [ "_No::${C}Such::Module1", undef, 0 ], 75 [ "'_No/${C}Such/Module1.pm'", "_No/${C}Such/Module1.pm", 0 ], 76 [ "'No/${C}Such./Module.pm'", "No/${C}Such./Module.pm", 0 ], 77 [ "No::${C}1Such::Module", undef, 0 ], 78 [ "'No/${C}1Such/Module.pm'", "No/${C}1Such/Module.pm", 0 ], 79 [ "1No::${C}Such::Module", undef, 0 ], 80 [ "'1No/${C}Such/Module.pm'", "1No/${C}Such/Module.pm", 0 ], 81 82 ) { 83 my ($require_arg, $err_path, $has_hint) = @$test_data; 84 85 my $exp; 86 if (defined $err_path) { 87 $exp = "Can't locate $err_path in \@INC"; 88 if ($has_hint) { 89 my $hint = $err_path; 90 $hint =~ s{/}{::}g; 91 $hint =~ s/\.pm$//; 92 $exp .= " (you may need to install the $hint module)"; 93 } 94 $exp .= " (\@INC entries checked: @INC) at"; 95 } 96 else { 97 # undef implies a require which doesn't compile, 98 # rather than one which triggers a run-time error. 99 # We'll set exp to a suitable value later; 100 $exp = ""; 101 } 102 103 my $err; 104 { 105 no warnings qw(syntax utf8); 106 if ($require_arg =~ /[^\x00-\xff]/) { 107 eval "require $require_arg"; 108 $err = $@; 109 utf8::decode($err); 110 } 111 else { 112 eval "require $require_arg"; 113 $err = $@; 114 } 115 } 116 117 for ($err, $exp, $require_arg) { 118 s/([^\x00-\xff])/sprintf"\\x{%x}",ord($1)/ge; 119 } 120 if (length $exp) { 121 $exp = qr/^\Q$exp\E/; 122 } 123 else { 124 $exp = qr/syntax error at|Unrecognized character/; 125 } 126 like $err, $exp, 127 "err for require $require_arg"; 128 } 129} 130 131 132 133eval "require ::$nonfile"; 134 135like $@, qr/^Bareword in require must not start with a double-colon:/, 136 "correct error message for require ::$nonfile"; 137 138eval { 139 require "$nonfile.ph"; 140}; 141 142like $@, qr/^Can't locate $nonfile\.ph in \@INC \(did you run h2ph\?\) \(\@INC[\w ]+: @INC\) at/; 143 144for my $file ("$nonfile.h", ".h") { 145 eval { 146 require $file 147 }; 148 149 like $@, qr/^Can't locate \Q$file\E in \@INC \(change \.h to \.ph maybe\?\) \(did you run h2ph\?\) \(\@INC[\w ]+: @INC\) at/, 150 "correct error message for require '$file'"; 151} 152 153for my $file ("$nonfile.ph", ".ph") { 154 eval { 155 require $file 156 }; 157 158 like $@, qr/^Can't locate \Q$file\E in \@INC \(did you run h2ph\?\) \(\@INC[\w ]+: @INC\) at/, 159 "correct error message for require '$file'"; 160} 161 162eval 'require <foom>'; 163like $@, qr/^<> at require-statement should be quotes at /, 'require <> error'; 164 165my $module = tempfile(); 166my $mod_file = "$module.pm"; 167 168open my $module_fh, ">", $mod_file or die $!; 169print { $module_fh } "print 1; 1;\n"; 170close $module_fh; 171 172chmod 0333, $mod_file; 173 174SKIP: { 175 skip_if_miniperl("these modules may not be available to miniperl", 2); 176 177 push @INC, '../lib'; 178 require Cwd; 179 require File::Spec::Functions; 180 if ($^O eq 'cygwin') { 181 require Win32; 182 } 183 184 # Going to try to switch away from root. Might not work. 185 # (stolen from t/op/stat.t) 186 my $olduid = $>; 187 eval { $> = 1; }; 188 skip "Can't test permissions meaningfully if you're superuser", 2 189 if ($^O eq 'cygwin' ? Win32::IsAdminUser() : $> == 0); 190 191 local @INC = "."; 192 eval "use $module"; 193 like $@, 194 qr<^\QCan't locate $mod_file:>, 195 "special error message if the file exists but can't be opened"; 196 197 SKIP: { 198 skip "Can't make the path absolute", 1 199 if !defined(Cwd::getcwd()); 200 201 my $file = File::Spec::Functions::catfile(Cwd::getcwd(), $mod_file); 202 eval { 203 require($file); 204 }; 205 like $@, 206 qr<^\QCan't locate $file:>, 207 "...even if we use a full path"; 208 } 209 210 # switch uid back (may not be implemented) 211 eval { $> = $olduid; }; 212} 213 2141 while unlink $mod_file; 215 216# I can't see how to test the EMFILE case 217# I can't see how to test the case of not displaying @INC in the message. 218# (and does that only happen on VMS?) 219 220# fail and print the full filename 221eval { no warnings 'syscalls'; require "strict.pm\0invalid"; }; 222like $@, qr/^Can't locate strict\.pm\\0invalid: /, 'require nul check [perl #117265]'; 223{ 224 my $WARN; 225 local $SIG{__WARN__} = sub { $WARN = shift }; 226 { 227 my $ret = do "strict.pm\0invalid"; 228 my $exc = $@; 229 my $err = $!; 230 is $ret, undef, 'do nulstring returns undef'; 231 is $exc, '', 'do nulstring clears $@'; 232 $! = $err; 233 ok $!{ENOENT}, 'do nulstring fails with ENOENT'; 234 like $WARN, qr{^Invalid \\0 character in pathname for do: strict\.pm\\0invalid at }, 'do nulstring warning'; 235 } 236 237 $WARN = ''; 238 eval { require "strict.pm\0invalid"; }; 239 like $WARN, qr{^Invalid \\0 character in pathname for require: strict\.pm\\0invalid at }, 'nul warning'; 240 like $@, qr{^Can't locate strict\.pm\\0invalid: }, 'nul error'; 241 242 $WARN = ''; 243 local @INC = @INC; 244 set_up_inc( "lib\0invalid" ); 245 eval { require "unknown.pm" }; 246 like $WARN, qr{^Invalid \\0 character in \@INC entry for require: lib\\0invalid at }, 'nul warning'; 247} 248eval "require strict\0::invalid;"; 249like $@, qr/^syntax error at \(eval \d+\) line 1/, 'parse error with \0 in barewords module names'; 250 251# Refs and globs that stringify with embedded nulls 252# These crashed from 5.20 to 5.24 [perl #128182]. 253eval { no warnings 'syscalls'; require eval "qr/\0/" }; 254like $@, qr/^Can't locate \(\?\^:\\0\):/, 255 'require ref that stringifies with embedded null'; 256eval { no strict; no warnings 'syscalls'; require *{"\0a"} }; 257like $@, qr/^Can't locate \*main::\\0a:/, 258 'require ref that stringifies with embedded null'; 259 260eval { require undef }; 261like $@, qr/^Missing or undefined argument to require /; 262 263eval { do undef }; 264like $@, qr/^Missing or undefined argument to do /; 265 266eval { require "" }; 267like $@, qr/^Missing or undefined argument to require /; 268 269eval { do "" }; 270like $@, qr/^Missing or undefined argument to do /; 271 272# non-searchable pathnames shouldn't mention @INC in the error 273 274my $nonsearch = "./no_such_file.pm"; 275 276eval "require \"$nonsearch\""; 277 278like $@, qr/^Can't locate \Q$nonsearch\E at/, 279 "correct error message for require $nonsearch"; 280 281{ 282 # make sure require doesn't treat a non-PL_sv_undef undef as 283 # success in %INC 284 # GH #17428 285 push @INC, "lib"; 286 ok(!eval { require CannotParse; }, "should fail to load"); 287 local %INC = %INC; # copies \&PL_sv_undef into a new undef 288 ok(!eval { require CannotParse; }, 289 "check the second attempt also fails"); 290 like $@, qr/Attempt to reload/, "check we failed for the right reason"; 291} 292 293{ 294 fresh_perl_like( 295 'unshift @INC, sub { sub { 0 } }; require "asdasd";', 296 qr/asdasd did not return a true value/, 297 { }, '@INC hook blocks do not cause segfault'); 298} 299 300{ 301 # make sure that modifications to %INC during an INC hooks lifetime 302 # don't result in us having an empty string for the cop_file. 303 # Older perls will output "error at line 1". 304 305 fresh_perl_like( 306 'use lib qq(./lib); BEGIN{ unshift @INC, ' 307 .'sub { if ($_[1] eq "CannotParse.pm" and !$seen++) { ' 308 .'eval q(require $_[1]); warn $@; my $code= qq[die qq(error)];' 309 .'open my $fh,"<", q(lib/Dies.pm); return $fh } } } require CannotParse;', 310 qr!\Asyntax error.*?^error at /loader/0x[A-Fa-f0-9]+/CannotParse\.pm line 1\.!ms, 311 { }, 'Inc hooks have the correct cop_file'); 312} 313{ 314 # this can segfault or assert prior to @INC hardening. 315 fresh_perl_like( 316 'unshift @INC, sub { *INC=["a","b"] }; ' 317 .'eval "require Frobnitz" or print $@', 318 qr!\(\@INC[\w ]+: CODE\(0x[A-Fa-f0-9]+\) b\)!, 319 { }, 'INC hooks do not segfault when overwritten'); 320} 321{ 322 # this is the defined behavior, but in older perls the error message 323 # would lie and say "contains: a b", which is true in the sense that 324 # it is the value of @INC after the require, but not the directory 325 # list that was looked at. 326 fresh_perl_like( 327 '@INC = (sub { @INC=("a","b"); () }, "z"); ' 328 .'eval "require Frobnitz" or print $@', 329 qr!\(\@INC[\w ]+: CODE\(0x[A-Fa-f0-9]+\) b\)!, 330 { }, 'INC hooks that overwrite @INC continue as expected (skips a and z)'); 331} 332{ 333 # as of 5.37.7 334 fresh_perl_like( 335 '@INC = (sub { @INC=qw(a b); undef $INC }, "z"); ' 336 .'eval "require Frobnitz" or print $@', 337 qr!\(\@INC[\w ]+: CODE\(0x[A-Fa-f0-9]+\) a b\)!, 338 { }, 'INC hooks that overwrite @INC and undef $INC continue at start'); 339} 340{ 341 # as of 5.37.7 342 fresh_perl_like( 343 'sub CB::INCDIR { return "b", "c","d" }; ' 344 .'@INC = ("a",bless({},"CB"),"e");' 345 .'eval "require Frobnitz" or print $@', 346 qr!\(\@INC[\w ]+: a CB=HASH\(0x[A-Fa-f0-9]+\) b c d e\)!, 347 { }, 'INCDIR works as expected'); 348} 349{ 350 # as of 5.37.7 351 fresh_perl_like( 352 '@INC = ("a",bless({},"CB"),"e");' 353 .'eval "require Frobnitz" or print $@', 354 qr!Can't locate object method "INC", nor "INCDIR" nor string overload via package "CB" in object hook in \@INC!, 355 { }, 'Objects with no INC or INCDIR method and no overload throw an error'); 356} 357{ 358 # as of 5.37.7 359 fresh_perl_like( 360 'package CB { use overload q("") => sub { "Fnorble" };} @INC = ("a",bless({},"CB"),"e");' 361 .'eval "require Frobnitz" or print $@', 362 qr!\(\@INC[\w ]+: a Fnorble e\)!, 363 { }, 'Objects with no INC or INCDIR method but with an overload are stringified'); 364} 365{ 366 # as of 5.37.7 367 fresh_perl_like( 368 'package CB { use overload q(0+) => sub { 12345 }, fallback=>1;} @INC = ("a",bless({},"CB"),"e");' 369 .'eval "require Frobnitz" or print $@', 370 qr!\(\@INC[\w ]+: a 12345 e\)!, 371 { }, 'Objects with no INC or INCDIR method but with an overload with fallback are stringified'); 372} 373{ 374 # as of 5.37.7 375 fresh_perl_like( 376 '{package CB; use overload qw("")=>sub { "blorg"};} ' 377 .'@INC = ("a",bless({},"CB"),"e");' 378 .'eval "require Frobnitz" or print $@', 379 qr!\(\@INC[\w ]+: a blorg e\)!, 380 { }, 'Objects with overload and no INC or INCDIR method are stringified'); 381} 382{ 383 # as of 5.37.7 384 fresh_perl_like( 385 '@INC = ("a",bless(sub { warn "blessed sub called" },"CB"),"e");' 386 .'eval "require Frobnitz" or print $@', 387 qr!blessed sub called.*\(\@INC[\w ]+: a CB=CODE\(0x[a-fA-F0-9]+\) e\)!s, 388 { }, 'Blessed subs with no hook methods are executed'); 389} 390{ 391 # as of 5.37.7 392 fresh_perl_like( 393 '@INC = ("a",bless(sub { die "blessed sub called" },"CB"),"e");' 394 .'eval "require Frobnitz" or print $@', 395 qr!INC sub hook died--halting \@INC search!s, 396 { }, 'Blessed subs that die produce expected extra message'); 397} 398{ 399 # as of 5.37.7 400 fresh_perl_like( 401 'sub CB::INC { die "bad mojo" } ' 402 .'@INC = ("a",bless(sub { die "blessed sub called" },"CB"),"e");' 403 .'eval "require Frobnitz" or print $@', 404 qr!bad mojo.*INC method hook died--halting \@INC search!s, 405 { }, 'Blessed subs with methods call method and produce expected message'); 406} 407{ 408 # as of 5.37.7 409 fresh_perl_like( 410 '@INC = ("a",[bless([],"CB"),1],"e");' 411 .'eval "require Frobnitz" or print $@', 412 qr!Can't locate object method "INC", nor "INCDIR" nor string overload via package "CB" in object in ARRAY hook in \@INC!s, 413 { }, 'Blessed objects with no hook methods in array form produce expected exception'); 414} 415{ 416 # as of 5.37.7 417 fresh_perl_like( 418 'sub CB::INCDIR { "i" } sub CB2::INCDIR { }' 419 .'@INC = ("a",bless(sub{"b"},"CB"),bless(sub{"c"},"CB2"),"e");' 420 .'eval "require Frobnitz" or print $@', 421 qr!\(\@INC[\w ]+: a CB=CODE\(0x[a-fA-F0-9]+\) i CB2=CODE\(0x[a-fA-F0-9]+\) e\)!s, 422 { }, 'Blessed subs with INCDIR methods call INCDIR'); 423} 424{ 425 # as of 5.37.7 426 fresh_perl_like( 427 'sub CB::INCDIR { return @{$_[2]} }' 428 .'@INC = ("a",[bless([],"CB"),"b"],"c");' 429 .'eval "require Frobnitz" or print $@', 430 qr!\(\@INC[\w ]+: a ARRAY\(0x[a-fA-F0-9]+\) CB=ARRAY\(0x[a-fA-F0-9]+\) b c\)!s, 431 { }, 'INCDIR ref returns are stringified'); 432} 433