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.95';
  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                 require "$self->{path}/$self->{dispatch}.pm";
 131                 File::Path::mkpath("$self->{prefix}/$self->{author}");
 132                 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 133                 $self->{admin}->init;
 134                 @_ = ($class, _self => $self);
 135                 goto &{"$self->{name}::import"};
 136         }
 137
 138         *{"${who}::AUTOLOAD"} = $self->autoload;
 139         $self->preload;
 140
 141         # Unregister loader and worker packages so subdirs can use them again
 142         delete $INC{"$self->{file}"};
 143         delete $INC{"$self->{path}.pm"};
 144
 145         # Save to the singleton
 146         $MAIN = $self;
 147
 148         return 1;
 149 }
 150
 151 sub autoload {
 152         my $self = shift;
 153         my $who  = $self->_caller;
 154         my $cwd  = Cwd::cwd();
 155         my $sym  = "${who}::AUTOLOAD";
 156         $sym->{$cwd} = sub {
 157                 my $pwd = Cwd::cwd();
 158                 if ( my $code = $sym->{$pwd} ) {
 159                         # Delegate back to parent dirs
 160                         goto &$code unless $cwd eq $pwd;
 161                 }
 162                 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
 163                 my $method = $1;
 164                 if ( uc($method) eq $method ) {
 165                         # Do nothing
 166                         return;
 167                 } elsif ( $method =~ /^_/ and $self->can($method) ) {
 168                         # Dispatch to the root M:I class
 169                         return $self->$method(@_);
 170                 }
 171
 172                 # Dispatch to the appropriate plugin
 173                 unshift @_, ( $self, $1 );
 174                 goto &{$self->can('call')};
 175         };
 176 }
 177
 178 sub preload {
 179         my $self = shift;
 180         unless ( $self->{extensions} ) {
 181                 $self->load_extensions(
 182                         "$self->{prefix}/$self->{path}", $self
 183                 );
 184         }
 185
 186         my @exts = @{$self->{extensions}};
 187         unless ( @exts ) {
 188                 @exts = $self->{admin}->load_all_extensions;
 189         }
 190
 191         my %seen;
 192         foreach my $obj ( @exts ) {
 193                 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 194                         next unless $obj->can($method);
 195                         next if $method =~ /^_/;
 196                         next if $method eq uc($method);
 197                         $seen{$method}++;
 198                 }
 199         }
 200
 201         my $who = $self->_caller;
 202         foreach my $name ( sort keys %seen ) {
 203                 *{"${who}::$name"} = sub {
 204                         ${"${who}::AUTOLOAD"} = "${who}::$name";
 205                         goto &{"${who}::AUTOLOAD"};
 206                 };
 207         }
 208 }
 209
 210 sub new {
 211         my ($class, %args) = @_;
 212
 213         # ignore the prefix on extension modules built from top level.
 214         my $base_path = Cwd::abs_path($FindBin::Bin);
 215         unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
 216                 delete $args{prefix};
 217         }
 218
 219         return $args{_self} if $args{_self};
 220
 221         $args{dispatch} ||= 'Admin';
 222         $args{prefix}   ||= 'inc';
 223         $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
 224         $args{bundle}   ||= 'inc/BUNDLES';
 225         $args{base}     ||= $base_path;
 226         $class =~ s/^\Q$args{prefix}\E:://;
 227         $args{name}     ||= $class;
 228         $args{version}  ||= $class->VERSION;
 229         unless ( $args{path} ) {
 230                 $args{path}  = $args{name};
 231                 $args{path}  =~ s!::!/!g;
 232         }
 233         $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 234         $args{wrote}      = 0;
 235
 236         bless( \%args, $class );
 237 }
 238
 239 sub call {
 240         my ($self, $method) = @_;
 241         my $obj = $self->load($method) or return;
 242         splice(@_, 0, 2, $obj);
 243         goto &{$obj->can($method)};
 244 }
 245
 246 sub load {
 247         my ($self, $method) = @_;
 248
 249         $self->load_extensions(
 250                 "$self->{prefix}/$self->{path}", $self
 251         ) unless $self->{extensions};
 252
 253         foreach my $obj (@{$self->{extensions}}) {
 254                 return $obj if $obj->can($method);
 255         }
 256
 257         my $admin = $self->{admin} or die <<"END_DIE";
 258 The '$method' method does not exist in the '$self->{prefix}' path!
 259 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 260 END_DIE
 261
 262         my $obj = $admin->load($method, 1);
 263         push @{$self->{extensions}}, $obj;
 264
 265         $obj;
 266 }
 267
 268 sub load_extensions {
 269         my ($self, $path, $top) = @_;
 270
 271         unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
 272                 unshift @INC, $self->{prefix};
 273         }
 274
 275         foreach my $rv ( $self->find_extensions($path) ) {
 276                 my ($file, $pkg) = @{$rv};
 277                 next if $self->{pathnames}{$pkg};
 278
 279                 local $@;
 280                 my $new = eval { require $file; $pkg->can('new') };
 281                 unless ( $new ) {
 282                         warn $@ if $@;
 283                         next;
 284                 }
 285                 $self->{pathnames}{$pkg} = delete $INC{$file};
 286                 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
 287         }
 288
 289         $self->{extensions} ||= [];
 290 }
 291
 292 sub find_extensions {
 293         my ($self, $path) = @_;
 294
 295         my @found;
 296         File::Find::find( sub {
 297                 my $file = $File::Find::name;
 298                 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 299                 my $subpath = $1;
 300                 return if lc($subpath) eq lc($self->{dispatch});
 301
 302                 $file = "$self->{path}/$subpath.pm";
 303                 my $pkg = "$self->{name}::$subpath";
 304                 $pkg =~ s!/!::!g;
 305
 306                 # If we have a mixed-case package name, assume case has been preserved
 307                 # correctly.  Otherwise, root through the file to locate the case-preserved
 308                 # version of the package name.
 309                 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
 310                         my $content = Module::Install::_read($subpath . '.pm');
 311                         my $in_pod  = 0;
 312                         foreach ( split //, $content ) {
 313                                 $in_pod = 1 if /^=\w/;
 314                                 $in_pod = 0 if /^=cut/;
 315                                 next if ($in_pod || /^=cut/);  # skip pod text
 316                                 next if /^\s*#/;               # and comments
 317                                 if ( m/^\s*package\s+($pkg)\s*;/i ) {
 318                                         $pkg = $1;
 319                                         last;
 320                                 }
 321                         }
 322                 }
 323
 324                 push @found, [ $file, $pkg ];
 325         }, $path ) if -d $path;
 326
 327         @found;
 328 }
 329
 330
 331
 332
 333
 334 #####################################################################
 335 # Common Utility Functions
 336
 337 sub _caller {
 338         my $depth = 0;
 339         my $call  = caller($depth);
 340         while ( $call eq __PACKAGE__ ) {
 341                 $depth++;
 342                 $call = caller($depth);
 343         }
 344         return $call;
 345 }
 346
 347 # Done in evals to avoid confusing Perl::MinimumVersion
 348 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 349 sub _read {
 350         local *FH;
 351         open( FH, '<', $_[0] ) or die "open($_[0]): $!";
 352         my $string = do { local $/; <FH> };
 353         close FH or die "close($_[0]): $!";
 354         return $string;
 355 }
 356 END_NEW
 357 sub _read {
 358         local *FH;
 359         open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
 360         my $string = do { local $/; <FH> };
 361         close FH or die "close($_[0]): $!";
 362         return $string;
 363 }
 364 END_OLD
 365
 366 sub _readperl {
 367         my $string = Module::Install::_read($_[0]);
 368         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 369         $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
 370         $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
 371         return $string;
 372 }
 373
 374 sub _readpod {
 375         my $string = Module::Install::_read($_[0]);
 376         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 377         return $string if $_[0] =~ /\.pod\z/;
 378         $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
 379         $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
 380         $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
 381         $string =~ s/^\n+//s;
 382         return $string;
 383 }
 384
 385 # Done in evals to avoid confusing Perl::MinimumVersion
 386 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 387 sub _write {
 388         local *FH;
 389         open( FH, '>', $_[0] ) or die "open($_[0]): $!";
 390         foreach ( 1 .. $#_ ) {
 391                 print FH $_[$_] or die "print($_[0]): $!";
 392         }
 393         close FH or die "close($_[0]): $!";
 394 }
 395 END_NEW
 396 sub _write {
 397         local *FH;
 398         open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
 399         foreach ( 1 .. $#_ ) {
 400                 print FH $_[$_] or die "print($_[0]): $!";
 401         }
 402         close FH or die "close($_[0]): $!";
 403 }
 404 END_OLD
 405
 406 # _version is for processing module versions (eg, 1.03_05) not
 407 # Perl versions (eg, 5.8.1).
 408 sub _version ($) {
 409         my $s = shift || 0;
 410         my $d =()= $s =~ /(\.)/g;
 411         if ( $d >= 2 ) {
 412                 # Normalise multipart versions
 413                 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
 414         }
 415         $s =~ s/^(\d+)\.?//;
 416         my $l = $1 || 0;
 417         my @v = map {
 418                 $_ . '0' x (3 - length $_)
 419         } $s =~ /(\d{1,3})\D?/g;
 420         $l = $l . '.' . join '', @v if @v;
 421         return $l + 0;
 422 }
 423
 424 sub _cmp ($$) {
 425         _version($_[0]) <=> _version($_[1]);
 426 }
 427
 428 # Cloned from Params::Util::_CLASS
 429 sub _CLASS ($) {
 430         (
 431                 defined $_[0]
 432                 and
 433                 ! ref $_[0]
 434                 and
 435                 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
 436         ) ? $_[0] : undef;
 437 }
 438
 439 1;
 440
 441 # Copyright 2008 - 2010 Adam Kennedy.