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