1 |
dpavlin |
1 |
#line 1 |
2 |
|
|
package Module::Install; |
3 |
|
|
|
4 |
|
|
# For any maintainers: |
5 |
|
|
# The load order for Module::Install is a bit magic. |
6 |
|
|
# It goes something like this... |
7 |
|
|
# |
8 |
|
|
# IF ( host has Module::Install installed, creating author mode ) { |
9 |
|
|
# 1. Makefile.PL calls "use inc::Module::Install" |
10 |
|
|
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install |
11 |
|
|
# 3. The installed version of inc::Module::Install loads |
12 |
|
|
# 4. inc::Module::Install calls "require Module::Install" |
13 |
|
|
# 5. The ./inc/ version of Module::Install loads |
14 |
|
|
# } ELSE { |
15 |
|
|
# 1. Makefile.PL calls "use inc::Module::Install" |
16 |
|
|
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install |
17 |
|
|
# 3. The ./inc/ version of Module::Install loads |
18 |
|
|
# } |
19 |
|
|
|
20 |
|
|
use 5.004; |
21 |
|
|
use strict 'vars'; |
22 |
|
|
|
23 |
|
|
use vars qw{$VERSION}; |
24 |
|
|
BEGIN { |
25 |
|
|
# All Module::Install core packages now require synchronised versions. |
26 |
|
|
# This will be used to ensure we don't accidentally load old or |
27 |
|
|
# different versions of modules. |
28 |
|
|
# This is not enforced yet, but will be some time in the next few |
29 |
|
|
# releases once we can make sure it won't clash with custom |
30 |
|
|
# Module::Install extensions. |
31 |
|
|
$VERSION = '0.61'; |
32 |
|
|
} |
33 |
|
|
|
34 |
|
|
# Whether or not inc::Module::Install is actually loaded, the |
35 |
|
|
# $INC{inc/Module/Install.pm} is what will still get set as long as |
36 |
|
|
# the caller loaded module this in the documented manner. |
37 |
|
|
# If not set, the caller may NOT have loaded the bundled version, and thus |
38 |
|
|
# they may not have a MI version that works with the Makefile.PL. This would |
39 |
|
|
# result in false errors or unexpected behaviour. And we don't want that. |
40 |
|
|
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; |
41 |
|
|
unless ( $INC{$file} ) { |
42 |
|
|
die <<"END_DIE"; |
43 |
|
|
Please invoke ${\__PACKAGE__} with: |
44 |
|
|
|
45 |
|
|
use inc::${\__PACKAGE__}; |
46 |
|
|
|
47 |
|
|
not: |
48 |
|
|
|
49 |
|
|
use ${\__PACKAGE__}; |
50 |
|
|
|
51 |
|
|
END_DIE |
52 |
|
|
} |
53 |
|
|
|
54 |
|
|
use Cwd (); |
55 |
|
|
use File::Find (); |
56 |
|
|
use File::Path (); |
57 |
|
|
use FindBin; |
58 |
|
|
|
59 |
|
|
*inc::Module::Install::VERSION = *VERSION; |
60 |
|
|
@inc::Module::Install::ISA = __PACKAGE__; |
61 |
|
|
|
62 |
|
|
sub autoload { |
63 |
|
|
my $self = shift; |
64 |
|
|
my $who = $self->_caller; |
65 |
|
|
my $cwd = Cwd::cwd(); |
66 |
|
|
my $sym = "${who}::AUTOLOAD"; |
67 |
|
|
$sym->{$cwd} = sub { |
68 |
|
|
my $pwd = Cwd::cwd(); |
69 |
|
|
if ( my $code = $sym->{$pwd} ) { |
70 |
|
|
# delegate back to parent dirs |
71 |
|
|
goto &$code unless $cwd eq $pwd; |
72 |
|
|
} |
73 |
|
|
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; |
74 |
|
|
unshift @_, ($self, $1); |
75 |
|
|
goto &{$self->can('call')} unless uc($1) eq $1; |
76 |
|
|
}; |
77 |
|
|
} |
78 |
|
|
|
79 |
|
|
sub import { |
80 |
|
|
my $class = shift; |
81 |
|
|
my $self = $class->new(@_); |
82 |
|
|
my $who = $self->_caller; |
83 |
|
|
|
84 |
|
|
unless ( -f $self->{file} ) { |
85 |
|
|
require "$self->{path}/$self->{dispatch}.pm"; |
86 |
|
|
File::Path::mkpath("$self->{prefix}/$self->{author}"); |
87 |
|
|
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); |
88 |
|
|
$self->{admin}->init; |
89 |
|
|
@_ = ($class, _self => $self); |
90 |
|
|
goto &{"$self->{name}::import"}; |
91 |
|
|
} |
92 |
|
|
|
93 |
|
|
*{"${who}::AUTOLOAD"} = $self->autoload; |
94 |
|
|
$self->preload; |
95 |
|
|
|
96 |
|
|
# Unregister loader and worker packages so subdirs can use them again |
97 |
|
|
delete $INC{"$self->{file}"}; |
98 |
|
|
delete $INC{"$self->{path}.pm"}; |
99 |
|
|
} |
100 |
|
|
|
101 |
|
|
sub preload { |
102 |
|
|
my ($self) = @_; |
103 |
|
|
|
104 |
|
|
unless ( $self->{extensions} ) { |
105 |
|
|
$self->load_extensions( |
106 |
|
|
"$self->{prefix}/$self->{path}", $self |
107 |
|
|
); |
108 |
|
|
} |
109 |
|
|
|
110 |
|
|
my @exts = @{$self->{extensions}}; |
111 |
|
|
unless ( @exts ) { |
112 |
|
|
my $admin = $self->{admin}; |
113 |
|
|
@exts = $admin->load_all_extensions; |
114 |
|
|
} |
115 |
|
|
|
116 |
|
|
my %seen; |
117 |
|
|
foreach my $obj ( @exts ) { |
118 |
|
|
while (my ($method, $glob) = each %{ref($obj) . '::'}) { |
119 |
|
|
next unless exists &{ref($obj).'::'.$method}; |
120 |
|
|
next if $method =~ /^_/; |
121 |
|
|
next if $method eq uc($method); |
122 |
|
|
$seen{$method}++; |
123 |
|
|
} |
124 |
|
|
} |
125 |
|
|
|
126 |
|
|
my $who = $self->_caller; |
127 |
|
|
foreach my $name ( sort keys %seen ) { |
128 |
|
|
*{"${who}::$name"} = sub { |
129 |
|
|
${"${who}::AUTOLOAD"} = "${who}::$name"; |
130 |
|
|
goto &{"${who}::AUTOLOAD"}; |
131 |
|
|
}; |
132 |
|
|
} |
133 |
|
|
} |
134 |
|
|
|
135 |
|
|
sub new { |
136 |
|
|
my ($class, %args) = @_; |
137 |
|
|
|
138 |
|
|
# ignore the prefix on extension modules built from top level. |
139 |
|
|
my $base_path = Cwd::abs_path($FindBin::Bin); |
140 |
|
|
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { |
141 |
|
|
delete $args{prefix}; |
142 |
|
|
} |
143 |
|
|
|
144 |
|
|
return $args{_self} if $args{_self}; |
145 |
|
|
|
146 |
|
|
$args{dispatch} ||= 'Admin'; |
147 |
|
|
$args{prefix} ||= 'inc'; |
148 |
|
|
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); |
149 |
|
|
$args{bundle} ||= 'inc/BUNDLES'; |
150 |
|
|
$args{base} ||= $base_path; |
151 |
|
|
$class =~ s/^\Q$args{prefix}\E:://; |
152 |
|
|
$args{name} ||= $class; |
153 |
|
|
$args{version} ||= $class->VERSION; |
154 |
|
|
unless ( $args{path} ) { |
155 |
|
|
$args{path} = $args{name}; |
156 |
|
|
$args{path} =~ s!::!/!g; |
157 |
|
|
} |
158 |
|
|
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; |
159 |
|
|
|
160 |
|
|
bless( \%args, $class ); |
161 |
|
|
} |
162 |
|
|
|
163 |
|
|
sub call { |
164 |
|
|
my ($self, $method) = @_; |
165 |
|
|
my $obj = $self->load($method) or return; |
166 |
|
|
splice(@_, 0, 2, $obj); |
167 |
|
|
goto &{$obj->can($method)}; |
168 |
|
|
} |
169 |
|
|
|
170 |
|
|
sub load { |
171 |
|
|
my ($self, $method) = @_; |
172 |
|
|
|
173 |
|
|
$self->load_extensions( |
174 |
|
|
"$self->{prefix}/$self->{path}", $self |
175 |
|
|
) unless $self->{extensions}; |
176 |
|
|
|
177 |
|
|
foreach my $obj (@{$self->{extensions}}) { |
178 |
|
|
return $obj if $obj->can($method); |
179 |
|
|
} |
180 |
|
|
|
181 |
|
|
my $admin = $self->{admin} or die <<"END_DIE"; |
182 |
|
|
The '$method' method does not exist in the '$self->{prefix}' path! |
183 |
|
|
Please remove the '$self->{prefix}' directory and run $0 again to load it. |
184 |
|
|
END_DIE |
185 |
|
|
|
186 |
|
|
my $obj = $admin->load($method, 1); |
187 |
|
|
push @{$self->{extensions}}, $obj; |
188 |
|
|
|
189 |
|
|
$obj; |
190 |
|
|
} |
191 |
|
|
|
192 |
|
|
sub load_extensions { |
193 |
|
|
my ($self, $path, $top) = @_; |
194 |
|
|
|
195 |
|
|
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { |
196 |
|
|
unshift @INC, $self->{prefix}; |
197 |
|
|
} |
198 |
|
|
|
199 |
|
|
foreach my $rv ( $self->find_extensions($path) ) { |
200 |
|
|
my ($file, $pkg) = @{$rv}; |
201 |
|
|
next if $self->{pathnames}{$pkg}; |
202 |
|
|
|
203 |
|
|
local $@; |
204 |
|
|
my $new = eval { require $file; $pkg->can('new') }; |
205 |
|
|
unless ( $new ) { |
206 |
|
|
warn $@ if $@; |
207 |
|
|
next; |
208 |
|
|
} |
209 |
|
|
$self->{pathnames}{$pkg} = delete $INC{$file}; |
210 |
|
|
push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); |
211 |
|
|
} |
212 |
|
|
|
213 |
|
|
$self->{extensions} ||= []; |
214 |
|
|
} |
215 |
|
|
|
216 |
|
|
sub find_extensions { |
217 |
|
|
my ($self, $path) = @_; |
218 |
|
|
|
219 |
|
|
my @found; |
220 |
|
|
File::Find::find( sub { |
221 |
|
|
my $file = $File::Find::name; |
222 |
|
|
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; |
223 |
|
|
my $subpath = $1; |
224 |
|
|
return if lc($subpath) eq lc($self->{dispatch}); |
225 |
|
|
|
226 |
|
|
$file = "$self->{path}/$subpath.pm"; |
227 |
|
|
my $pkg = "$self->{name}::$subpath"; |
228 |
|
|
$pkg =~ s!/!::!g; |
229 |
|
|
|
230 |
|
|
# If we have a mixed-case package name, assume case has been preserved |
231 |
|
|
# correctly. Otherwise, root through the file to locate the case-preserved |
232 |
|
|
# version of the package name. |
233 |
|
|
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { |
234 |
|
|
open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; |
235 |
|
|
my $in_pod = 0; |
236 |
|
|
while ( <PKGFILE> ) { |
237 |
|
|
$in_pod = 1 if /^=\w/; |
238 |
|
|
$in_pod = 0 if /^=cut/; |
239 |
|
|
next if ($in_pod || /^=cut/); # skip pod text |
240 |
|
|
next if /^\s*#/; # and comments |
241 |
|
|
if ( m/^\s*package\s+($pkg)\s*;/i ) { |
242 |
|
|
$pkg = $1; |
243 |
|
|
last; |
244 |
|
|
} |
245 |
|
|
} |
246 |
|
|
close PKGFILE; |
247 |
|
|
} |
248 |
|
|
|
249 |
|
|
push @found, [ $file, $pkg ]; |
250 |
|
|
}, $path ) if -d $path; |
251 |
|
|
|
252 |
|
|
@found; |
253 |
|
|
} |
254 |
|
|
|
255 |
|
|
sub _caller { |
256 |
|
|
my $depth = 0; |
257 |
|
|
my $call = caller($depth); |
258 |
|
|
while ( $call eq __PACKAGE__ ) { |
259 |
|
|
$depth++; |
260 |
|
|
$call = caller($depth); |
261 |
|
|
} |
262 |
|
|
return $call; |
263 |
|
|
} |
264 |
|
|
|
265 |
|
|
1; |