local-lib5/lib/perl5/Module/Install.pm

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