inc/Module/Install.pm

   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
  20 use 5.006;
  21 use strict 'vars';
  22 use Cwd        ();
  23 use File::Find ();
  24 use File::Path ();
  25
  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         # Module::Install extensions.
  34         $VERSION = '1.16';
  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
  44 sub 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
  64 Please invoke ${\__PACKAGE__} with:
  65
  66         use inc::${\__PACKAGE__};
  67
  68 not:
  69
  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         # (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
  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         # difficulty in implementing every single feature twice.
 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         # ...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
 156 sub 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";
 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                 }
 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
 197 sub 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
 230 sub 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         $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
 265 sub 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
 272 sub 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";
 284 The '$method' method does not exist in the '$self->{prefix}' path!
 285 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 286 END_DIE
 287
 288         my $obj = $admin->load($method, 1);
 289         push @{$self->{extensions}}, $obj;
 290
 291         $obj;
 292 }
 293
 294 sub 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
 321 sub 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 /\n/, $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
 366 sub _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
 377 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 378 sub _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 END_NEW
 387 sub _read {
 388         local *FH;
 389         open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
 390         binmode FH;
 391         my $string = do { local $/; <FH> };
 392         close FH or die "close($_[0]): $!";
 393         return $string;
 394 }
 395 END_OLD
 396
 397 sub _readperl {
 398         my $string = Module::Install::_read($_[0]);
 399         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 400         $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
 401         $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
 402         return $string;
 403 }
 404
 405 sub _readpod {
 406         my $string = Module::Install::_read($_[0]);
 407         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 408         return $string if $_[0] =~ /\.pod\z/;
 409         $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
 410         $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
 411         $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
 412         $string =~ s/^\n+//s;
 413         return $string;
 414 }
 415
 416 # Done in evals to avoid confusing Perl::MinimumVersion
 417 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 418 sub _write {
 419         local *FH;
 420         open( FH, '>', $_[0] ) or die "open($_[0]): $!";
 421         binmode FH;
 422         foreach ( 1 .. $#_ ) {
 423                 print FH $_[$_] or die "print($_[0]): $!";
 424         }
 425         close FH or die "close($_[0]): $!";
 426 }
 427 END_NEW
 428 sub _write {
 429         local *FH;
 430         open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
 431         binmode FH;
 432         foreach ( 1 .. $#_ ) {
 433                 print FH $_[$_] or die "print($_[0]): $!";
 434         }
 435         close FH or die "close($_[0]): $!";
 436 }
 437 END_OLD
 438
 439 # _version is for processing module versions (eg, 1.03_05) not
 440 # Perl versions (eg, 5.8.1).
 441 sub _version {
 442         my $s = shift || 0;
 443         my $d =()= $s =~ /(\.)/g;
 444         if ( $d >= 2 ) {
 445                 # Normalise multipart versions
 446                 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
 447         }
 448         $s =~ s/^(\d+)\.?//;
 449         my $l = $1 || 0;
 450         my @v = map {
 451                 $_ . '0' x (3 - length $_)
 452         } $s =~ /(\d{1,3})\D?/g;
 453         $l = $l . '.' . join '', @v if @v;
 454         return $l + 0;
 455 }
 456
 457 sub _cmp {
 458         _version($_[1]) <=> _version($_[2]);
 459 }
 460
 461 # Cloned from Params::Util::_CLASS
 462 sub _CLASS {
 463         (
 464                 defined $_[0]
 465                 and
 466                 ! ref $_[0]
 467                 and
 468                 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
 469         ) ? $_[0] : undef;
 470 }
 471
 472 1;
 473
 474 # Copyright 2008 - 2012 Adam Kennedy.