src/perl/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 BEGIN {
  21         require 5.004;
  22 }
  23 use strict 'vars';
  24
  25 use vars qw{$VERSION};
  26 BEGIN {
  27         # All Module::Install core packages now require synchronised versions.
  28         # This will be used to ensure we don't accidentally load old or
  29         # different versions of modules.
  30         # This is not enforced yet, but will be some time in the next few
  31         # releases once we can make sure it won't clash with custom
  32         # Module::Install extensions.
  33         $VERSION = '0.76';
  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 and (stat($0))[9] > time ) { die <<"END_DIE" }
  73
  74 Your installer $0 has a modification time in the future.
  75
  76 This is known to create infinite loops in make.
  77
  78 Please correct this, then run $0 again.
  79
  80 END_DIE
  81
  82
  83
  84
  85
  86 # Build.PL was formerly supported, but no longer is due to excessive
  87 # difficulty in implementing every single feature twice.
  88 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
  89
  90 Module::Install no longer supports Build.PL.
  91
  92 It was impossible to maintain duel backends, and has been deprecated.
  93
  94 Please remove all Build.PL files and only use the Makefile.PL installer.
  95
  96 END_DIE
  97
  98
  99
 100
 101
 102 # To save some more typing in Module::Install installers, every...
 103 # use inc::Module::Install
 104 # ...also acts as an implicit use strict.
 105 $^H |= strict::bits(qw(refs subs vars));
 106
 107
 108
 109
 110
 111 use Cwd        ();
 112 use File::Find ();
 113 use File::Path ();
 114 use FindBin;
 115
 116 sub autoload {
 117         my $self = shift;
 118         my $who  = $self->_caller;
 119         my $cwd  = Cwd::cwd();
 120         my $sym  = "${who}::AUTOLOAD";
 121         $sym->{$cwd} = sub {
 122                 my $pwd = Cwd::cwd();
 123                 if ( my $code = $sym->{$pwd} ) {
 124                         # delegate back to parent dirs
 125                         goto &$code unless $cwd eq $pwd;
 126                 }
 127                 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
 128                 unshift @_, ( $self, $1 );
 129                 goto &{$self->can('call')} unless uc($1) eq $1;
 130         };
 131 }
 132
 133 sub import {
 134         my $class = shift;
 135         my $self  = $class->new(@_);
 136         my $who   = $self->_caller;
 137
 138         unless ( -f $self->{file} ) {
 139                 require "$self->{path}/$self->{dispatch}.pm";
 140                 File::Path::mkpath("$self->{prefix}/$self->{author}");
 141                 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 142                 $self->{admin}->init;
 143                 @_ = ($class, _self => $self);
 144                 goto &{"$self->{name}::import"};
 145         }
 146
 147         *{"${who}::AUTOLOAD"} = $self->autoload;
 148         $self->preload;
 149
 150         # Unregister loader and worker packages so subdirs can use them again
 151         delete $INC{"$self->{file}"};
 152         delete $INC{"$self->{path}.pm"};
 153
 154         return 1;
 155 }
 156
 157 sub preload {
 158         my $self = shift;
 159         unless ( $self->{extensions} ) {
 160                 $self->load_extensions(
 161                         "$self->{prefix}/$self->{path}", $self
 162                 );
 163         }
 164
 165         my @exts = @{$self->{extensions}};
 166         unless ( @exts ) {
 167                 my $admin = $self->{admin};
 168                 @exts = $admin->load_all_extensions;
 169         }
 170
 171         my %seen;
 172         foreach my $obj ( @exts ) {
 173                 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 174                         next unless $obj->can($method);
 175                         next if $method =~ /^_/;
 176                         next if $method eq uc($method);
 177                         $seen{$method}++;
 178                 }
 179         }
 180
 181         my $who = $self->_caller;
 182         foreach my $name ( sort keys %seen ) {
 183                 *{"${who}::$name"} = sub {
 184                         ${"${who}::AUTOLOAD"} = "${who}::$name";
 185                         goto &{"${who}::AUTOLOAD"};
 186                 };
 187         }
 188 }
 189
 190 sub new {
 191         my ($class, %args) = @_;
 192
 193         # ignore the prefix on extension modules built from top level.
 194         my $base_path = Cwd::abs_path($FindBin::Bin);
 195         unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
 196                 delete $args{prefix};
 197         }
 198
 199         return $args{_self} if $args{_self};
 200
 201         $args{dispatch} ||= 'Admin';
 202         $args{prefix}   ||= 'inc';
 203         $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
 204         $args{bundle}   ||= 'inc/BUNDLES';
 205         $args{base}     ||= $base_path;
 206         $class =~ s/^\Q$args{prefix}\E:://;
 207         $args{name}     ||= $class;
 208         $args{version}  ||= $class->VERSION;
 209         unless ( $args{path} ) {
 210                 $args{path}  = $args{name};
 211                 $args{path}  =~ s!::!/!g;
 212         }
 213         $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 214         $args{wrote}      = 0;
 215
 216         bless( \%args, $class );
 217 }
 218
 219 sub call {
 220         my ($self, $method) = @_;
 221         my $obj = $self->load($method) or return;
 222         splice(@_, 0, 2, $obj);
 223         goto &{$obj->can($method)};
 224 }
 225
 226 sub load {
 227         my ($self, $method) = @_;
 228
 229         $self->load_extensions(
 230                 "$self->{prefix}/$self->{path}", $self
 231         ) unless $self->{extensions};
 232
 233         foreach my $obj (@{$self->{extensions}}) {
 234                 return $obj if $obj->can($method);
 235         }
 236
 237         my $admin = $self->{admin} or die <<"END_DIE";
 238 The '$method' method does not exist in the '$self->{prefix}' path!
 239 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 240 END_DIE
 241
 242         my $obj = $admin->load($method, 1);
 243         push @{$self->{extensions}}, $obj;
 244
 245         $obj;
 246 }
 247
 248 sub load_extensions {
 249         my ($self, $path, $top) = @_;
 250
 251         unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
 252                 unshift @INC, $self->{prefix};
 253         }
 254
 255         foreach my $rv ( $self->find_extensions($path) ) {
 256                 my ($file, $pkg) = @{$rv};
 257                 next if $self->{pathnames}{$pkg};
 258
 259                 local $@;
 260                 my $new = eval { require $file; $pkg->can('new') };
 261                 unless ( $new ) {
 262                         warn $@ if $@;
 263                         next;
 264                 }
 265                 $self->{pathnames}{$pkg} = delete $INC{$file};
 266                 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
 267         }
 268
 269         $self->{extensions} ||= [];
 270 }
 271
 272 sub find_extensions {
 273         my ($self, $path) = @_;
 274
 275         my @found;
 276         File::Find::find( sub {
 277                 my $file = $File::Find::name;
 278                 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 279                 my $subpath = $1;
 280                 return if lc($subpath) eq lc($self->{dispatch});
 281
 282                 $file = "$self->{path}/$subpath.pm";
 283                 my $pkg = "$self->{name}::$subpath";
 284                 $pkg =~ s!/!::!g;
 285
 286                 # If we have a mixed-case package name, assume case has been preserved
 287                 # correctly.  Otherwise, root through the file to locate the case-preserved
 288                 # version of the package name.
 289                 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
 290                         my $content = Module::Install::_read($subpath . '.pm');
 291                         my $in_pod  = 0;
 292                         foreach ( split //, $content ) {
 293                                 $in_pod = 1 if /^=\w/;
 294                                 $in_pod = 0 if /^=cut/;
 295                                 next if ($in_pod || /^=cut/);  # skip pod text
 296                                 next if /^\s*#/;               # and comments
 297                                 if ( m/^\s*package\s+($pkg)\s*;/i ) {
 298                                         $pkg = $1;
 299                                         last;
 300                                 }
 301                         }
 302                 }
 303
 304                 push @found, [ $file, $pkg ];
 305         }, $path ) if -d $path;
 306
 307         @found;
 308 }
 309
 310
 311
 312
 313
 314 #####################################################################
 315 # Utility Functions
 316
 317 sub _caller {
 318         my $depth = 0;
 319         my $call  = caller($depth);
 320         while ( $call eq __PACKAGE__ ) {
 321                 $depth++;
 322                 $call = caller($depth);
 323         }
 324         return $call;
 325 }
 326
 327 sub _read {
 328         local *FH;
 329         open FH, "< $_[0]" or die "open($_[0]): $!";
 330         my $str = do { local $/; <FH> };
 331         close FH or die "close($_[0]): $!";
 332         return $str;
 333 }
 334
 335 sub _write {
 336         local *FH;
 337         open FH, "> $_[0]" or die "open($_[0]): $!";
 338         foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
 339         close FH or die "close($_[0]): $!";
 340 }
 341
 342 sub _version ($) {
 343         my $s = shift || 0;
 344            $s =~ s/^(\d+)\.?//;
 345         my $l = $1 || 0;
 346         my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
 347            $l = $l . '.' . join '', @v if @v;
 348         return $l + 0;
 349 }
 350
 351 # Cloned from Params::Util::_CLASS
 352 sub _CLASS ($) {
 353         (
 354                 defined $_[0]
 355                 and
 356                 ! ref $_[0]
 357                 and
 358                 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
 359         ) ? $_[0] : undef;
 360 }
 361
 362 1;
 363
 364 # Copyright 2008 Adam Kennedy.