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