Commit | Line | Data |
f8973f08 |
1 | #!./perl -wT |
e5d18500 |
2 | |
3 | # Tests for the coderef-in-@INC feature |
4 | |
5 | BEGIN { |
f8973f08 |
6 | chdir 't' if -d 't'; |
7 | @INC = '../lib'; |
e5d18500 |
8 | } |
f8973f08 |
9 | |
47de4e93 |
10 | use File::Spec; |
47de4e93 |
11 | use Test::More tests => 30; |
12 | |
22e2837f |
13 | my @tempfiles = (); |
14 | |
47de4e93 |
15 | sub get_temp_fh { |
22e2837f |
16 | my $f = "DummyModule0000"; |
17 | 1 while -e ++$f; |
18 | push @tempfiles, $f; |
19 | open my $fh, ">$f" or die "Can't create $f: $!"; |
47de4e93 |
20 | print $fh "package ".substr($_[0],0,-3)."; 1;"; |
21 | close $fh; |
22 | open $fh, $f or die "Can't open $f: $!"; |
23 | return $fh; |
24 | } |
f8973f08 |
25 | |
22e2837f |
26 | END { 1 while unlink @tempfiles } |
27 | |
47de4e93 |
28 | sub get_addr { |
29 | my $str = shift; |
30 | $str =~ /(0x[0-9a-f]+)/i; |
31 | return $1; |
f8973f08 |
32 | } |
e5d18500 |
33 | |
34 | sub fooinc { |
35 | my ($self, $filename) = @_; |
36 | if (substr($filename,0,3) eq 'Foo') { |
47de4e93 |
37 | return get_temp_fh($filename); |
e5d18500 |
38 | } |
39 | else { |
f8973f08 |
40 | return undef; |
e5d18500 |
41 | } |
42 | } |
43 | |
44 | push @INC, \&fooinc; |
45 | |
f8973f08 |
46 | ok( !eval { require Bar; 1 }, 'Trying non-magic package' ); |
47 | |
48 | ok( eval { require Foo; 1 }, 'require() magic via code ref' ); |
49 | ok( exists $INC{'Foo.pm'}, ' %INC sees it' ); |
47de4e93 |
50 | is( get_addr($INC{'Foo.pm'}), get_addr(\&fooinc), |
51 | ' key is correct in %INC' ); |
f8973f08 |
52 | |
53 | ok( eval "use Foo1; 1;", 'use()' ); |
54 | ok( exists $INC{'Foo1.pm'}, ' %INC sees it' ); |
47de4e93 |
55 | is( get_addr($INC{'Foo1.pm'}), get_addr(\&fooinc), |
56 | ' key is correct in %INC' ); |
f8973f08 |
57 | |
58 | ok( eval { do 'Foo2.pl'; 1 }, 'do()' ); |
59 | ok( exists $INC{'Foo2.pl'}, ' %INC sees it' ); |
47de4e93 |
60 | is( get_addr($INC{'Foo2.pl'}), get_addr(\&fooinc), |
61 | ' key is correct in %INC' ); |
e5d18500 |
62 | |
63 | pop @INC; |
64 | |
f8973f08 |
65 | |
e5d18500 |
66 | sub fooinc2 { |
67 | my ($self, $filename) = @_; |
68 | if (substr($filename, 0, length($self->[1])) eq $self->[1]) { |
47de4e93 |
69 | return get_temp_fh($filename); |
e5d18500 |
70 | } |
71 | else { |
f8973f08 |
72 | return undef; |
e5d18500 |
73 | } |
74 | } |
75 | |
47de4e93 |
76 | my $arrayref = [ \&fooinc2, 'Bar' ]; |
77 | push @INC, $arrayref; |
e5d18500 |
78 | |
f8973f08 |
79 | ok( eval { require Foo; 1; }, 'Originally loaded packages preserved' ); |
80 | ok( !eval { require Foo3; 1; }, 'Original magic INC purged' ); |
81 | |
82 | ok( eval { require Bar; 1 }, 'require() magic via array ref' ); |
83 | ok( exists $INC{'Bar.pm'}, ' %INC sees it' ); |
47de4e93 |
84 | is( get_addr($INC{'Bar.pm'}), get_addr($arrayref), |
85 | ' key is correct in %INC' ); |
f8973f08 |
86 | |
87 | ok( eval "use Bar1; 1;", 'use()' ); |
88 | ok( exists $INC{'Bar1.pm'}, ' %INC sees it' ); |
47de4e93 |
89 | is( get_addr($INC{'Bar1.pm'}), get_addr($arrayref), |
90 | ' key is correct in %INC' ); |
f8973f08 |
91 | |
92 | ok( eval { do 'Bar2.pl'; 1 }, 'do()' ); |
93 | ok( exists $INC{'Bar2.pl'}, ' %INC sees it' ); |
47de4e93 |
94 | is( get_addr($INC{'Bar2.pl'}), get_addr($arrayref), |
95 | ' key is correct in %INC' ); |
e5d18500 |
96 | |
97 | pop @INC; |
98 | |
99 | sub FooLoader::INC { |
100 | my ($self, $filename) = @_; |
101 | if (substr($filename,0,4) eq 'Quux') { |
47de4e93 |
102 | return get_temp_fh($filename); |
e5d18500 |
103 | } |
104 | else { |
f8973f08 |
105 | return undef; |
e5d18500 |
106 | } |
107 | } |
108 | |
47de4e93 |
109 | my $href = bless( {}, 'FooLoader' ); |
110 | push @INC, $href; |
e5d18500 |
111 | |
f8973f08 |
112 | ok( eval { require Quux; 1 }, 'require() magic via hash object' ); |
113 | ok( exists $INC{'Quux.pm'}, ' %INC sees it' ); |
47de4e93 |
114 | is( get_addr($INC{'Quux.pm'}), get_addr($href), |
115 | ' key is correct in %INC' ); |
e5d18500 |
116 | |
117 | pop @INC; |
118 | |
47de4e93 |
119 | my $aref = bless( [], 'FooLoader' ); |
120 | push @INC, $aref; |
e5d18500 |
121 | |
f8973f08 |
122 | ok( eval { require Quux1; 1 }, 'require() magic via array object' ); |
123 | ok( exists $INC{'Quux1.pm'}, ' %INC sees it' ); |
47de4e93 |
124 | is( get_addr($INC{'Quux1.pm'}), get_addr($aref), |
125 | ' key is correct in %INC' ); |
e5d18500 |
126 | |
127 | pop @INC; |
128 | |
47de4e93 |
129 | my $sref = bless( \(my $x = 1), 'FooLoader' ); |
130 | push @INC, $sref; |
e5d18500 |
131 | |
f8973f08 |
132 | ok( eval { require Quux2; 1 }, 'require() magic via scalar object' ); |
133 | ok( exists $INC{'Quux2.pm'}, ' %INC sees it' ); |
47de4e93 |
134 | is( get_addr($INC{'Quux2.pm'}), get_addr($sref), |
135 | ' key is correct in %INC' ); |
f8973f08 |
136 | |
137 | pop @INC; |