Commit | Line | Data |
69026470 |
1 | #!./perl -w |
e5d18500 |
2 | |
3 | # Tests for the coderef-in-@INC feature |
4 | |
6b75eab3 |
5 | my $can_fork = 0; |
e5d18500 |
6 | BEGIN { |
f8973f08 |
7 | chdir 't' if -d 't'; |
69026470 |
8 | @INC = qw(. ../lib); |
e5d18500 |
9 | } |
6b75eab3 |
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 |
18 | use strict; |
47de4e93 |
19 | use File::Spec; |
69026470 |
20 | |
21 | require "test.pl"; |
6b75eab3 |
22 | plan(tests => 45 + 14 * $can_fork); |
47de4e93 |
23 | |
22e2837f |
24 | my @tempfiles = (); |
25 | |
47de4e93 |
26 | sub get_temp_fh { |
22e2837f |
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 |
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 |
34 | open $fh, $f or die "Can't open $f: $!"; |
35 | return $fh; |
36 | } |
f8973f08 |
37 | |
22e2837f |
38 | END { 1 while unlink @tempfiles } |
39 | |
e5d18500 |
40 | sub fooinc { |
41 | my ($self, $filename) = @_; |
42 | if (substr($filename,0,3) eq 'Foo') { |
47de4e93 |
43 | return get_temp_fh($filename); |
e5d18500 |
44 | } |
45 | else { |
f8973f08 |
46 | return undef; |
e5d18500 |
47 | } |
48 | } |
49 | |
50 | push @INC, \&fooinc; |
51 | |
d1e4d418 |
52 | my $evalret = eval { require Bar; 1 }; |
53 | ok( !$evalret, 'Trying non-magic package' ); |
54 | |
55 | $evalret = eval { require Foo; 1 }; |
56 | die $@ if $@; |
57 | ok( $evalret, 'require Foo; magic via code ref' ); |
58 | ok( exists $INC{'Foo.pm'}, ' %INC sees Foo.pm' ); |
59 | is( ref $INC{'Foo.pm'}, 'CODE', ' val Foo.pm is a coderef in %INC' ); |
60 | is( $INC{'Foo.pm'}, \&fooinc, ' val Foo.pm is correct in %INC' ); |
61 | |
62 | $evalret = eval "use Foo1; 1;"; |
63 | die $@ if $@; |
64 | ok( $evalret, 'use Foo1' ); |
65 | ok( exists $INC{'Foo1.pm'}, ' %INC sees Foo1.pm' ); |
66 | is( ref $INC{'Foo1.pm'}, 'CODE', ' val Foo1.pm is a coderef in %INC' ); |
67 | is( $INC{'Foo1.pm'}, \&fooinc, ' val Foo1.pm is correct in %INC' ); |
68 | |
69 | $evalret = eval { do 'Foo2.pl'; 1 }; |
70 | die $@ if $@; |
71 | ok( $evalret, 'do "Foo2.pl"' ); |
72 | ok( exists $INC{'Foo2.pl'}, ' %INC sees Foo2.pl' ); |
73 | is( ref $INC{'Foo2.pl'}, 'CODE', ' val Foo2.pl is a coderef in %INC' ); |
74 | is( $INC{'Foo2.pl'}, \&fooinc, ' val Foo2.pl is correct in %INC' ); |
e5d18500 |
75 | |
76 | pop @INC; |
77 | |
f8973f08 |
78 | |
e5d18500 |
79 | sub fooinc2 { |
80 | my ($self, $filename) = @_; |
81 | if (substr($filename, 0, length($self->[1])) eq $self->[1]) { |
47de4e93 |
82 | return get_temp_fh($filename); |
e5d18500 |
83 | } |
84 | else { |
f8973f08 |
85 | return undef; |
e5d18500 |
86 | } |
87 | } |
88 | |
47de4e93 |
89 | my $arrayref = [ \&fooinc2, 'Bar' ]; |
90 | push @INC, $arrayref; |
e5d18500 |
91 | |
d1e4d418 |
92 | $evalret = eval { require Foo; 1; }; |
93 | die $@ if $@; |
94 | ok( $evalret, 'Originally loaded packages preserved' ); |
95 | $evalret = eval { require Foo3; 1; }; |
96 | ok( !$evalret, 'Original magic INC purged' ); |
97 | |
98 | $evalret = eval { require Bar; 1 }; |
99 | die $@ if $@; |
100 | ok( $evalret, 'require Bar; magic via array ref' ); |
101 | ok( exists $INC{'Bar.pm'}, ' %INC sees Bar.pm' ); |
102 | is( ref $INC{'Bar.pm'}, 'ARRAY', ' val Bar.pm is an arrayref in %INC' ); |
103 | is( $INC{'Bar.pm'}, $arrayref, ' val Bar.pm is correct in %INC' ); |
104 | |
105 | ok( eval "use Bar1; 1;", 'use Bar1' ); |
106 | ok( exists $INC{'Bar1.pm'}, ' %INC sees Bar1.pm' ); |
107 | is( ref $INC{'Bar1.pm'}, 'ARRAY', ' val Bar1.pm is an arrayref in %INC' ); |
108 | is( $INC{'Bar1.pm'}, $arrayref, ' val Bar1.pm is correct in %INC' ); |
109 | |
110 | ok( eval { do 'Bar2.pl'; 1 }, 'do "Bar2.pl"' ); |
111 | ok( exists $INC{'Bar2.pl'}, ' %INC sees Bar2.pl' ); |
112 | is( ref $INC{'Bar2.pl'}, 'ARRAY', ' val Bar2.pl is an arrayref in %INC' ); |
113 | is( $INC{'Bar2.pl'}, $arrayref, ' val Bar2.pl is correct in %INC' ); |
e5d18500 |
114 | |
115 | pop @INC; |
116 | |
117 | sub FooLoader::INC { |
118 | my ($self, $filename) = @_; |
119 | if (substr($filename,0,4) eq 'Quux') { |
47de4e93 |
120 | return get_temp_fh($filename); |
e5d18500 |
121 | } |
122 | else { |
f8973f08 |
123 | return undef; |
e5d18500 |
124 | } |
125 | } |
126 | |
47de4e93 |
127 | my $href = bless( {}, 'FooLoader' ); |
128 | push @INC, $href; |
e5d18500 |
129 | |
d1e4d418 |
130 | $evalret = eval { require Quux; 1 }; |
131 | die $@ if $@; |
132 | ok( $evalret, 'require Quux; magic via hash object' ); |
133 | ok( exists $INC{'Quux.pm'}, ' %INC sees Quux.pm' ); |
6ece0f6b |
134 | is( ref $INC{'Quux.pm'}, 'FooLoader', |
d1e4d418 |
135 | ' val Quux.pm is an object in %INC' ); |
136 | is( $INC{'Quux.pm'}, $href, ' val Quux.pm is correct in %INC' ); |
e5d18500 |
137 | |
138 | pop @INC; |
139 | |
47de4e93 |
140 | my $aref = bless( [], 'FooLoader' ); |
141 | push @INC, $aref; |
e5d18500 |
142 | |
d1e4d418 |
143 | $evalret = eval { require Quux1; 1 }; |
144 | die $@ if $@; |
145 | ok( $evalret, 'require Quux1; magic via array object' ); |
146 | ok( exists $INC{'Quux1.pm'}, ' %INC sees Quux1.pm' ); |
6ece0f6b |
147 | is( ref $INC{'Quux1.pm'}, 'FooLoader', |
d1e4d418 |
148 | ' val Quux1.pm is an object in %INC' ); |
149 | is( $INC{'Quux1.pm'}, $aref, ' val Quux1.pm is correct in %INC' ); |
e5d18500 |
150 | |
151 | pop @INC; |
152 | |
47de4e93 |
153 | my $sref = bless( \(my $x = 1), 'FooLoader' ); |
154 | push @INC, $sref; |
e5d18500 |
155 | |
d1e4d418 |
156 | $evalret = eval { require Quux2; 1 }; |
157 | die $@ if $@; |
158 | ok( $evalret, 'require Quux2; magic via scalar object' ); |
159 | ok( exists $INC{'Quux2.pm'}, ' %INC sees Quux2.pm' ); |
6ece0f6b |
160 | is( ref $INC{'Quux2.pm'}, 'FooLoader', |
d1e4d418 |
161 | ' val Quux2.pm is an object in %INC' ); |
162 | is( $INC{'Quux2.pm'}, $sref, ' val Quux2.pm is correct in %INC' ); |
f8973f08 |
163 | |
164 | pop @INC; |
9ae8cd5b |
165 | |
166 | push @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 |
177 | $evalret = eval { require Toto; 1 }; |
178 | die $@ if $@; |
179 | ok( $evalret, 'require Toto; magic via anonymous code ref' ); |
180 | ok( exists $INC{'Toto.pm'}, ' %INC sees Toto.pm' ); |
181 | ok( ! ref $INC{'Toto.pm'}, q/ val Toto.pm isn't a ref in %INC/ ); |
182 | is( $INC{'Toto.pm'}, 'xyz', ' val Toto.pm is correct in %INC' ); |
9ae8cd5b |
183 | |
184 | pop @INC; |
d820be44 |
185 | |
3a5db825 |
186 | push @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 |
196 | my $ret = ""; |
3a5db825 |
197 | $ret ||= do 'abc.pl'; |
198 | is( $ret, 'abc', 'do "abc.pl" sees return value' ); |
199 | |
200 | pop @INC; |
201 | |
d820be44 |
202 | my $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 |
209 | |
210 | if ($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 | } |