t/comp/require.t

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