This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tests for having multiple pipes open simultaneously.
[perl5.git] / t / op / inccode.t
CommitLineData
69026470 1#!./perl -w
e5d18500
AMS
2
3# Tests for the coderef-in-@INC feature
4
6b75eab3 5my $can_fork = 0;
e5d18500 6BEGIN {
f8973f08 7 chdir 't' if -d 't';
69026470 8 @INC = qw(. ../lib);
e5d18500 9}
6b75eab3
NC
10{
11 use Config;
12 if (PerlIO::Layer->find('perlio') && $Config{d_fork} &&
13 eval 'require POSIX; 1') {
14 $can_fork = 1;
15 }
16}
f8973f08 17
6b75eab3 18use strict;
47de4e93 19use File::Spec;
69026470
JH
20
21require "test.pl";
6b75eab3 22plan(tests => 45 + 14 * $can_fork);
47de4e93 23
22e2837f
RGS
24my @tempfiles = ();
25
47de4e93 26sub get_temp_fh {
22e2837f
RGS
27 my $f = "DummyModule0000";
28 1 while -e ++$f;
29 push @tempfiles, $f;
30 open my $fh, ">$f" or die "Can't create $f: $!";
3a5db825
GA
31 print $fh "package ".substr($_[0],0,-3).";\n1;\n";
32 print $fh $_[1] if @_ > 1;
d1e4d418 33 close $fh or die "Couldn't close: $!";
47de4e93
RGS
34 open $fh, $f or die "Can't open $f: $!";
35 return $fh;
36}
f8973f08 37
22e2837f
RGS
38END { 1 while unlink @tempfiles }
39
e5d18500
AMS
40sub fooinc {
41 my ($self, $filename) = @_;
42 if (substr($filename,0,3) eq 'Foo') {
47de4e93 43 return get_temp_fh($filename);
e5d18500
AMS
44 }
45 else {
f8973f08 46 return undef;
e5d18500
AMS
47 }
48}
49
50push @INC, \&fooinc;
51
d1e4d418
A
52my $evalret = eval { require Bar; 1 };
53ok( !$evalret, 'Trying non-magic package' );
54
55$evalret = eval { require Foo; 1 };
56die $@ if $@;
57ok( $evalret, 'require Foo; magic via code ref' );
58ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' );
59is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' );
60is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' );
61
62$evalret = eval "use Foo1; 1;";
63die $@ if $@;
64ok( $evalret, 'use Foo1' );
65ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' );
66is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' );
67is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' );
68
69$evalret = eval { do 'Foo2.pl'; 1 };
70die $@ if $@;
71ok( $evalret, 'do "Foo2.pl"' );
72ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' );
73is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' );
74is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' );
e5d18500
AMS
75
76pop @INC;
77
f8973f08 78
e5d18500
AMS
79sub fooinc2 {
80 my ($self, $filename) = @_;
81 if (substr($filename, 0, length($self->[1])) eq $self->[1]) {
47de4e93 82 return get_temp_fh($filename);
e5d18500
AMS
83 }
84 else {
f8973f08 85 return undef;
e5d18500
AMS
86 }
87}
88
47de4e93
RGS
89my $arrayref = [ \&fooinc2, 'Bar' ];
90push @INC, $arrayref;
e5d18500 91
d1e4d418
A
92$evalret = eval { require Foo; 1; };
93die $@ if $@;
94ok( $evalret, 'Originally loaded packages preserved' );
95$evalret = eval { require Foo3; 1; };
96ok( !$evalret, 'Original magic INC purged' );
97
98$evalret = eval { require Bar; 1 };
99die $@ if $@;
100ok( $evalret, 'require Bar; magic via array ref' );
101ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' );
102is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' );
103is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' );
104
105ok( eval "use Bar1; 1;", 'use Bar1' );
106ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' );
107is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' );
108is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' );
109
110ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' );
111ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' );
112is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' );
113is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' );
e5d18500
AMS
114
115pop @INC;
116
117sub FooLoader::INC {
118 my ($self, $filename) = @_;
119 if (substr($filename,0,4) eq 'Quux') {
47de4e93 120 return get_temp_fh($filename);
e5d18500
AMS
121 }
122 else {
f8973f08 123 return undef;
e5d18500
AMS
124 }
125}
126
47de4e93
RGS
127my $href = bless( {}, 'FooLoader' );
128push @INC, $href;
e5d18500 129
d1e4d418
A
130$evalret = eval { require Quux; 1 };
131die $@ if $@;
132ok( $evalret, 'require Quux; magic via hash object' );
133ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' );
6ece0f6b 134is( ref $INC{'Quux.pm'}, 'FooLoader',
d1e4d418
A
135 ' val Quux.pm is an object in %INC' );
136is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' );
e5d18500
AMS
137
138pop @INC;
139
47de4e93
RGS
140my $aref = bless( [], 'FooLoader' );
141push @INC, $aref;
e5d18500 142
d1e4d418
A
143$evalret = eval { require Quux1; 1 };
144die $@ if $@;
145ok( $evalret, 'require Quux1; magic via array object' );
146ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' );
6ece0f6b 147is( ref $INC{'Quux1.pm'}, 'FooLoader',
d1e4d418
A
148 ' val Quux1.pm is an object in %INC' );
149is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' );
e5d18500
AMS
150
151pop @INC;
152
47de4e93
RGS
153my $sref = bless( \(my $x = 1), 'FooLoader' );
154push @INC, $sref;
e5d18500 155
d1e4d418
A
156$evalret = eval { require Quux2; 1 };
157die $@ if $@;
158ok( $evalret, 'require Quux2; magic via scalar object' );
159ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' );
6ece0f6b 160is( ref $INC{'Quux2.pm'}, 'FooLoader',
d1e4d418
A
161 ' val Quux2.pm is an object in %INC' );
162is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' );
f8973f08
MS
163
164pop @INC;
9ae8cd5b
RGS
165
166push @INC, sub {
167 my ($self, $filename) = @_;
168 if (substr($filename,0,4) eq 'Toto') {
169 $INC{$filename} = 'xyz';
170 return get_temp_fh($filename);
171 }
172 else {
173 return undef;
174 }
175};
176
d1e4d418
A
177$evalret = eval { require Toto; 1 };
178die $@ if $@;
179ok( $evalret, 'require Toto; magic via anonymous code ref' );
180ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' );
181ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ );
182is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' );
9ae8cd5b
RGS
183
184pop @INC;
d820be44 185
3a5db825
GA
186push @INC, sub {
187 my ($self, $filename) = @_;
188 if ($filename eq 'abc.pl') {
189 return get_temp_fh($filename, qq(return "abc";\n));
190 }
191 else {
192 return undef;
193 }
194};
195
6b75eab3 196my $ret = "";
3a5db825
GA
197$ret ||= do 'abc.pl';
198is( $ret, 'abc', 'do "abc.pl" sees return value' );
199
200pop @INC;
201
d820be44
RGS
202my $filename = $^O eq 'MacOS' ? ':Foo:Foo.pm' : './Foo.pm';
203{
204 local @INC;
205 @INC = sub { $filename = 'seen'; return undef; };
206 eval { require $filename; };
207 is( $filename, 'seen', 'the coderef sees fully-qualified pathnames' );
208}
6b75eab3
NC
209
210if ($can_fork) {
211 require PerlIO::scalar;
212 # This little bundle of joy generates n more recursive use statements,
213 # with each module chaining the next one down to 0. If it works, then we
214 # can safely nest subprocesses
215 my $use_filter_too;
216 push @INC, sub {
217 return unless $_[1] =~ /^BBBLPLAST(\d+)\.pm/;
218 my $pid = open my $fh, "-|";
219 if ($pid) {
220 # Parent
221 return $fh unless $use_filter_too;
222 # Try filters and state in addition.
223 return ($fh, sub {s/$_[1]/pass/; return}, "die")
224 }
225 die "Can't fork self: $!" unless defined $pid;
226
227 # Child
228 my $count = $1;
229 # Lets force some fun with odd sized reads.
230 $| = 1;
231 print 'push @main::bbblplast, ';
232 print "$count;\n";
233 if ($count--) {
234 print "use BBBLPLAST$count;\n";
235 }
236 if ($use_filter_too) {
237 print "die('In $_[1]');";
238 } else {
239 print "pass('In $_[1]');";
240 }
241 print '"Truth"';
242 POSIX::_exit(0);
243 die "Can't get here: $!";
244 };
245
246 @::bbblplast = ();
247 require BBBLPLAST5;
248 is ("@::bbblplast", "0 1 2 3 4 5", "All ran");
249
250 foreach (keys %INC) {
251 delete $INC{$_} if /^BBBLPLAST/;
252 }
253
254 @::bbblplast = ();
255 $use_filter_too = 1;
256
257 require BBBLPLAST5;
258
259 is ("@::bbblplast", "0 1 2 3 4 5", "All ran with a filter");
260}