Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / inccode.t
1 #!./perl -w
2
3 # Tests for the coderef-in-@INC feature
4
5 use Config;
6
7 my $can_fork   = 0;
8 my $minitest   = $ENV{PERL_CORE_MINITEST};
9 my $has_perlio = $Config{useperlio};
10
11 BEGIN {
12     chdir 't' if -d 't';
13     @INC = qw(. ../lib);
14 }
15
16 if (!$minitest) {
17     if ($Config{d_fork} && eval 'require POSIX; 1') {
18         $can_fork = 1;
19     }
20 }
21
22 use strict;
23 use File::Spec;
24
25 require "test.pl";
26 plan(tests => 45 + !$minitest * (3 + 14 * $can_fork));
27
28 my @tempfiles = ();
29
30 sub get_temp_fh {
31     my $f = "DummyModule0000";
32     1 while -e ++$f;
33     push @tempfiles, $f;
34     open my $fh, ">$f" or die "Can't create $f: $!";
35     print $fh "package ".substr($_[0],0,-3).";\n1;\n";
36     print $fh $_[1] if @_ > 1;
37     close $fh or die "Couldn't close: $!";
38     open $fh, $f or die "Can't open $f: $!";
39     return $fh;
40 }
41
42 END { 1 while unlink @tempfiles }
43
44 sub fooinc {
45     my ($self, $filename) = @_;
46     if (substr($filename,0,3) eq 'Foo') {
47         return get_temp_fh($filename);
48     }
49     else {
50         return undef;
51     }
52 }
53
54 push @INC, \&fooinc;
55
56 my $evalret = eval { require Bar; 1 };
57 ok( !$evalret,      'Trying non-magic package' );
58
59 $evalret = eval { require Foo; 1 };
60 die $@ if $@;
61 ok( $evalret,                      'require Foo; magic via code ref'  );
62 ok( exists $INC{'Foo.pm'},         '  %INC sees Foo.pm' );
63 is( ref $INC{'Foo.pm'}, 'CODE',    '  val Foo.pm is a coderef in %INC' );
64 is( $INC{'Foo.pm'}, \&fooinc,      '  val Foo.pm is correct in %INC' );
65
66 $evalret = eval "use Foo1; 1;";
67 die $@ if $@;
68 ok( $evalret,                      'use Foo1' );
69 ok( exists $INC{'Foo1.pm'},        '  %INC sees Foo1.pm' );
70 is( ref $INC{'Foo1.pm'}, 'CODE',   '  val Foo1.pm is a coderef in %INC' );
71 is( $INC{'Foo1.pm'}, \&fooinc,     '  val Foo1.pm is correct in %INC' );
72
73 $evalret = eval { do 'Foo2.pl'; 1 };
74 die $@ if $@;
75 ok( $evalret,                      'do "Foo2.pl"' );
76 ok( exists $INC{'Foo2.pl'},        '  %INC sees Foo2.pl' );
77 is( ref $INC{'Foo2.pl'}, 'CODE',   '  val Foo2.pl is a coderef in %INC' );
78 is( $INC{'Foo2.pl'}, \&fooinc,     '  val Foo2.pl is correct in %INC' );
79
80 pop @INC;
81
82
83 sub fooinc2 {
84     my ($self, $filename) = @_;
85     if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
86         return get_temp_fh($filename);
87     }
88     else {
89         return undef;
90     }
91 }
92
93 my $arrayref = [ \&fooinc2, 'Bar' ];
94 push @INC, $arrayref;
95
96 $evalret = eval { require Foo; 1; };
97 die $@ if $@;
98 ok( $evalret,                     'Originally loaded packages preserved' );
99 $evalret = eval { require Foo3; 1; };
100 ok( !$evalret,                    'Original magic INC purged' );
101
102 $evalret = eval { require Bar; 1 };
103 die $@ if $@;
104 ok( $evalret,                     'require Bar; magic via array ref' );
105 ok( exists $INC{'Bar.pm'},        '  %INC sees Bar.pm' );
106 is( ref $INC{'Bar.pm'}, 'ARRAY',  '  val Bar.pm is an arrayref in %INC' );
107 is( $INC{'Bar.pm'}, $arrayref,    '  val Bar.pm is correct in %INC' );
108
109 ok( eval "use Bar1; 1;",          'use Bar1' );
110 ok( exists $INC{'Bar1.pm'},       '  %INC sees Bar1.pm' );
111 is( ref $INC{'Bar1.pm'}, 'ARRAY', '  val Bar1.pm is an arrayref in %INC' );
112 is( $INC{'Bar1.pm'}, $arrayref,   '  val Bar1.pm is correct in %INC' );
113
114 ok( eval { do 'Bar2.pl'; 1 },     'do "Bar2.pl"' );
115 ok( exists $INC{'Bar2.pl'},       '  %INC sees Bar2.pl' );
116 is( ref $INC{'Bar2.pl'}, 'ARRAY', '  val Bar2.pl is an arrayref in %INC' );
117 is( $INC{'Bar2.pl'}, $arrayref,   '  val Bar2.pl is correct in %INC' );
118
119 pop @INC;
120
121 sub FooLoader::INC {
122     my ($self, $filename) = @_;
123     if (substr($filename,0,4) eq 'Quux') {
124         return get_temp_fh($filename);
125     }
126     else {
127         return undef;
128     }
129 }
130
131 my $href = bless( {}, 'FooLoader' );
132 push @INC, $href;
133
134 $evalret = eval { require Quux; 1 };
135 die $@ if $@;
136 ok( $evalret,                      'require Quux; magic via hash object' );
137 ok( exists $INC{'Quux.pm'},        '  %INC sees Quux.pm' );
138 is( ref $INC{'Quux.pm'}, 'FooLoader',
139                                    '  val Quux.pm is an object in %INC' );
140 is( $INC{'Quux.pm'}, $href,        '  val Quux.pm is correct in %INC' );
141
142 pop @INC;
143
144 my $aref = bless( [], 'FooLoader' );
145 push @INC, $aref;
146
147 $evalret = eval { require Quux1; 1 };
148 die $@ if $@;
149 ok( $evalret,                      'require Quux1; magic via array object' );
150 ok( exists $INC{'Quux1.pm'},       '  %INC sees Quux1.pm' );
151 is( ref $INC{'Quux1.pm'}, 'FooLoader',
152                                    '  val Quux1.pm is an object in %INC' );
153 is( $INC{'Quux1.pm'}, $aref,       '  val Quux1.pm  is correct in %INC' );
154
155 pop @INC;
156
157 my $sref = bless( \(my $x = 1), 'FooLoader' );
158 push @INC, $sref;
159
160 $evalret = eval { require Quux2; 1 };
161 die $@ if $@;
162 ok( $evalret,                      'require Quux2; magic via scalar object' );
163 ok( exists $INC{'Quux2.pm'},       '  %INC sees Quux2.pm' );
164 is( ref $INC{'Quux2.pm'}, 'FooLoader',
165                                    '  val Quux2.pm is an object in %INC' );
166 is( $INC{'Quux2.pm'}, $sref,       '  val Quux2.pm is correct in %INC' );
167
168 pop @INC;
169
170 push @INC, sub {
171     my ($self, $filename) = @_;
172     if (substr($filename,0,4) eq 'Toto') {
173         $INC{$filename} = 'xyz';
174         return get_temp_fh($filename);
175     }
176     else {
177         return undef;
178     }
179 };
180
181 $evalret = eval { require Toto; 1 };
182 die $@ if $@;
183 ok( $evalret,                      'require Toto; magic via anonymous code ref'  );
184 ok( exists $INC{'Toto.pm'},        '  %INC sees Toto.pm' );
185 ok( ! ref $INC{'Toto.pm'},         q/  val Toto.pm isn't a ref in %INC/ );
186 is( $INC{'Toto.pm'}, 'xyz',        '  val Toto.pm is correct in %INC' );
187
188 pop @INC;
189
190 push @INC, sub {
191     my ($self, $filename) = @_;
192     if ($filename eq 'abc.pl') {
193         return get_temp_fh($filename, qq(return "abc";\n));
194     }
195     else {
196         return undef;
197     }
198 };
199
200 my $ret = "";
201 $ret ||= do 'abc.pl';
202 is( $ret, 'abc', 'do "abc.pl" sees return value' );
203
204 {
205     my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
206     #local @INC; # local fails on tied @INC
207     my @old_INC = @INC; # because local doesn't work on tied arrays
208     @INC = sub { $filename = 'seen'; return undef; };
209     eval { require $filename; };
210     is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
211     @INC = @old_INC;
212 }
213
214 exit if $minitest;
215
216 SKIP: {
217     skip( "No PerlIO available", 3 ) unless $has_perlio;
218     pop @INC;
219
220     push @INC, sub {
221         my ($cr, $filename) = @_;
222         my $module = $filename; $module =~ s,/,::,g; $module =~ s/\.pm$//;
223         open my $fh, '<',
224              \"package $module; sub complain { warn q() }; \$::file = __FILE__;"
225             or die $!;
226         $INC{$filename} = "/custom/path/to/$filename";
227         return $fh;
228     };
229
230     require Publius::Vergilius::Maro;
231     is( $INC{'Publius/Vergilius/Maro.pm'},
232         '/custom/path/to/Publius/Vergilius/Maro.pm', '%INC set correctly');
233     is( our $file, '/custom/path/to/Publius/Vergilius/Maro.pm',
234         '__FILE__ set correctly' );
235     {
236         my $warning;
237         local $SIG{__WARN__} = sub { $warning = shift };
238         Publius::Vergilius::Maro::complain();
239         like( $warning, qr{something's wrong at /custom/path/to/Publius/Vergilius/Maro.pm}, 'warn() reports correct file source' );
240     }
241 }
242 pop @INC;
243
244 if ($can_fork) {
245     require PerlIO::scalar;
246     # This little bundle of joy generates n more recursive use statements,
247     # with each module chaining the next one down to 0. If it works, then we
248     # can safely nest subprocesses
249     my $use_filter_too;
250     push @INC, sub {
251         return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/;
252         my $pid = open my $fh, "-|";
253         if ($pid) {
254             # Parent
255             return $fh unless $use_filter_too;
256             # Try filters and state in addition.
257             return ($fh, sub {s/$_[1]/pass/; return}, "die")
258         }
259         die "Can't fork self: $!" unless defined $pid;
260
261         # Child
262         my $count = $1;
263         # Lets force some fun with odd sized reads.
264         $| = 1;
265         print 'push @main::bbblplast, ';
266         print "$count;\n";
267         if ($count--) {
268             print "use BBBLPLAST$count;\n";
269         }
270         if ($use_filter_too) {
271             print "die('In $_[1]');";
272         } else {
273             print "pass('In $_[1]');";
274         }
275         print '"Truth"';
276         POSIX::_exit(0);
277         die "Can't get here: $!";
278     };
279
280     @::bbblplast = ();
281     require BBBLPLAST5;
282     is ("@::bbblplast", "0 1 2 3 4 5", "All ran");
283
284     foreach (keys %INC) {
285         delete $INC{$_} if /^BBBLPLAST/;
286     }
287
288     @::bbblplast = ();
289     $use_filter_too = 1;
290
291     require BBBLPLAST5;
292
293     is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter");
294 }