1#line 1 2package 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 20use 5.005; 21use strict 'vars'; 22use Cwd (); 23use File::Find (); 24use File::Path (); 25 26use vars qw{$VERSION $MAIN}; 27BEGIN { 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.04'; 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 44sub 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 64Please invoke ${\__PACKAGE__} with: 65 66 use inc::${\__PACKAGE__}; 67 68not: 69 70 use ${\__PACKAGE__}; 71 72END_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 97Your installer $0 has a modification time in the future ($s > $t). 98 99This is known to create infinite loops in make. 100 101Please correct this, then run $0 again. 102 103END_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 111Module::Install no longer supports Build.PL. 112 113It was impossible to maintain duel backends, and has been deprecated. 114 115Please remove all Build.PL files and only use the Makefile.PL installer. 116 117END_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 156sub 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"; 174Unknown function is found at $file line $line. 175Execution of $file aborted due to runtime errors. 176 177If you're a contributor to a project, you may need to install 178some Module::Install extensions from CPAN (or other repository). 179If you're a user of a module, please contact the author. 180EOT 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 197sub 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 230sub 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 265sub 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 272sub 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"; 284The '$method' method does not exist in the '$self->{prefix}' path! 285Please remove the '$self->{prefix}' directory and run $0 again to load it. 286END_DIE 287 288 my $obj = $admin->load($method, 1); 289 push @{$self->{extensions}}, $obj; 290 291 $obj; 292} 293 294sub 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 321sub 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 366sub _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 377eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 378sub _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} 385END_NEW 386sub _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} 393END_OLD 394 395sub _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 403sub _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 415eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 416sub _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} 424END_NEW 425sub _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} 433END_OLD 434 435# _version is for processing module versions (eg, 1.03_05) not 436# Perl versions (eg, 5.8.1). 437sub _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 453sub _cmp ($$) { 454 _version($_[1]) <=> _version($_[2]); 455} 456 457# Cloned from Params::Util::_CLASS 458sub _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 4681; 469 470# Copyright 2008 - 2011 Adam Kennedy. 471