File Coverage

inc/Module/Install.pm
Criterion Covered Total %
statement 15 234 6.4
branch 0 102 0.0
condition 0 45 0.0
subroutine 7 27 25.9
pod 0 7 0.0
total 22 415 5.3


line stmt bran cond sub pod time code
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 1     1   2496366  
  0         0  
20 1     1   5 use 5.006;
  0         0  
  1         21  
21 1     1   4 use strict 'vars';
  0         0  
  1         22  
22 1     1   4 use Cwd ();
  0         0  
  1         14  
23 1     1   6 use File::Find ();
  0         0  
  1         24  
24             use File::Path ();
25 1     1   6  
  0         0  
  1         94  
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 1     1   3 # Module::Install extensions.
34             $VERSION = '1.19';
35              
36 1         2 # Storage for the pseudo-singleton
37             $MAIN    = undef;
38 1         2  
39 1         2783 *inc::Module::Install::VERSION = *VERSION;
40             @inc::Module::Install::ISA     = __PACKAGE__;
41              
42             }
43              
44 0     0     sub import {
45 0           my $class = shift;
46 0           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 0           # result in false errors or unexpected behaviour. And we don't want that.
61 0 0         my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
  0            
62             unless ( $INC{$file} ) { die <<"END_DIE" }
63 0          
64             Please invoke ${\__PACKAGE__} with:
65 0          
66             use inc::${\__PACKAGE__};
67            
68             not:
69 0          
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 0 0 0       # (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 0 0         # for now we should catch this and refuse to run.
85 0           if ( -f $0 ) {
86             my $s = (stat($0))[9];
87              
88             # If the modification time is only slightly in the future,
89 0           # sleep briefly to remove the problem.
90 0 0 0       my $a = $s - time;
  0            
91             if ( $a > 0 and $a < 5 ) { sleep 5 }
92              
93 0           # Too far in the future, throw an error.
94 0 0         my $t = time;
  0            
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 0 0         # difficulty in implementing every single feature twice.
  0            
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 0           # ...also acts as an implicit use strict.
124             $^H |= strict::bits(qw(refs subs vars));
125              
126             #-------------------------------------------------------------
127 0 0          
128 0           unless ( -f $self->{file} ) {
129 0 0         foreach my $key (keys %INC) {
130             delete $INC{$key} if $key =~ /Module\/Install/;
131             }
132 0            
133 0           local $^W;
134 0           require "$self->{path}/$self->{dispatch}.pm";
135 0           File::Path::mkpath("$self->{prefix}/$self->{author}");
136 0           $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
137 0           $self->{admin}->init;
138 0           @_ = ($class, _self => $self);
  0            
139             goto &{"$self->{name}::import"};
140             }
141 0            
142 0           local $^W;
  0            
143 0           *{"${who}::AUTOLOAD"} = $self->autoload;
144             $self->preload;
145              
146 0           # Unregister loader and worker packages so subdirs can use them again
147 0           delete $INC{'inc/Module/Install.pm'};
148             delete $INC{'Module/Install.pm'};
149              
150 0           # Save to the singleton
151             $MAIN = $self;
152 0            
153             return 1;
154             }
155              
156 0     0 0   sub autoload {
157 0           my $self = shift;
158 0           my $who = $self->_caller;
159 0           my $cwd = Cwd::getcwd();
160             my $sym = "${who}::AUTOLOAD";
161 0     0     $sym->{$cwd} = sub {
162 0 0         my $pwd = Cwd::getcwd();
163             if ( my $code = $sym->{$pwd} ) {
164 0 0         # Delegate back to parent dirs
165             goto &$code unless $cwd eq $pwd;
166 0 0         }
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 0           # get some context or not ...
172 0           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 0           }
182 0 0 0       my $method = $1;
    0          
183             if ( uc($method) eq $method ) {
184 0           # Do nothing
185             return;
186             } elsif ( $method =~ /^_/ and $self->can($method) ) {
187 0           # Dispatch to the root M:I class
188             return $self->$method(@_);
189             }
190              
191 0           # Dispatch to the appropriate plugin
192 0           unshift @_, ( $self, $1 );
  0            
193 0           goto &{$self->can('call')};
194             };
195             }
196              
197 0     0 0   sub preload {
198 0 0         my $self = shift;
199 0           unless ( $self->{extensions} ) {
200             $self->load_extensions(
201             "$self->{prefix}/$self->{path}", $self
202             );
203             }
204 0            
  0            
205 0 0         my @exts = @{$self->{extensions}};
206 0           unless ( @exts ) {
207             @exts = $self->{admin}->load_all_extensions;
208             }
209 0            
210 0           my %seen;
211 0           foreach my $obj ( @exts ) {
  0            
212 0 0         while (my ($method, $glob) = each %{ref($obj) . '::'}) {
213 0 0         next unless $obj->can($method);
214 0 0         next if $method =~ /^_/;
215 0           next if $method eq uc($method);
216             $seen{$method}++;
217             }
218             }
219 0            
220 0           my $who = $self->_caller;
221 0           foreach my $name ( sort keys %seen ) {
222 0           local $^W;
223 0     0     *{"${who}::$name"} = sub {
  0            
224 0           ${"${who}::AUTOLOAD"} = "${who}::$name";
  0            
225 0           goto &{"${who}::AUTOLOAD"};
226             };
227             }
228             }
229              
230 0     0 0   sub new {
231             my ($class, %args) = @_;
232 0            
233             delete $INC{'FindBin.pm'};
234             {
235 0     0     # to suppress the redefine warning
  0            
236 0           local $SIG{__WARN__} = sub {};
237             require FindBin;
238             }
239              
240 0           # ignore the prefix on extension modules built from top level.
241 0 0         my $base_path = Cwd::abs_path($FindBin::Bin);
242 0           unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) {
243             delete $args{prefix};
244 0 0         }
245             return $args{_self} if $args{_self};
246 0 0          
247             $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
248 0   0        
249 0   0       $args{dispatch} ||= 'Admin';
250 0 0 0       $args{prefix}   ||= 'inc';
251 0   0       $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
252 0   0       $args{bundle}   ||= 'inc/BUNDLES';
253 0           $args{base}     ||= $base_path;
254 0   0       $class =~ s/^\Q$args{prefix}\E:://;
255 0   0       $args{name}     ||= $class;
256 0 0         $args{version}  ||= $class->VERSION;
257 0           unless ( $args{path} ) {
258 0           $args{path}  = $args{name};
259             $args{path}  =~ s!::!/!g;
260 0   0       }
261 0           $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
262             $args{wrote}      = 0;
263 0            
264             bless( \%args, $class );
265             }
266              
267 0     0 0   sub call {
268 0 0         my ($self, $method) = @_;
269 0           my $obj = $self->load($method) or return;
270 0                   splice(@_, 0, 2, $obj);
  0            
271             goto &{$obj->can($method)};
272             }
273              
274 0     0 0   sub load {
275             my ($self, $method) = @_;
276              
277             $self->load_extensions(
278 0 0         "$self->{prefix}/$self->{path}", $self
279             ) unless $self->{extensions};
280 0            
  0            
281 0 0         foreach my $obj (@{$self->{extensions}}) {
282             return $obj if $obj->can($method);
283             }
284 0 0          
285             my $admin = $self->{admin} or die <<"END_DIE";
286             The '$method' method does not exist in the '$self->{prefix}' path!
287             Please remove the '$self->{prefix}' directory and run $0 again to load it.
288             END_DIE
289 0            
290 0           my $obj = $admin->load($method, 1);
  0            
291             push @{$self->{extensions}}, $obj;
292 0            
293             $obj;
294             }
295              
296 0     0 0   sub load_extensions {
297             my ($self, $path, $top) = @_;
298 0            
299 0 0         my $should_reload = 0;
  0 0          
300 0           unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
301 0           unshift @INC, $self->{prefix};
302             $should_reload = 1;
303             }
304 0            
305 0           foreach my $rv ( $self->find_extensions($path) ) {
  0            
306 0 0         my ($file, $pkg) = @{$rv};
307             next if $self->{pathnames}{$pkg};
308 0            
309 0           local $@;
  0            
  0            
  0            
310 0 0         my $new = eval { local $^W; require $file; $pkg->can('new') };
311 0 0         unless ( $new ) {
312 0           warn $@ if $@;
313             next;
314             }
315 0 0         $self->{pathnames}{$pkg} =
316 0           $should_reload ? delete $INC{$file} : $INC{$file};
  0            
  0            
317             push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
318             }
319 0   0        
320             $self->{extensions} ||= [];
321             }
322              
323 0     0 0   sub find_extensions {
324             my ($self, $path) = @_;
325 0            
326             my @found;
327 0     0     File::Find::find( {no_chdir => 1, wanted => sub {
328 0 0         my $file = $File::Find::name;
329 0           return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
330 0 0         my $subpath = $1;
331             return if lc($subpath) eq lc($self->{dispatch});
332 0            
333 0           $file = "$self->{path}/$subpath.pm";
334 0           my $pkg = "$self->{name}::$subpath";
335             $pkg =~ s!/!::!g;
336              
337             # If we have a mixed-case package name, assume case has been preserved
338             # correctly. Otherwise, root through the file to locate the case-preserved
339 0 0 0       # version of the package name.
340 0           if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
341 0           my $content = Module::Install::_read($File::Find::name);
342 0           my $in_pod = 0;
343 0 0         foreach ( split /\n/, $content ) {
344 0 0         $in_pod = 1 if /^=\w/;
345 0 0 0       $in_pod = 0 if /^=cut/;
346 0 0         next if ($in_pod || /^=cut/); # skip pod text
347 0 0         next if /^\s*#/; # and comments
348 0           if ( m/^\s*package\s+($pkg)\s*;/i ) {
349 0           $pkg = $1;
350             last;
351             }
352             }
353             }
354 0            
355 0 0         push @found, [ $file, $pkg ];
356             }}, $path ) if -d $path;
357 0            
358             @found;
359             }
360              
361              
362              
363              
364              
365             #####################################################################
366             # Common Utility Functions
367              
368 0     0     sub _caller {
369 0           my $depth = 0;
370 0           my $call = caller($depth);
371 0           while ( $call eq __PACKAGE__ ) {
372 0           $depth++;
373             $call = caller($depth);
374 0           }
375             return $call;
376             }
377              
378 0     0     sub _read {
379 0 0         local *FH;
380 0           open( FH, '<', $_[0] ) or die "open($_[0]): $!";
381 0           binmode FH;
  0            
  0            
382 0 0         my $string = do { local $/; <FH> };
383 0           close FH or die "close($_[0]): $!";
384             return $string;
385             }
386              
387 0     0     sub _readperl {
388 0           my $string = Module::Install::_read($_[0]);
389 0           $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
390 0           $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
391 0           $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
392             return $string;
393             }
394              
395 0     0     sub _readpod {
396 0           my $string = Module::Install::_read($_[0]);
397 0 0         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
398 0           return $string if $_[0] =~ /\.pod\z/;
399 0           $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
400 0           $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
401 0           $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
402 0           $string =~ s/^\n+//s;
403             return $string;
404             }
405              
406 0     0     sub _write {
407 0 0         local *FH;
408 0           open( FH, '>', $_[0] ) or die "open($_[0]): $!";
409 0           binmode FH;
410 0 0         foreach ( 1 .. $#_ ) {
411             print FH $_[$_] or die "print($_[0]): $!";
412 0 0         }
413             close FH or die "close($_[0]): $!";
414             }
415              
416             # _version is for processing module versions (eg, 1.03_05) not
417             # Perl versions (eg, 5.8.1).
418 0   0 0     sub _version {
419 0           my $s = shift || 0;
420 0 0         my $d =()= $s =~ /(\.)/g;
421             if ( $d >= 2 ) {
422 0           # Normalise multipart versions
  0            
423             $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
424 0           }
425 0   0       $s =~ s/^(\d+)\.?//;
426             my $l = $1 || 0;
427 0           my @v = map {
  0            
428             $_ . '0' x (3 - length $_)
429 0 0         } $s =~ /(\d{1,3})\D?/g;
430 0           $l = $l . '.' . join '', @v if @v;
431             return $l + 0;
432             }
433              
434 0     0     sub _cmp {
435             _version($_[1]) <=> _version($_[2]);
436             }
437              
438             # Cloned from Params::Util::_CLASS
439             sub _CLASS {
440 0 0 0 0     (
441             defined $_[0]
442             and
443             ! ref $_[0]
444             and
445             $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
446             ) ? $_[0] : undef;
447             }
448              
449             1;
450              
451             # Copyright 2008 - 2012 Adam Kennedy.
452