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 use FindBin;
  26
  27 use vars qw{$VERSION $MAIN};
  28 BEGIN {
  29         # All Module::Install core packages now require synchronised versions.
  30         # This will be used to ensure we don't accidentally load old or
  31         # different versions of modules.
  32         # This is not enforced yet, but will be some time in the next few
  33         # releases once we can make sure it won't clash with custom
  34         # Module::Install extensions.
  35         $VERSION = '0.97';
  36
  37         # Storage for the pseudo-singleton
  38         $MAIN    = undef;
  39
  40         *inc::Module::Install::VERSION = *VERSION;
  41         @inc::Module::Install::ISA     = __PACKAGE__;
  42
  43 }
  44
  45 sub import {
  46         my $class = shift;
  47         my $self  = $class->new(@_);
  48         my $who   = $self->_caller;
  49
  50         #-------------------------------------------------------------
  51         # all of the following checks should be included in import(),
  52         # to allow "eval 'require Module::Install; 1' to test
  53         # installation of Module::Install. (RT #51267)
  54         #-------------------------------------------------------------
  55
  56         # Whether or not inc::Module::Install is actually loaded, the
  57         # $INC{inc/Module/Install.pm} is what will still get set as long as
  58         # the caller loaded module this in the documented manner.
  59         # If not set, the caller may NOT have loaded the bundled version, and thus
  60         # they may not have a MI version that works with the Makefile.PL. This would
  61         # result in false errors or unexpected behaviour. And we don't want that.
  62         my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
  63         unless ( $INC{$file} ) { die <<"END_DIE" }
  64
  65 Please invoke ${\__PACKAGE__} with:
  66
  67         use inc::${\__PACKAGE__};
  68
  69 not:
  70
  71         use ${\__PACKAGE__};
  72
  73 END_DIE
  74
  75         # This reportedly fixes a rare Win32 UTC file time issue, but
  76         # as this is a non-cross-platform XS module not in the core,
  77         # we shouldn't really depend on it. See RT #24194 for detail.
  78         # (Also, this module only supports Perl 5.6 and above).
  79         eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
  80
  81         # If the script that is loading Module::Install is from the future,
  82         # then make will detect this and cause it to re-run over and over
  83         # again. This is bad. Rather than taking action to touch it (which
  84         # is unreliable on some platforms and requires write permissions)
  85         # for now we should catch this and refuse to run.
  86         if ( -f $0 ) {
  87                 my $s = (stat($0))[9];
  88
  89                 # If the modification time is only slightly in the future,
  90                 # sleep briefly to remove the problem.
  91                 my $a = $s - time;
  92                 if ( $a > 0 and $a < 5 ) { sleep 5 }
  93
  94                 # Too far in the future, throw an error.
  95                 my $t = time;
  96                 if ( $s > $t ) { die <<"END_DIE" }
  97
  98 Your installer $0 has a modification time in the future ($s > $t).
  99
 100 This is known to create infinite loops in make.
 101
 102 Please correct this, then run $0 again.
 103
 104 END_DIE
 105         }
 106
 107
 108         # Build.PL was formerly supported, but no longer is due to excessive
 109         # difficulty in implementing every single feature twice.
 110         if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
 111
 112 Module::Install no longer supports Build.PL.
 113
 114 It was impossible to maintain duel backends, and has been deprecated.
 115
 116 Please remove all Build.PL files and only use the Makefile.PL installer.
 117
 118 END_DIE
 119
 120         #-------------------------------------------------------------
 121
 122         # To save some more typing in Module::Install installers, every...
 123         # use inc::Module::Install
 124         # ...also acts as an implicit use strict.
 125         $^H |= strict::bits(qw(refs subs vars));
 126
 127         #-------------------------------------------------------------
 128
 129         unless ( -f $self->{file} ) {
 130                 foreach my $key (keys %INC) {
 131                         delete $INC{$key} if $key =~ /Module\/Install/;
 132                 }
 133
 134                 local $^W;
 135                 require "$self->{path}/$self->{dispatch}.pm";
 136                 File::Path::mkpath("$self->{prefix}/$self->{author}");
 137                 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 138                 $self->{admin}->init;
 139                 @_ = ($class, _self => $self);
 140                 goto &{"$self->{name}::import"};
 141         }
 142
 143         local $^W;
 144         *{"${who}::AUTOLOAD"} = $self->autoload;
 145         $self->preload;
 146
 147         # Unregister loader and worker packages so subdirs can use them again
 148         delete $INC{'inc/Module/Install.pm'};
 149         delete $INC{'Module/Install.pm'};
 150
 151         # Save to the singleton
 152         $MAIN = $self;
 153
 154         return 1;
 155 }
 156
 157 sub autoload {
 158         my $self = shift;
 159         my $who  = $self->_caller;
 160         my $cwd  = Cwd::cwd();
 161         my $sym  = "${who}::AUTOLOAD";
 162         $sym->{$cwd} = sub {
 163                 my $pwd = Cwd::cwd();
 164                 if ( my $code = $sym->{$pwd} ) {
 165                         # Delegate back to parent dirs
 166                         goto &$code unless $cwd eq $pwd;
 167                 }
 168                 unless ($$sym =~ s/([^:]+)$//) {
 169                         # XXX: it looks like we can't retrieve the missing function
 170                         # via $$sym (usually $main::AUTOLOAD) in this case.
 171                         # I'm still wondering if we should slurp Makefile.PL to
 172                         # get some context or not ...
 173                         my ($package, $file, $line) = caller;
 174                         die <<"EOT";
 175 Unknown function is found at $file line $line.
 176 Execution of $file aborted due to runtime errors.
 177
 178 If you're a contributor to a project, you may need to install
 179 some Module::Install extensions from CPAN (or other repository).
 180 If you're a user of a module, please contact the author.
 181 EOT
 182                 }
 183                 my $method = $1;
 184                 if ( uc($method) eq $method ) {
 185                         # Do nothing
 186                         return;
 187                 } elsif ( $method =~ /^_/ and $self->can($method) ) {
 188                         # Dispatch to the root M:I class
 189                         return $self->$method(@_);
 190                 }
 191
 192                 # Dispatch to the appropriate plugin
 193                 unshift @_, ( $self, $1 );
 194                 goto &{$self->can('call')};
 195         };
 196 }
 197
 198 sub preload {
 199         my $self = shift;
 200         unless ( $self->{extensions} ) {
 201                 $self->load_extensions(
 202                         "$self->{prefix}/$self->{path}", $self
 203                 );
 204         }
 205
 206         my @exts = @{$self->{extensions}};
 207         unless ( @exts ) {
 208                 @exts = $self->{admin}->load_all_extensions;
 209         }
 210
 211         my %seen;
 212         foreach my $obj ( @exts ) {
 213                 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 214                         next unless $obj->can($method);
 215                         next if $method =~ /^_/;
 216                         next if $method eq uc($method);
 217                         $seen{$method}++;
 218                 }
 219         }
 220
 221         my $who = $self->_caller;
 222         foreach my $name ( sort keys %seen ) {
 223                 local $^W;
 224                 *{"${who}::$name"} = sub {
 225                         ${"${who}::AUTOLOAD"} = "${who}::$name";
 226                         goto &{"${who}::AUTOLOAD"};
 227                 };
 228         }
 229 }
 230
 231 sub new {
 232         my ($class, %args) = @_;
 233
 234         FindBin->again;
 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
 261 sub 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
 268 sub 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";
 280 The '$method' method does not exist in the '$self->{prefix}' path!
 281 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 282 END_DIE
 283
 284         my $obj = $admin->load($method, 1);
 285         push @{$self->{extensions}}, $obj;
 286
 287         $obj;
 288 }
 289
 290 sub 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
 317 sub 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
 362 sub _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
 373 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 374 sub _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 }
 381 END_NEW
 382 sub _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 }
 389 END_OLD
 390
 391 sub _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
 399 sub _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
 411 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 412 sub _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 }
 420 END_NEW
 421 sub _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 }
 429 END_OLD
 430
 431 # _version is for processing module versions (eg, 1.03_05) not
 432 # Perl versions (eg, 5.8.1).
 433 sub _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
 449 sub _cmp ($$) {
 450         _version($_[0]) <=> _version($_[1]);
 451 }
 452
 453 # Cloned from Params::Util::_CLASS
 454 sub _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
 464 1;
 465
 466 # Copyright 2008 - 2010 Adam Kennedy.