Commit | Line | Data |
0430b7f7 |
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 | |
6ea94d90 |
20 | BEGIN { |
21 | require 5.004; |
22 | } |
0430b7f7 |
23 | use strict 'vars'; |
24 | |
25 | use vars qw{$VERSION}; |
26 | BEGIN { |
6ea94d90 |
27 | # All Module::Install core packages now require synchronised versions. |
28 | # This will be used to ensure we don't accidentally load old or |
29 | # different versions of modules. |
30 | # This is not enforced yet, but will be some time in the next few |
31 | # releases once we can make sure it won't clash with custom |
32 | # Module::Install extensions. |
f44772ad |
33 | $VERSION = '0.77'; |
34 | |
35 | *inc::Module::Install::VERSION = *VERSION; |
36 | @inc::Module::Install::ISA = __PACKAGE__; |
37 | |
0430b7f7 |
38 | } |
39 | |
6ea94d90 |
40 | |
41 | |
42 | |
43 | |
0430b7f7 |
44 | # Whether or not inc::Module::Install is actually loaded, the |
45 | # $INC{inc/Module/Install.pm} is what will still get set as long as |
46 | # the caller loaded module this in the documented manner. |
47 | # If not set, the caller may NOT have loaded the bundled version, and thus |
48 | # they may not have a MI version that works with the Makefile.PL. This would |
49 | # result in false errors or unexpected behaviour. And we don't want that. |
50 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; |
6ea94d90 |
51 | unless ( $INC{$file} ) { die <<"END_DIE" } |
52 | |
0430b7f7 |
53 | Please invoke ${\__PACKAGE__} with: |
54 | |
6ea94d90 |
55 | use inc::${\__PACKAGE__}; |
0430b7f7 |
56 | |
57 | not: |
58 | |
6ea94d90 |
59 | use ${\__PACKAGE__}; |
0430b7f7 |
60 | |
61 | END_DIE |
6ea94d90 |
62 | |
63 | |
64 | |
65 | |
0430b7f7 |
66 | |
67 | # If the script that is loading Module::Install is from the future, |
68 | # then make will detect this and cause it to re-run over and over |
69 | # again. This is bad. Rather than taking action to touch it (which |
70 | # is unreliable on some platforms and requires write permissions) |
71 | # for now we should catch this and refuse to run. |
6ea94d90 |
72 | if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } |
73 | |
0430b7f7 |
74 | Your installer $0 has a modification time in the future. |
75 | |
76 | This is known to create infinite loops in make. |
77 | |
78 | Please correct this, then run $0 again. |
79 | |
80 | END_DIE |
6ea94d90 |
81 | |
82 | |
83 | |
84 | |
85 | |
86 | # Build.PL was formerly supported, but no longer is due to excessive |
87 | # difficulty in implementing every single feature twice. |
f44772ad |
88 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } |
6ea94d90 |
89 | |
90 | Module::Install no longer supports Build.PL. |
91 | |
92 | It was impossible to maintain duel backends, and has been deprecated. |
93 | |
94 | Please remove all Build.PL files and only use the Makefile.PL installer. |
95 | |
96 | END_DIE |
97 | |
98 | |
99 | |
100 | |
0430b7f7 |
101 | |
f44772ad |
102 | # To save some more typing in Module::Install installers, every... |
103 | # use inc::Module::Install |
104 | # ...also acts as an implicit use strict. |
105 | $^H |= strict::bits(qw(refs subs vars)); |
106 | |
107 | |
108 | |
109 | |
110 | |
0430b7f7 |
111 | use Cwd (); |
112 | use File::Find (); |
113 | use File::Path (); |
114 | use FindBin; |
115 | |
0430b7f7 |
116 | sub autoload { |
6ea94d90 |
117 | my $self = shift; |
118 | my $who = $self->_caller; |
119 | my $cwd = Cwd::cwd(); |
120 | my $sym = "${who}::AUTOLOAD"; |
121 | $sym->{$cwd} = sub { |
122 | my $pwd = Cwd::cwd(); |
123 | if ( my $code = $sym->{$pwd} ) { |
124 | # delegate back to parent dirs |
125 | goto &$code unless $cwd eq $pwd; |
126 | } |
127 | $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; |
f44772ad |
128 | unless ( uc($1) eq $1 ) { |
129 | unshift @_, ( $self, $1 ); |
130 | goto &{$self->can('call')}; |
131 | } |
6ea94d90 |
132 | }; |
0430b7f7 |
133 | } |
134 | |
135 | sub import { |
6ea94d90 |
136 | my $class = shift; |
137 | my $self = $class->new(@_); |
138 | my $who = $self->_caller; |
139 | |
140 | unless ( -f $self->{file} ) { |
141 | require "$self->{path}/$self->{dispatch}.pm"; |
142 | File::Path::mkpath("$self->{prefix}/$self->{author}"); |
143 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); |
144 | $self->{admin}->init; |
145 | @_ = ($class, _self => $self); |
146 | goto &{"$self->{name}::import"}; |
147 | } |
148 | |
149 | *{"${who}::AUTOLOAD"} = $self->autoload; |
150 | $self->preload; |
151 | |
152 | # Unregister loader and worker packages so subdirs can use them again |
153 | delete $INC{"$self->{file}"}; |
154 | delete $INC{"$self->{path}.pm"}; |
155 | |
156 | return 1; |
0430b7f7 |
157 | } |
158 | |
159 | sub preload { |
6ea94d90 |
160 | my $self = shift; |
161 | unless ( $self->{extensions} ) { |
162 | $self->load_extensions( |
163 | "$self->{prefix}/$self->{path}", $self |
164 | ); |
165 | } |
166 | |
167 | my @exts = @{$self->{extensions}}; |
168 | unless ( @exts ) { |
169 | my $admin = $self->{admin}; |
170 | @exts = $admin->load_all_extensions; |
171 | } |
172 | |
173 | my %seen; |
174 | foreach my $obj ( @exts ) { |
175 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { |
176 | next unless $obj->can($method); |
177 | next if $method =~ /^_/; |
178 | next if $method eq uc($method); |
179 | $seen{$method}++; |
180 | } |
181 | } |
182 | |
183 | my $who = $self->_caller; |
184 | foreach my $name ( sort keys %seen ) { |
185 | *{"${who}::$name"} = sub { |
186 | ${"${who}::AUTOLOAD"} = "${who}::$name"; |
187 | goto &{"${who}::AUTOLOAD"}; |
188 | }; |
189 | } |
0430b7f7 |
190 | } |
191 | |
192 | sub new { |
6ea94d90 |
193 | my ($class, %args) = @_; |
194 | |
195 | # ignore the prefix on extension modules built from top level. |
196 | my $base_path = Cwd::abs_path($FindBin::Bin); |
197 | unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { |
198 | delete $args{prefix}; |
199 | } |
200 | |
201 | return $args{_self} if $args{_self}; |
202 | |
203 | $args{dispatch} ||= 'Admin'; |
204 | $args{prefix} ||= 'inc'; |
205 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); |
206 | $args{bundle} ||= 'inc/BUNDLES'; |
207 | $args{base} ||= $base_path; |
208 | $class =~ s/^\Q$args{prefix}\E:://; |
209 | $args{name} ||= $class; |
210 | $args{version} ||= $class->VERSION; |
211 | unless ( $args{path} ) { |
212 | $args{path} = $args{name}; |
213 | $args{path} =~ s!::!/!g; |
214 | } |
215 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; |
216 | $args{wrote} = 0; |
217 | |
218 | bless( \%args, $class ); |
0430b7f7 |
219 | } |
220 | |
221 | sub call { |
222 | my ($self, $method) = @_; |
223 | my $obj = $self->load($method) or return; |
224 | splice(@_, 0, 2, $obj); |
225 | goto &{$obj->can($method)}; |
226 | } |
227 | |
228 | sub load { |
6ea94d90 |
229 | my ($self, $method) = @_; |
0430b7f7 |
230 | |
6ea94d90 |
231 | $self->load_extensions( |
232 | "$self->{prefix}/$self->{path}", $self |
233 | ) unless $self->{extensions}; |
0430b7f7 |
234 | |
6ea94d90 |
235 | foreach my $obj (@{$self->{extensions}}) { |
236 | return $obj if $obj->can($method); |
237 | } |
0430b7f7 |
238 | |
6ea94d90 |
239 | my $admin = $self->{admin} or die <<"END_DIE"; |
0430b7f7 |
240 | The '$method' method does not exist in the '$self->{prefix}' path! |
241 | Please remove the '$self->{prefix}' directory and run $0 again to load it. |
242 | END_DIE |
243 | |
6ea94d90 |
244 | my $obj = $admin->load($method, 1); |
245 | push @{$self->{extensions}}, $obj; |
0430b7f7 |
246 | |
6ea94d90 |
247 | $obj; |
0430b7f7 |
248 | } |
249 | |
250 | sub load_extensions { |
6ea94d90 |
251 | my ($self, $path, $top) = @_; |
252 | |
253 | unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { |
254 | unshift @INC, $self->{prefix}; |
255 | } |
256 | |
257 | foreach my $rv ( $self->find_extensions($path) ) { |
258 | my ($file, $pkg) = @{$rv}; |
259 | next if $self->{pathnames}{$pkg}; |
260 | |
261 | local $@; |
262 | my $new = eval { require $file; $pkg->can('new') }; |
263 | unless ( $new ) { |
264 | warn $@ if $@; |
265 | next; |
266 | } |
267 | $self->{pathnames}{$pkg} = delete $INC{$file}; |
268 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); |
269 | } |
270 | |
271 | $self->{extensions} ||= []; |
0430b7f7 |
272 | } |
273 | |
274 | sub find_extensions { |
6ea94d90 |
275 | my ($self, $path) = @_; |
276 | |
277 | my @found; |
278 | File::Find::find( sub { |
279 | my $file = $File::Find::name; |
280 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; |
281 | my $subpath = $1; |
282 | return if lc($subpath) eq lc($self->{dispatch}); |
283 | |
284 | $file = "$self->{path}/$subpath.pm"; |
285 | my $pkg = "$self->{name}::$subpath"; |
286 | $pkg =~ s!/!::!g; |
287 | |
288 | # If we have a mixed-case package name, assume case has been preserved |
289 | # correctly. Otherwise, root through the file to locate the case-preserved |
290 | # version of the package name. |
291 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { |
292 | my $content = Module::Install::_read($subpath . '.pm'); |
293 | my $in_pod = 0; |
294 | foreach ( split //, $content ) { |
295 | $in_pod = 1 if /^=\w/; |
296 | $in_pod = 0 if /^=cut/; |
297 | next if ($in_pod || /^=cut/); # skip pod text |
298 | next if /^\s*#/; # and comments |
299 | if ( m/^\s*package\s+($pkg)\s*;/i ) { |
300 | $pkg = $1; |
301 | last; |
302 | } |
303 | } |
304 | } |
305 | |
306 | push @found, [ $file, $pkg ]; |
307 | }, $path ) if -d $path; |
308 | |
309 | @found; |
0430b7f7 |
310 | } |
311 | |
6ea94d90 |
312 | |
313 | |
314 | |
315 | |
316 | ##################################################################### |
317 | # Utility Functions |
318 | |
0430b7f7 |
319 | sub _caller { |
6ea94d90 |
320 | my $depth = 0; |
321 | my $call = caller($depth); |
322 | while ( $call eq __PACKAGE__ ) { |
323 | $depth++; |
324 | $call = caller($depth); |
325 | } |
326 | return $call; |
327 | } |
328 | |
329 | sub _read { |
330 | local *FH; |
331 | open FH, "< $_[0]" or die "open($_[0]): $!"; |
332 | my $str = do { local $/; <FH> }; |
333 | close FH or die "close($_[0]): $!"; |
334 | return $str; |
335 | } |
336 | |
337 | sub _write { |
338 | local *FH; |
339 | open FH, "> $_[0]" or die "open($_[0]): $!"; |
340 | foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" } |
341 | close FH or die "close($_[0]): $!"; |
342 | } |
343 | |
f44772ad |
344 | # _version is for processing module versions (eg, 1.03_05) not |
345 | # Perl versions (eg, 5.8.1). |
346 | |
347 | sub _version ($) { |
6ea94d90 |
348 | my $s = shift || 0; |
349 | $s =~ s/^(\d+)\.?//; |
350 | my $l = $1 || 0; |
351 | my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; |
352 | $l = $l . '.' . join '', @v if @v; |
353 | return $l + 0; |
0430b7f7 |
354 | } |
355 | |
f44772ad |
356 | # Cloned from Params::Util::_CLASS |
357 | sub _CLASS ($) { |
358 | ( |
359 | defined $_[0] |
360 | and |
361 | ! ref $_[0] |
362 | and |
363 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s |
364 | ) ? $_[0] : undef; |
365 | } |
366 | |
0430b7f7 |
367 | 1; |
6ea94d90 |
368 | |
369 | # Copyright 2008 Adam Kennedy. |