File Coverage

blib/lib/Module/Install.pm
Criterion Covered Total %
statement 84 234 35.9
branch 16 102 15.6
condition 19 45 42.2
subroutine 14 27 51.8
pod 0 7 0.0
total 133 415 32.0


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