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 $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
  13 my $Is_UTF8   = (${^OPEN} || "") =~ /:utf8/;
  14 my $total_tests = 46;
  15 if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; }
  16 print "1..$total_tests\n";
  17
  18 sub do_require {
  19     %INC = ();
  20     write_file('bleah.pm',@_);
  21     eval { require "bleah.pm" };
  22     my @a; # magic guard for scope violations (must be first lexical in file)
  23 }
  24
  25 sub write_file {
  26     my $f = shift;
  27     open(REQ,">$f") or die "Can't write '$f': $!";
  28     binmode REQ;
  29     use bytes;
  30     print REQ @_;
  31     close REQ or die "Could not close $f: $!";
  32 }
  33
  34 eval {require 5.005};
  35 print "# $@\nnot " if $@;
  36 print "ok ",$i++,"\n";
  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 {
  47     require 5.005
  48 };
  49 print "# $@\nnot " if $@;
  50 print "ok ",$i++,"\n";
  51
  52 # new style version numbers
  53
  54 eval { require v5.5.630; };
  55 print "# $@\nnot " if $@;
  56 print "ok ",$i++,"\n";
  57
  58 eval { require 10.0.2; };
  59 print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
  60 print "ok ",$i++,"\n";
  61
  62 eval q{ use v5.5.630; };
  63 print "# $@\nnot " if $@;
  64 print "ok ",$i++,"\n";
  65
  66 eval q{ use 10.0.2; };
  67 print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
  68 print "ok ",$i++,"\n";
  69
  70 my $ver = 5.005_63;
  71 eval { require $ver; };
  72 print "# $@\nnot " if $@;
  73 print "ok ",$i++,"\n";
  74
  75 # check inaccurate fp
  76 $ver = 10.2;
  77 eval { require $ver; };
  78 print "# $@\nnot " unless $@ =~ /^Perl v10\.200.0 required/;
  79 print "ok ",$i++,"\n";
  80
  81 $ver = 10.000_02;
  82 eval { require $ver; };
  83 print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/;
  84 print "ok ",$i++,"\n";
  85
  86 print "not " unless 5.5.1 gt v5.5;
  87 print "ok ",$i++,"\n";
  88
  89 {
  90     print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}";
  91     print "ok ",$i++,"\n";
  92
  93     print "not " unless v7.15 eq "\x{7}\x{f}";
  94     print "ok ",$i++,"\n";
  95
  96     print "not "
  97       unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}";
  98     print "ok ",$i++,"\n";
  99 }
 100
 101 # interaction with pod (see the eof)
 102 write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
 103 require "bleah.pm";
 104 $i++;
 105
 106 # run-time failure in require
 107 do_require "0;\n";
 108 print "# $@\nnot " unless $@ =~ /did not return a true/;
 109 print "ok ",$i++,"\n";
 110
 111 print "not " if exists $INC{'bleah.pm'};
 112 print "ok ",$i++,"\n";
 113
 114 my $flag_file = 'bleah.flg';
 115 # run-time error in require
 116 for my $expected_compile (1,0) {
 117     write_file($flag_file, 1);
 118     print "not " unless -e $flag_file;
 119     print "ok ",$i++,"\n";
 120     write_file('bleah.pm', "unlink '$flag_file' or die; \$a=0; \$b=1/\$a; 1;\n");
 121     print "# $@\nnot " if eval { require 'bleah.pm' };
 122     print "ok ",$i++,"\n";
 123     print "not " unless -e $flag_file xor $expected_compile;
 124     print "ok ",$i++,"\n";
 125     print "not " unless exists $INC{'bleah.pm'};
 126     print "ok ",$i++,"\n";
 127 }
 128
 129 # compile-time failure in require
 130 do_require "1)\n";
 131 # bison says 'parse error' instead of 'syntax error',
 132 # various yaccs may or may not capitalize 'syntax'.
 133 print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi;
 134 print "ok ",$i++,"\n";
 135
 136 # previous failure cached in %INC
 137 print "not " unless exists $INC{'bleah.pm'};
 138 print "ok ",$i++,"\n";
 139 write_file($flag_file, 1);
 140 write_file('bleah.pm', "unlink '$flag_file'; 1");
 141 print "# $@\nnot " if eval { require 'bleah.pm' };
 142 print "ok ",$i++,"\n";
 143 print "# $@\nnot " unless $@ =~ /Compilation failed/i;
 144 print "ok ",$i++,"\n";
 145 print "not " unless -e $flag_file;
 146 print "ok ",$i++,"\n";
 147 print "not " unless exists $INC{'bleah.pm'};
 148 print "ok ",$i++,"\n";
 149
 150 # successful require
 151 do_require "1";
 152 print "# $@\nnot " if $@;
 153 print "ok ",$i++,"\n";
 154
 155 # do FILE shouldn't see any outside lexicals
 156 my $x = "ok $i\n";
 157 write_file("bleah.do", <<EOT);
 158 \$x = "not ok $i\\n";
 159 EOT
 160 do "bleah.do";
 161 dofile();
 162 sub dofile { do "bleah.do"; };
 163 print $x;
 164
 165 # Test that scalar context is forced for require
 166
 167 write_file('bleah.pm', <<'**BLEAH**'
 168 print "not " if !defined wantarray || wantarray ne '';
 169 print "ok $i - require() context\n";
 170 1;
 171 **BLEAH**
 172 );
 173                               delete $INC{"bleah.pm"}; ++$::i;
 174 $foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 175 @foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 176        eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 177        eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 178 $foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 179 @foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 180        eval  {require bleah};
 181
 182 # Test for fix of RT #24404 : "require $scalar" may load a directory
 183 my $r = "threads";
 184 eval { require $r };
 185 $i++;
 186 if($@ =~ /Can't locate threads in \@INC/) {
 187     print "ok $i\n";
 188 } else {
 189     print "not ok $i\n";
 190 }
 191
 192
 193 write_file('bleah.pm', qq(die "This is an expected error";\n));
 194 delete $INC{"bleah.pm"}; ++$::i;
 195 eval { CORE::require bleah; };
 196 if ($@ =~ /^This is an expected error/) {
 197     print "ok $i\n";
 198 } else {
 199     print "not ok $i\n";
 200 }
 201
 202 ##########################################
 203 # What follows are UTF-8 specific tests. #
 204 # Add generic tests before this point.   #
 205 ##########################################
 206
 207 # UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input
 208
 209 if ($Is_EBCDIC || $Is_UTF8) { exit; }
 210
 211 my $utf8 = chr(0xFEFF);
 212
 213 $i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
 214
 215 sub bytes_to_utf16 {
 216     my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
 217     return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16;
 218 }
 219
 220 $i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
 221 $i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE
 222
 223 END {
 224     1 while unlink 'bleah.pm';
 225     1 while unlink 'bleah.do';
 226     1 while unlink 'bleah.flg';
 227 }
 228
 229 # ***interaction with pod (don't put any thing after here)***
 230
 231 =pod