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