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.004;
  21 use strict 'vars';
  22
  23 use vars qw{$VERSION};
  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.67';
  32 }
  33
  34 # Whether or not inc::Module::Install is actually loaded, the
  35 # $INC{inc/Module/Install.pm} is what will still get set as long as
  36 # the caller loaded module this in the documented manner.
  37 # If not set, the caller may NOT have loaded the bundled version, and thus
  38 # they may not have a MI version that works with the Makefile.PL. This would
  39 # result in false errors or unexpected behaviour. And we don't want that.
  40 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
  41 unless ( $INC{$file} ) {
  42     die <<"END_DIE";
  43 Please invoke ${\__PACKAGE__} with:
  44
  45     use inc::${\__PACKAGE__};
  46
  47 not:
  48
  49     use ${\__PACKAGE__};
  50
  51 END_DIE
  52 }
  53
  54 # If the script that is loading Module::Install is from the future,
  55 # then make will detect this and cause it to re-run over and over
  56 # again. This is bad. Rather than taking action to touch it (which
  57 # is unreliable on some platforms and requires write permissions)
  58 # for now we should catch this and refuse to run.
  59 if ( -f $0 and (stat($0))[9] > time ) {
  60         die << "END_DIE";
  61 Your installer $0 has a modification time in the future.
  62
  63 This is known to create infinite loops in make.
  64
  65 Please correct this, then run $0 again.
  66
  67 END_DIE
  68 }
  69
  70 use Cwd        ();
  71 use File::Find ();
  72 use File::Path ();
  73 use FindBin;
  74
  75 *inc::Module::Install::VERSION = *VERSION;
  76 @inc::Module::Install::ISA     = __PACKAGE__;
  77
  78 sub autoload {
  79     my $self = shift;
  80     my $who  = $self->_caller;
  81     my $cwd  = Cwd::cwd();
  82     my $sym  = "${who}::AUTOLOAD";
  83     $sym->{$cwd} = sub {
  84         my $pwd = Cwd::cwd();
  85         if ( my $code = $sym->{$pwd} ) {
  86             # delegate back to parent dirs
  87             goto &$code unless $cwd eq $pwd;
  88         }
  89         $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
  90         unshift @_, ($self, $1);
  91         goto &{$self->can('call')} unless uc($1) eq $1;
  92     };
  93 }
  94
  95 sub import {
  96     my $class = shift;
  97     my $self  = $class->new(@_);
  98     my $who   = $self->_caller;
  99
 100     unless ( -f $self->{file} ) {
 101         require "$self->{path}/$self->{dispatch}.pm";
 102         File::Path::mkpath("$self->{prefix}/$self->{author}");
 103         $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 104         $self->{admin}->init;
 105         @_ = ($class, _self => $self);
 106         goto &{"$self->{name}::import"};
 107     }
 108
 109     *{"${who}::AUTOLOAD"} = $self->autoload;
 110     $self->preload;
 111
 112     # Unregister loader and worker packages so subdirs can use them again
 113     delete $INC{"$self->{file}"};
 114     delete $INC{"$self->{path}.pm"};
 115 }
 116
 117 sub preload {
 118     my ($self) = @_;
 119
 120     unless ( $self->{extensions} ) {
 121         $self->load_extensions(
 122             "$self->{prefix}/$self->{path}", $self
 123         );
 124     }
 125
 126     my @exts = @{$self->{extensions}};
 127     unless ( @exts ) {
 128         my $admin = $self->{admin};
 129         @exts = $admin->load_all_extensions;
 130     }
 131
 132     my %seen;
 133     foreach my $obj ( @exts ) {
 134         while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 135             next unless $obj->can($method);
 136             next if $method =~ /^_/;
 137             next if $method eq uc($method);
 138             $seen{$method}++;
 139         }
 140     }
 141
 142     my $who = $self->_caller;
 143     foreach my $name ( sort keys %seen ) {
 144         *{"${who}::$name"} = sub {
 145             ${"${who}::AUTOLOAD"} = "${who}::$name";
 146             goto &{"${who}::AUTOLOAD"};
 147         };
 148     }
 149 }
 150
 151 sub new {
 152     my ($class, %args) = @_;
 153
 154     # ignore the prefix on extension modules built from top level.
 155     my $base_path = Cwd::abs_path($FindBin::Bin);
 156     unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
 157         delete $args{prefix};
 158     }
 159
 160     return $args{_self} if $args{_self};
 161
 162     $args{dispatch} ||= 'Admin';
 163     $args{prefix}   ||= 'inc';
 164     $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
 165     $args{bundle}   ||= 'inc/BUNDLES';
 166     $args{base}     ||= $base_path;
 167     $class =~ s/^\Q$args{prefix}\E:://;
 168     $args{name}     ||= $class;
 169     $args{version}  ||= $class->VERSION;
 170     unless ( $args{path} ) {
 171         $args{path}  = $args{name};
 172         $args{path}  =~ s!::!/!g;
 173     }
 174     $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 175
 176     bless( \%args, $class );
 177 }
 178
 179 sub call {
 180         my ($self, $method) = @_;
 181         my $obj = $self->load($method) or return;
 182         splice(@_, 0, 2, $obj);
 183         goto &{$obj->can($method)};
 184 }
 185
 186 sub load {
 187     my ($self, $method) = @_;
 188
 189     $self->load_extensions(
 190         "$self->{prefix}/$self->{path}", $self
 191     ) unless $self->{extensions};
 192
 193     foreach my $obj (@{$self->{extensions}}) {
 194         return $obj if $obj->can($method);
 195     }
 196
 197     my $admin = $self->{admin} or die <<"END_DIE";
 198 The '$method' method does not exist in the '$self->{prefix}' path!
 199 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 200 END_DIE
 201
 202     my $obj = $admin->load($method, 1);
 203     push @{$self->{extensions}}, $obj;
 204
 205     $obj;
 206 }
 207
 208 sub load_extensions {
 209     my ($self, $path, $top) = @_;
 210
 211     unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
 212         unshift @INC, $self->{prefix};
 213     }
 214
 215     foreach my $rv ( $self->find_extensions($path) ) {
 216         my ($file, $pkg) = @{$rv};
 217         next if $self->{pathnames}{$pkg};
 218
 219         local $@;
 220         my $new = eval { require $file; $pkg->can('new') };
 221         unless ( $new ) {
 222             warn $@ if $@;
 223             next;
 224         }
 225         $self->{pathnames}{$pkg} = delete $INC{$file};
 226         push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
 227     }
 228
 229     $self->{extensions} ||= [];
 230 }
 231
 232 sub find_extensions {
 233     my ($self, $path) = @_;
 234
 235     my @found;
 236     File::Find::find( sub {
 237         my $file = $File::Find::name;
 238         return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 239         my $subpath = $1;
 240         return if lc($subpath) eq lc($self->{dispatch});
 241
 242         $file = "$self->{path}/$subpath.pm";
 243         my $pkg = "$self->{name}::$subpath";
 244         $pkg =~ s!/!::!g;
 245
 246         # If we have a mixed-case package name, assume case has been preserved
 247         # correctly.  Otherwise, root through the file to locate the case-preserved
 248         # version of the package name.
 249         if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
 250             open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
 251             my $in_pod = 0;
 252             while ( <PKGFILE> ) {
 253                 $in_pod = 1 if /^=\w/;
 254                 $in_pod = 0 if /^=cut/;
 255                 next if ($in_pod || /^=cut/);  # skip pod text
 256                 next if /^\s*#/;               # and comments
 257                 if ( m/^\s*package\s+($pkg)\s*;/i ) {
 258                     $pkg = $1;
 259                     last;
 260                 }
 261             }
 262             close PKGFILE;
 263         }
 264
 265         push @found, [ $file, $pkg ];
 266     }, $path ) if -d $path;
 267
 268     @found;
 269 }
 270
 271 sub _caller {
 272     my $depth = 0;
 273     my $call  = caller($depth);
 274     while ( $call eq __PACKAGE__ ) {
 275         $depth++;
 276         $call = caller($depth);
 277     }
 278     return $call;
 279 }
 280
 281 1;