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