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.18';
  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         $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
 267 sub 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
 274 sub 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";
 286 The '$method' method does not exist in the '$self->{prefix}' path!
 287 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 288 END_DIE
 289
 290         my $obj = $admin->load($method, 1);
 291         push @{$self->{extensions}}, $obj;
 292
 293         $obj;
 294 }
 295
 296 sub 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
 323 sub 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
 368 sub _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
 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
 387 sub _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
 395 sub _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
 406 sub _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).
 418 sub _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
 434 sub _cmp {
 435         _version($_[1]) <=> _version($_[2]);
 436 }
 437
 438 # Cloned from Params::Util::_CLASS
 439 sub _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
 449 1;
 450
 451 # Copyright 2008 - 2012 Adam Kennedy.