Commit | Line | Data |
dbcf12a6 |
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.005; |
21 | use strict 'vars'; |
22 | use Cwd (); |
23 | use File::Find (); |
24 | use File::Path (); |
25 | |
26 | use vars qw{$VERSION $MAIN}; |
27 | BEGIN { |
28 | # All Module::Install core packages now require synchronised versions. |
29 | # This will be used to ensure we don't accidentally load old or |
30 | # different versions of modules. |
31 | # This is not enforced yet, but will be some time in the next few |
32 | # releases once we can make sure it won't clash with custom |
33 | # Module::Install extensions. |
34 | $VERSION = '1.00'; |
35 | |
36 | # Storage for the pseudo-singleton |
37 | $MAIN = undef; |
38 | |
39 | *inc::Module::Install::VERSION = *VERSION; |
40 | @inc::Module::Install::ISA = __PACKAGE__; |
41 | |
42 | } |
43 | |
44 | sub import { |
45 | my $class = shift; |
46 | my $self = $class->new(@_); |
47 | my $who = $self->_caller; |
48 | |
49 | #------------------------------------------------------------- |
50 | # all of the following checks should be included in import(), |
51 | # to allow "eval 'require Module::Install; 1' to test |
52 | # installation of Module::Install. (RT #51267) |
53 | #------------------------------------------------------------- |
54 | |
55 | # Whether or not inc::Module::Install is actually loaded, the |
56 | # $INC{inc/Module/Install.pm} is what will still get set as long as |
57 | # the caller loaded module this in the documented manner. |
58 | # If not set, the caller may NOT have loaded the bundled version, and thus |
59 | # they may not have a MI version that works with the Makefile.PL. This would |
60 | # result in false errors or unexpected behaviour. And we don't want that. |
61 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; |
62 | unless ( $INC{$file} ) { die <<"END_DIE" } |
63 | |
64 | Please invoke ${\__PACKAGE__} with: |
65 | |
66 | use inc::${\__PACKAGE__}; |
67 | |
68 | not: |
69 | |
70 | use ${\__PACKAGE__}; |
71 | |
72 | END_DIE |
73 | |
74 | # This reportedly fixes a rare Win32 UTC file time issue, but |
75 | # as this is a non-cross-platform XS module not in the core, |
76 | # we shouldn't really depend on it. See RT #24194 for detail. |
77 | # (Also, this module only supports Perl 5.6 and above). |
78 | eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; |
79 | |
80 | # If the script that is loading Module::Install is from the future, |
81 | # then make will detect this and cause it to re-run over and over |
82 | # again. This is bad. Rather than taking action to touch it (which |
83 | # is unreliable on some platforms and requires write permissions) |
84 | # for now we should catch this and refuse to run. |
85 | if ( -f $0 ) { |
86 | my $s = (stat($0))[9]; |
87 | |
88 | # If the modification time is only slightly in the future, |
89 | # sleep briefly to remove the problem. |
90 | my $a = $s - time; |
91 | if ( $a > 0 and $a < 5 ) { sleep 5 } |
92 | |
93 | # Too far in the future, throw an error. |
94 | my $t = time; |
95 | if ( $s > $t ) { die <<"END_DIE" } |
96 | |
97 | Your installer $0 has a modification time in the future ($s > $t). |
98 | |
99 | This is known to create infinite loops in make. |
100 | |
101 | Please correct this, then run $0 again. |
102 | |
103 | END_DIE |
104 | } |
105 | |
106 | |
107 | # Build.PL was formerly supported, but no longer is due to excessive |
108 | # difficulty in implementing every single feature twice. |
109 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } |
110 | |
111 | Module::Install no longer supports Build.PL. |
112 | |
113 | It was impossible to maintain duel backends, and has been deprecated. |
114 | |
115 | Please remove all Build.PL files and only use the Makefile.PL installer. |
116 | |
117 | END_DIE |
118 | |
119 | #------------------------------------------------------------- |
120 | |
121 | # To save some more typing in Module::Install installers, every... |
122 | # use inc::Module::Install |
123 | # ...also acts as an implicit use strict. |
124 | $^H |= strict::bits(qw(refs subs vars)); |
125 | |
126 | #------------------------------------------------------------- |
127 | |
128 | unless ( -f $self->{file} ) { |
129 | foreach my $key (keys %INC) { |
130 | delete $INC{$key} if $key =~ /Module\/Install/; |
131 | } |
132 | |
133 | local $^W; |
134 | require "$self->{path}/$self->{dispatch}.pm"; |
135 | File::Path::mkpath("$self->{prefix}/$self->{author}"); |
136 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); |
137 | $self->{admin}->init; |
138 | @_ = ($class, _self => $self); |
139 | goto &{"$self->{name}::import"}; |
140 | } |
141 | |
142 | local $^W; |
143 | *{"${who}::AUTOLOAD"} = $self->autoload; |
144 | $self->preload; |
145 | |
146 | # Unregister loader and worker packages so subdirs can use them again |
147 | delete $INC{'inc/Module/Install.pm'}; |
148 | delete $INC{'Module/Install.pm'}; |
149 | |
150 | # Save to the singleton |
151 | $MAIN = $self; |
152 | |
153 | return 1; |
154 | } |
155 | |
156 | sub autoload { |
157 | my $self = shift; |
158 | my $who = $self->_caller; |
159 | my $cwd = Cwd::cwd(); |
160 | my $sym = "${who}::AUTOLOAD"; |
161 | $sym->{$cwd} = sub { |
162 | my $pwd = Cwd::cwd(); |
163 | if ( my $code = $sym->{$pwd} ) { |
164 | # Delegate back to parent dirs |
165 | goto &$code unless $cwd eq $pwd; |
166 | } |
167 | unless ($$sym =~ s/([^:]+)$//) { |
168 | # XXX: it looks like we can't retrieve the missing function |
169 | # via $$sym (usually $main::AUTOLOAD) in this case. |
170 | # I'm still wondering if we should slurp Makefile.PL to |
171 | # get some context or not ... |
172 | my ($package, $file, $line) = caller; |
173 | die <<"EOT"; |
174 | Unknown function is found at $file line $line. |
175 | Execution of $file aborted due to runtime errors. |
176 | |
177 | If you're a contributor to a project, you may need to install |
178 | some Module::Install extensions from CPAN (or other repository). |
179 | If you're a user of a module, please contact the author. |
180 | EOT |
181 | } |
182 | my $method = $1; |
183 | if ( uc($method) eq $method ) { |
184 | # Do nothing |
185 | return; |
186 | } elsif ( $method =~ /^_/ and $self->can($method) ) { |
187 | # Dispatch to the root M:I class |
188 | return $self->$method(@_); |
189 | } |
190 | |
191 | # Dispatch to the appropriate plugin |
192 | unshift @_, ( $self, $1 ); |
193 | goto &{$self->can('call')}; |
194 | }; |
195 | } |
196 | |
197 | sub preload { |
198 | my $self = shift; |
199 | unless ( $self->{extensions} ) { |
200 | $self->load_extensions( |
201 | "$self->{prefix}/$self->{path}", $self |
202 | ); |
203 | } |
204 | |
205 | my @exts = @{$self->{extensions}}; |
206 | unless ( @exts ) { |
207 | @exts = $self->{admin}->load_all_extensions; |
208 | } |
209 | |
210 | my %seen; |
211 | foreach my $obj ( @exts ) { |
212 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { |
213 | next unless $obj->can($method); |
214 | next if $method =~ /^_/; |
215 | next if $method eq uc($method); |
216 | $seen{$method}++; |
217 | } |
218 | } |
219 | |
220 | my $who = $self->_caller; |
221 | foreach my $name ( sort keys %seen ) { |
222 | local $^W; |
223 | *{"${who}::$name"} = sub { |
224 | ${"${who}::AUTOLOAD"} = "${who}::$name"; |
225 | goto &{"${who}::AUTOLOAD"}; |
226 | }; |
227 | } |
228 | } |
229 | |
230 | sub new { |
231 | my ($class, %args) = @_; |
232 | |
233 | delete $INC{'FindBin.pm'}; |
234 | { |
235 | # to suppress the redefine warning |
236 | local $SIG{__WARN__} = sub {}; |
237 | require FindBin; |
238 | } |
239 | |
240 | # ignore the prefix on extension modules built from top level. |
241 | my $base_path = Cwd::abs_path($FindBin::Bin); |
242 | unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { |
243 | delete $args{prefix}; |
244 | } |
245 | return $args{_self} if $args{_self}; |
246 | |
247 | $args{dispatch} ||= 'Admin'; |
248 | $args{prefix} ||= 'inc'; |
249 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); |
250 | $args{bundle} ||= 'inc/BUNDLES'; |
251 | $args{base} ||= $base_path; |
252 | $class =~ s/^\Q$args{prefix}\E:://; |
253 | $args{name} ||= $class; |
254 | $args{version} ||= $class->VERSION; |
255 | unless ( $args{path} ) { |
256 | $args{path} = $args{name}; |
257 | $args{path} =~ s!::!/!g; |
258 | } |
259 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; |
260 | $args{wrote} = 0; |
261 | |
262 | bless( \%args, $class ); |
263 | } |
264 | |
265 | sub call { |
266 | my ($self, $method) = @_; |
267 | my $obj = $self->load($method) or return; |
268 | splice(@_, 0, 2, $obj); |
269 | goto &{$obj->can($method)}; |
270 | } |
271 | |
272 | sub load { |
273 | my ($self, $method) = @_; |
274 | |
275 | $self->load_extensions( |
276 | "$self->{prefix}/$self->{path}", $self |
277 | ) unless $self->{extensions}; |
278 | |
279 | foreach my $obj (@{$self->{extensions}}) { |
280 | return $obj if $obj->can($method); |
281 | } |
282 | |
283 | my $admin = $self->{admin} or die <<"END_DIE"; |
284 | The '$method' method does not exist in the '$self->{prefix}' path! |
285 | Please remove the '$self->{prefix}' directory and run $0 again to load it. |
286 | END_DIE |
287 | |
288 | my $obj = $admin->load($method, 1); |
289 | push @{$self->{extensions}}, $obj; |
290 | |
291 | $obj; |
292 | } |
293 | |
294 | sub load_extensions { |
295 | my ($self, $path, $top) = @_; |
296 | |
297 | my $should_reload = 0; |
298 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { |
299 | unshift @INC, $self->{prefix}; |
300 | $should_reload = 1; |
301 | } |
302 | |
303 | foreach my $rv ( $self->find_extensions($path) ) { |
304 | my ($file, $pkg) = @{$rv}; |
305 | next if $self->{pathnames}{$pkg}; |
306 | |
307 | local $@; |
308 | my $new = eval { local $^W; require $file; $pkg->can('new') }; |
309 | unless ( $new ) { |
310 | warn $@ if $@; |
311 | next; |
312 | } |
313 | $self->{pathnames}{$pkg} = |
314 | $should_reload ? delete $INC{$file} : $INC{$file}; |
315 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); |
316 | } |
317 | |
318 | $self->{extensions} ||= []; |
319 | } |
320 | |
321 | sub find_extensions { |
322 | my ($self, $path) = @_; |
323 | |
324 | my @found; |
325 | File::Find::find( sub { |
326 | my $file = $File::Find::name; |
327 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; |
328 | my $subpath = $1; |
329 | return if lc($subpath) eq lc($self->{dispatch}); |
330 | |
331 | $file = "$self->{path}/$subpath.pm"; |
332 | my $pkg = "$self->{name}::$subpath"; |
333 | $pkg =~ s!/!::!g; |
334 | |
335 | # If we have a mixed-case package name, assume case has been preserved |
336 | # correctly. Otherwise, root through the file to locate the case-preserved |
337 | # version of the package name. |
338 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { |
339 | my $content = Module::Install::_read($subpath . '.pm'); |
340 | my $in_pod = 0; |
341 | foreach ( split //, $content ) { |
342 | $in_pod = 1 if /^=\w/; |
343 | $in_pod = 0 if /^=cut/; |
344 | next if ($in_pod || /^=cut/); # skip pod text |
345 | next if /^\s*#/; # and comments |
346 | if ( m/^\s*package\s+($pkg)\s*;/i ) { |
347 | $pkg = $1; |
348 | last; |
349 | } |
350 | } |
351 | } |
352 | |
353 | push @found, [ $file, $pkg ]; |
354 | }, $path ) if -d $path; |
355 | |
356 | @found; |
357 | } |
358 | |
359 | |
360 | |
361 | |
362 | |
363 | ##################################################################### |
364 | # Common Utility Functions |
365 | |
366 | sub _caller { |
367 | my $depth = 0; |
368 | my $call = caller($depth); |
369 | while ( $call eq __PACKAGE__ ) { |
370 | $depth++; |
371 | $call = caller($depth); |
372 | } |
373 | return $call; |
374 | } |
375 | |
376 | # Done in evals to avoid confusing Perl::MinimumVersion |
377 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; |
378 | sub _read { |
379 | local *FH; |
380 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; |
381 | my $string = do { local $/; <FH> }; |
382 | close FH or die "close($_[0]): $!"; |
383 | return $string; |
384 | } |
385 | END_NEW |
386 | sub _read { |
387 | local *FH; |
388 | open( FH, "< $_[0]" ) or die "open($_[0]): $!"; |
389 | my $string = do { local $/; <FH> }; |
390 | close FH or die "close($_[0]): $!"; |
391 | return $string; |
392 | } |
393 | END_OLD |
394 | |
395 | sub _readperl { |
396 | my $string = Module::Install::_read($_[0]); |
397 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; |
398 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; |
399 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; |
400 | return $string; |
401 | } |
402 | |
403 | sub _readpod { |
404 | my $string = Module::Install::_read($_[0]); |
405 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; |
406 | return $string if $_[0] =~ /\.pod\z/; |
407 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; |
408 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; |
409 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; |
410 | $string =~ s/^\n+//s; |
411 | return $string; |
412 | } |
413 | |
414 | # Done in evals to avoid confusing Perl::MinimumVersion |
415 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; |
416 | sub _write { |
417 | local *FH; |
418 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; |
419 | foreach ( 1 .. $#_ ) { |
420 | print FH $_[$_] or die "print($_[0]): $!"; |
421 | } |
422 | close FH or die "close($_[0]): $!"; |
423 | } |
424 | END_NEW |
425 | sub _write { |
426 | local *FH; |
427 | open( FH, "> $_[0]" ) or die "open($_[0]): $!"; |
428 | foreach ( 1 .. $#_ ) { |
429 | print FH $_[$_] or die "print($_[0]): $!"; |
430 | } |
431 | close FH or die "close($_[0]): $!"; |
432 | } |
433 | END_OLD |
434 | |
435 | # _version is for processing module versions (eg, 1.03_05) not |
436 | # Perl versions (eg, 5.8.1). |
437 | sub _version ($) { |
438 | my $s = shift || 0; |
439 | my $d =()= $s =~ /(\.)/g; |
440 | if ( $d >= 2 ) { |
441 | # Normalise multipart versions |
442 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; |
443 | } |
444 | $s =~ s/^(\d+)\.?//; |
445 | my $l = $1 || 0; |
446 | my @v = map { |
447 | $_ . '0' x (3 - length $_) |
448 | } $s =~ /(\d{1,3})\D?/g; |
449 | $l = $l . '.' . join '', @v if @v; |
450 | return $l + 0; |
451 | } |
452 | |
453 | sub _cmp ($$) { |
454 | _version($_[0]) <=> _version($_[1]); |
455 | } |
456 | |
457 | # Cloned from Params::Util::_CLASS |
458 | sub _CLASS ($) { |
459 | ( |
460 | defined $_[0] |
461 | and |
462 | ! ref $_[0] |
463 | and |
464 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s |
465 | ) ? $_[0] : undef; |
466 | } |
467 | |
468 | 1; |
469 | |
470 | # Copyright 2008 - 2010 Adam Kennedy. |