1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
#!./perl
BEGIN {
chdir 't' if -d 't';
@INC = '.';
push @INC, '../lib';
}
# don't make this lexical
$i = 1;
my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/;
my $total_tests = 30;
if ($Is_EBCDIC || $Is_UTF8) { $total_tests = 27; }
print "1..$total_tests\n";
sub do_require {
%INC = ();
write_file('bleah.pm',@_);
eval { require "bleah.pm" };
my @a; # magic guard for scope violations (must be first lexical in file)
}
sub write_file {
my $f = shift;
open(REQ,">$f") or die "Can't write '$f': $!";
binmode REQ;
use bytes;
print REQ @_;
close REQ or die "Could not close $f: $!";
}
eval {require 5.005};
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval { require 5.005 };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval { require 5.005; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval {
require 5.005
};
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# new style version numbers
eval { require v5.5.630; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval { require 10.0.2; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
print "ok ",$i++,"\n";
eval q{ use v5.5.630; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
eval q{ use 10.0.2; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.2 required/;
print "ok ",$i++,"\n";
my $ver = 5.005_63;
eval { require $ver; };
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# check inaccurate fp
$ver = 10.2;
eval { require $ver; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.200\.0 required/;
print "ok ",$i++,"\n";
$ver = 10.000_02;
eval { require $ver; };
print "# $@\nnot " unless $@ =~ /^Perl v10\.0\.20 required/;
print "ok ",$i++,"\n";
print "not " unless 5.5.1 gt v5.5;
print "ok ",$i++,"\n";
{
print "not " unless v5.5.640 eq "\x{5}\x{5}\x{280}";
print "ok ",$i++,"\n";
print "not " unless v7.15 eq "\x{7}\x{f}";
print "ok ",$i++,"\n";
print "not "
unless v1.20.300.4000.50000.600000 eq "\x{1}\x{14}\x{12c}\x{fa0}\x{c350}\x{927c0}";
print "ok ",$i++,"\n";
}
# interaction with pod (see the eof)
write_file('bleah.pm', "print 'ok $i\n'; 1;\n");
require "bleah.pm";
$i++;
# run-time failure in require
do_require "0;\n";
print "# $@\nnot " unless $@ =~ /did not return a true/;
print "ok ",$i++,"\n";
# compile-time failure in require
do_require "1)\n";
# bison says 'parse error' instead of 'syntax error',
# various yaccs may or may not capitalize 'syntax'.
print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi;
print "ok ",$i++,"\n";
# successful require
do_require "1";
print "# $@\nnot " if $@;
print "ok ",$i++,"\n";
# do FILE shouldn't see any outside lexicals
my $x = "ok $i\n";
write_file("bleah.do", <<EOT);
\$x = "not ok $i\\n";
EOT
do "bleah.do";
dofile();
sub dofile { do "bleah.do"; };
print $x;
# Test that scalar context is forced for require
write_file('bleah.pm', <<'**BLEAH**'
print "not " if !defined wantarray || wantarray ne '';
print "ok $i - require() context\n";
1;
**BLEAH**
);
delete $INC{"bleah.pm"}; ++$::i;
$foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval q{$_=$_+2;require bleah}; delete $INC{"bleah.pm"}; ++$::i;
$foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
@foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
eval {require bleah};
# UTF-encoded things - skipped on EBCDIC machines and on UTF-8 input
if ($Is_EBCDIC || $Is_UTF8) { exit; }
my $utf8 = chr(0xFEFF);
$i++; do_require(qq(${utf8}print "ok $i\n"; 1;\n));
sub bytes_to_utf16 {
my $utf16 = pack("$_[0]*", unpack("C*", $_[1]));
return @_ == 3 && $_[2] ? pack("$_[0]", 0xFEFF) . $utf16 : $utf16;
}
$i++; do_require(bytes_to_utf16('n', qq(print "ok $i\\n"; 1;\n), 1)); # BE
$i++; do_require(bytes_to_utf16('v', qq(print "ok $i\\n"; 1;\n), 1)); # LE
END { 1 while unlink 'bleah.pm'; 1 while unlink 'bleah.do'; }
# ***interaction with pod (don't put any thing after here)***
=pod
|
