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 = '0.99'; 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 require FindBin; 235 236 # ignore the prefix on extension modules built from top level. 237 my $base_path = Cwd::abs_path($FindBin::Bin); 238 unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { 239 delete $args{prefix}; 240 } 241 return $args{_self} if $args{_self}; 242 243 $args{dispatch} ||= 'Admin'; 244 $args{prefix} ||= 'inc'; 245 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 246 $args{bundle} ||= 'inc/BUNDLES'; 247 $args{base} ||= $base_path; 248 $class =~ s/^\Q$args{prefix}\E:://; 249 $args{name} ||= $class; 250 $args{version} ||= $class->VERSION; 251 unless ( $args{path} ) { 252 $args{path} = $args{name}; 253 $args{path} =~ s!::!/!g; 254 } 255 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 256 $args{wrote} = 0; 257 258 bless( \%args, $class ); 259} 260 261sub call { 262 my ($self, $method) = @_; 263 my $obj = $self->load($method) or return; 264 splice(@_, 0, 2, $obj); 265 goto &{$obj->can($method)}; 266} 267 268sub load { 269 my ($self, $method) = @_; 270 271 $self->load_extensions( 272 "$self->{prefix}/$self->{path}", $self 273 ) unless $self->{extensions}; 274 275 foreach my $obj (@{$self->{extensions}}) { 276 return $obj if $obj->can($method); 277 } 278 279 my $admin = $self->{admin} or die <<"END_DIE"; 280The '$method' method does not exist in the '$self->{prefix}' path! 281Please remove the '$self->{prefix}' directory and run $0 again to load it. 282END_DIE 283 284 my $obj = $admin->load($method, 1); 285 push @{$self->{extensions}}, $obj; 286 287 $obj; 288} 289 290sub load_extensions { 291 my ($self, $path, $top) = @_; 292 293 my $should_reload = 0; 294 unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 295 unshift @INC, $self->{prefix}; 296 $should_reload = 1; 297 } 298 299 foreach my $rv ( $self->find_extensions($path) ) { 300 my ($file, $pkg) = @{$rv}; 301 next if $self->{pathnames}{$pkg}; 302 303 local $@; 304 my $new = eval { local $^W; require $file; $pkg->can('new') }; 305 unless ( $new ) { 306 warn $@ if $@; 307 next; 308 } 309 $self->{pathnames}{$pkg} = 310 $should_reload ? delete $INC{$file} : $INC{$file}; 311 push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 312 } 313 314 $self->{extensions} ||= []; 315} 316 317sub find_extensions { 318 my ($self, $path) = @_; 319 320 my @found; 321 File::Find::find( sub { 322 my $file = $File::Find::name; 323 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 324 my $subpath = $1; 325 return if lc($subpath) eq lc($self->{dispatch}); 326 327 $file = "$self->{path}/$subpath.pm"; 328 my $pkg = "$self->{name}::$subpath"; 329 $pkg =~ s!/!::!g; 330 331 # If we have a mixed-case package name, assume case has been preserved 332 # correctly. Otherwise, root through the file to locate the case-preserved 333 # version of the package name. 334 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 335 my $content = Module::Install::_read($subpath . '.pm'); 336 my $in_pod = 0; 337 foreach ( split //, $content ) { 338 $in_pod = 1 if /^=\w/; 339 $in_pod = 0 if /^=cut/; 340 next if ($in_pod || /^=cut/); # skip pod text 341 next if /^\s*#/; # and comments 342 if ( m/^\s*package\s+($pkg)\s*;/i ) { 343 $pkg = $1; 344 last; 345 } 346 } 347 } 348 349 push @found, [ $file, $pkg ]; 350 }, $path ) if -d $path; 351 352 @found; 353} 354 355 356 357 358 359##################################################################### 360# Common Utility Functions 361 362sub _caller { 363 my $depth = 0; 364 my $call = caller($depth); 365 while ( $call eq __PACKAGE__ ) { 366 $depth++; 367 $call = caller($depth); 368 } 369 return $call; 370} 371 372# Done in evals to avoid confusing Perl::MinimumVersion 373eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 374sub _read { 375 local *FH; 376 open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 377 my $string = do { local $/; <FH> }; 378 close FH or die "close($_[0]): $!"; 379 return $string; 380} 381END_NEW 382sub _read { 383 local *FH; 384 open( FH, "< $_[0]" ) or die "open($_[0]): $!"; 385 my $string = do { local $/; <FH> }; 386 close FH or die "close($_[0]): $!"; 387 return $string; 388} 389END_OLD 390 391sub _readperl { 392 my $string = Module::Install::_read($_[0]); 393 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 394 $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 395 $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 396 return $string; 397} 398 399sub _readpod { 400 my $string = Module::Install::_read($_[0]); 401 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 402 return $string if $_[0] =~ /\.pod\z/; 403 $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 404 $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 405 $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 406 $string =~ s/^\n+//s; 407 return $string; 408} 409 410# Done in evals to avoid confusing Perl::MinimumVersion 411eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 412sub _write { 413 local *FH; 414 open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 415 foreach ( 1 .. $#_ ) { 416 print FH $_[$_] or die "print($_[0]): $!"; 417 } 418 close FH or die "close($_[0]): $!"; 419} 420END_NEW 421sub _write { 422 local *FH; 423 open( FH, "> $_[0]" ) or die "open($_[0]): $!"; 424 foreach ( 1 .. $#_ ) { 425 print FH $_[$_] or die "print($_[0]): $!"; 426 } 427 close FH or die "close($_[0]): $!"; 428} 429END_OLD 430 431# _version is for processing module versions (eg, 1.03_05) not 432# Perl versions (eg, 5.8.1). 433sub _version ($) { 434 my $s = shift || 0; 435 my $d =()= $s =~ /(\.)/g; 436 if ( $d >= 2 ) { 437 # Normalise multipart versions 438 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 439 } 440 $s =~ s/^(\d+)\.?//; 441 my $l = $1 || 0; 442 my @v = map { 443 $_ . '0' x (3 - length $_) 444 } $s =~ /(\d{1,3})\D?/g; 445 $l = $l . '.' . join '', @v if @v; 446 return $l + 0; 447} 448 449sub _cmp ($$) { 450 _version($_[0]) <=> _version($_[1]); 451} 452 453# Cloned from Params::Util::_CLASS 454sub _CLASS ($) { 455 ( 456 defined $_[0] 457 and 458 ! ref $_[0] 459 and 460 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 461 ) ? $_[0] : undef; 462} 463 4641; 465 466# Copyright 2008 - 2010 Adam Kennedy. 467