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.005;
  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.02';
  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::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";
 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::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
 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 //, $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         my $string = do { local $/; <FH> };
 382         close FH or die "close($_[0]): $!";
 383         return $string;
 384 }
 385 END_NEW
 386 sub _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 }
 393 END_OLD
 394
 395 sub _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
 403 sub _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
 415 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 416 sub _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 }
 424 END_NEW
 425 sub _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 }
 433 END_OLD
 434
 435 # _version is for processing module versions (eg, 1.03_05) not
 436 # Perl versions (eg, 5.8.1).
 437 sub _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
 453 sub _cmp ($$) {
 454         _version($_[0]) <=> _version($_[1]);
 455 }
 456
 457 # Cloned from Params::Util::_CLASS
 458 sub _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
 468 1;
 469
 470 # Copyright 2008 - 2011 Adam Kennedy.