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
  23 use vars qw{$VERSION $MAIN};
  24 BEGIN {
  25         # All Module::Install core packages now require synchronised versions.
  26         # This will be used to ensure we don't accidentally load old or
  27         # different versions of modules.
  28         # This is not enforced yet, but will be some time in the next few
  29         # releases once we can make sure it won't clash with custom
  30         # Module::Install extensions.
  31         $VERSION = '0.91';
  32
  33         # Storage for the pseudo-singleton
  34         $MAIN    = undef;
  35
  36         *inc::Module::Install::VERSION = *VERSION;
  37         @inc::Module::Install::ISA     = __PACKAGE__;
  38
  39 }
  40
  41
  42
  43
  44
  45 # Whether or not inc::Module::Install is actually loaded, the
  46 # $INC{inc/Module/Install.pm} is what will still get set as long as
  47 # the caller loaded module this in the documented manner.
  48 # If not set, the caller may NOT have loaded the bundled version, and thus
  49 # they may not have a MI version that works with the Makefile.PL. This would
  50 # result in false errors or unexpected behaviour. And we don't want that.
  51 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
  52 unless ( $INC{$file} ) { die <<"END_DIE" }
  53
  54 Please invoke ${\__PACKAGE__} with:
  55
  56         use inc::${\__PACKAGE__};
  57
  58 not:
  59
  60         use ${\__PACKAGE__};
  61
  62 END_DIE
  63
  64
  65
  66
  67
  68 # If the script that is loading Module::Install is from the future,
  69 # then make will detect this and cause it to re-run over and over
  70 # again. This is bad. Rather than taking action to touch it (which
  71 # is unreliable on some platforms and requires write permissions)
  72 # for now we should catch this and refuse to run.
  73 if ( -f $0 ) {
  74         my $s = (stat($0))[9];
  75
  76         # If the modification time is only slightly in the future,
  77         # sleep briefly to remove the problem.
  78         my $a = $s - time;
  79         if ( $a > 0 and $a < 5 ) { sleep 5 }
  80
  81         # Too far in the future, throw an error.
  82         my $t = time;
  83         if ( $s > $t ) { die <<"END_DIE" }
  84
  85 Your installer $0 has a modification time in the future ($s > $t).
  86
  87 This is known to create infinite loops in make.
  88
  89 Please correct this, then run $0 again.
  90
  91 END_DIE
  92 }
  93
  94
  95
  96
  97
  98 # Build.PL was formerly supported, but no longer is due to excessive
  99 # difficulty in implementing every single feature twice.
 100 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
 101
 102 Module::Install no longer supports Build.PL.
 103
 104 It was impossible to maintain duel backends, and has been deprecated.
 105
 106 Please remove all Build.PL files and only use the Makefile.PL installer.
 107
 108 END_DIE
 109
 110
 111
 112
 113
 114 # To save some more typing in Module::Install installers, every...
 115 # use inc::Module::Install
 116 # ...also acts as an implicit use strict.
 117 $^H |= strict::bits(qw(refs subs vars));
 118
 119
 120
 121
 122
 123 use Cwd        ();
 124 use File::Find ();
 125 use File::Path ();
 126 use FindBin;
 127
 128 sub autoload {
 129         my $self = shift;
 130         my $who  = $self->_caller;
 131         my $cwd  = Cwd::cwd();
 132         my $sym  = "${who}::AUTOLOAD";
 133         $sym->{$cwd} = sub {
 134                 my $pwd = Cwd::cwd();
 135                 if ( my $code = $sym->{$pwd} ) {
 136                         # Delegate back to parent dirs
 137                         goto &$code unless $cwd eq $pwd;
 138                 }
 139                 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
 140                 my $method = $1;
 141                 if ( uc($method) eq $method ) {
 142                         # Do nothing
 143                         return;
 144                 } elsif ( $method =~ /^_/ and $self->can($method) ) {
 145                         # Dispatch to the root M:I class
 146                         return $self->$method(@_);
 147                 }
 148
 149                 # Dispatch to the appropriate plugin
 150                 unshift @_, ( $self, $1 );
 151                 goto &{$self->can('call')};
 152         };
 153 }
 154
 155 sub import {
 156         my $class = shift;
 157         my $self  = $class->new(@_);
 158         my $who   = $self->_caller;
 159
 160         unless ( -f $self->{file} ) {
 161                 require "$self->{path}/$self->{dispatch}.pm";
 162                 File::Path::mkpath("$self->{prefix}/$self->{author}");
 163                 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 164                 $self->{admin}->init;
 165                 @_ = ($class, _self => $self);
 166                 goto &{"$self->{name}::import"};
 167         }
 168
 169         *{"${who}::AUTOLOAD"} = $self->autoload;
 170         $self->preload;
 171
 172         # Unregister loader and worker packages so subdirs can use them again
 173         delete $INC{"$self->{file}"};
 174         delete $INC{"$self->{path}.pm"};
 175
 176         # Save to the singleton
 177         $MAIN = $self;
 178
 179         return 1;
 180 }
 181
 182 sub preload {
 183         my $self = shift;
 184         unless ( $self->{extensions} ) {
 185                 $self->load_extensions(
 186                         "$self->{prefix}/$self->{path}", $self
 187                 );
 188         }
 189
 190         my @exts = @{$self->{extensions}};
 191         unless ( @exts ) {
 192                 @exts = $self->{admin}->load_all_extensions;
 193         }
 194
 195         my %seen;
 196         foreach my $obj ( @exts ) {
 197                 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 198                         next unless $obj->can($method);
 199                         next if $method =~ /^_/;
 200                         next if $method eq uc($method);
 201                         $seen{$method}++;
 202                 }
 203         }
 204
 205         my $who = $self->_caller;
 206         foreach my $name ( sort keys %seen ) {
 207                 *{"${who}::$name"} = sub {
 208                         ${"${who}::AUTOLOAD"} = "${who}::$name";
 209                         goto &{"${who}::AUTOLOAD"};
 210                 };
 211         }
 212 }
 213
 214 sub new {
 215         my ($class, %args) = @_;
 216
 217         # ignore the prefix on extension modules built from top level.
 218         my $base_path = Cwd::abs_path($FindBin::Bin);
 219         unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
 220                 delete $args{prefix};
 221         }
 222
 223         return $args{_self} if $args{_self};
 224
 225         $args{dispatch} ||= 'Admin';
 226         $args{prefix}   ||= 'inc';
 227         $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
 228         $args{bundle}   ||= 'inc/BUNDLES';
 229         $args{base}     ||= $base_path;
 230         $class =~ s/^\Q$args{prefix}\E:://;
 231         $args{name}     ||= $class;
 232         $args{version}  ||= $class->VERSION;
 233         unless ( $args{path} ) {
 234                 $args{path}  = $args{name};
 235                 $args{path}  =~ s!::!/!g;
 236         }
 237         $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 238         $args{wrote}      = 0;
 239
 240         bless( \%args, $class );
 241 }
 242
 243 sub call {
 244         my ($self, $method) = @_;
 245         my $obj = $self->load($method) or return;
 246         splice(@_, 0, 2, $obj);
 247         goto &{$obj->can($method)};
 248 }
 249
 250 sub load {
 251         my ($self, $method) = @_;
 252
 253         $self->load_extensions(
 254                 "$self->{prefix}/$self->{path}", $self
 255         ) unless $self->{extensions};
 256
 257         foreach my $obj (@{$self->{extensions}}) {
 258                 return $obj if $obj->can($method);
 259         }
 260
 261         my $admin = $self->{admin} or die <<"END_DIE";
 262 The '$method' method does not exist in the '$self->{prefix}' path!
 263 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 264 END_DIE
 265
 266         my $obj = $admin->load($method, 1);
 267         push @{$self->{extensions}}, $obj;
 268
 269         $obj;
 270 }
 271
 272 sub load_extensions {
 273         my ($self, $path, $top) = @_;
 274
 275         unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
 276                 unshift @INC, $self->{prefix};
 277         }
 278
 279         foreach my $rv ( $self->find_extensions($path) ) {
 280                 my ($file, $pkg) = @{$rv};
 281                 next if $self->{pathnames}{$pkg};
 282
 283                 local $@;
 284                 my $new = eval { require $file; $pkg->can('new') };
 285                 unless ( $new ) {
 286                         warn $@ if $@;
 287                         next;
 288                 }
 289                 $self->{pathnames}{$pkg} = delete $INC{$file};
 290                 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
 291         }
 292
 293         $self->{extensions} ||= [];
 294 }
 295
 296 sub find_extensions {
 297         my ($self, $path) = @_;
 298
 299         my @found;
 300         File::Find::find( sub {
 301                 my $file = $File::Find::name;
 302                 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 303                 my $subpath = $1;
 304                 return if lc($subpath) eq lc($self->{dispatch});
 305
 306                 $file = "$self->{path}/$subpath.pm";
 307                 my $pkg = "$self->{name}::$subpath";
 308                 $pkg =~ s!/!::!g;
 309
 310                 # If we have a mixed-case package name, assume case has been preserved
 311                 # correctly.  Otherwise, root through the file to locate the case-preserved
 312                 # version of the package name.
 313                 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
 314                         my $content = Module::Install::_read($subpath . '.pm');
 315                         my $in_pod  = 0;
 316                         foreach ( split //, $content ) {
 317                                 $in_pod = 1 if /^=\w/;
 318                                 $in_pod = 0 if /^=cut/;
 319                                 next if ($in_pod || /^=cut/);  # skip pod text
 320                                 next if /^\s*#/;               # and comments
 321                                 if ( m/^\s*package\s+($pkg)\s*;/i ) {
 322                                         $pkg = $1;
 323                                         last;
 324                                 }
 325                         }
 326                 }
 327
 328                 push @found, [ $file, $pkg ];
 329         }, $path ) if -d $path;
 330
 331         @found;
 332 }
 333
 334
 335
 336
 337
 338 #####################################################################
 339 # Common Utility Functions
 340
 341 sub _caller {
 342         my $depth = 0;
 343         my $call  = caller($depth);
 344         while ( $call eq __PACKAGE__ ) {
 345                 $depth++;
 346                 $call = caller($depth);
 347         }
 348         return $call;
 349 }
 350
 351 sub _read {
 352         local *FH;
 353         if ( $] >= 5.006 ) {
 354                 open( FH, '<', $_[0] ) or die "open($_[0]): $!";
 355         } else {
 356                 open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
 357         }
 358         my $string = do { local $/; <FH> };
 359         close FH or die "close($_[0]): $!";
 360         return $string;
 361 }
 362
 363 sub _readperl {
 364         my $string = Module::Install::_read($_[0]);
 365         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 366         $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
 367         $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
 368         return $string;
 369 }
 370
 371 sub _readpod {
 372         my $string = Module::Install::_read($_[0]);
 373         $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
 374         return $string if $_[0] =~ /\.pod\z/;
 375         $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
 376         $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
 377         $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
 378         $string =~ s/^\n+//s;
 379         return $string;
 380 }
 381
 382 sub _write {
 383         local *FH;
 384         if ( $] >= 5.006 ) {
 385                 open( FH, '>', $_[0] ) or die "open($_[0]): $!";
 386         } else {
 387                 open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
 388         }
 389         foreach ( 1 .. $#_ ) {
 390                 print FH $_[$_] or die "print($_[0]): $!";
 391         }
 392         close FH or die "close($_[0]): $!";
 393 }
 394
 395 # _version is for processing module versions (eg, 1.03_05) not
 396 # Perl versions (eg, 5.8.1).
 397 sub _version ($) {
 398         my $s = shift || 0;
 399         my $d =()= $s =~ /(\.)/g;
 400         if ( $d >= 2 ) {
 401                 # Normalise multipart versions
 402                 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
 403         }
 404         $s =~ s/^(\d+)\.?//;
 405         my $l = $1 || 0;
 406         my @v = map {
 407                 $_ . '0' x (3 - length $_)
 408         } $s =~ /(\d{1,3})\D?/g;
 409         $l = $l . '.' . join '', @v if @v;
 410         return $l + 0;
 411 }
 412
 413 sub _cmp ($$) {
 414         _version($_[0]) <=> _version($_[1]);
 415 }
 416
 417 # Cloned from Params::Util::_CLASS
 418 sub _CLASS ($) {
 419         (
 420                 defined $_[0]
 421                 and
 422                 ! ref $_[0]
 423                 and
 424                 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
 425         ) ? $_[0] : undef;
 426 }
 427
 428 1;
 429
 430 # Copyright 2008 - 2009 Adam Kennedy.