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