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.77';
  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                 unless ( uc($1) eq $1 ) {
 129                         unshift @_, ( $self, $1 );
 130                         goto &{$self->can('call')};
 131                 }
 132         };
 133 }
 134
 135 sub import {
 136         my $class = shift;
 137         my $self  = $class->new(@_);
 138         my $who   = $self->_caller;
 139
 140         unless ( -f $self->{file} ) {
 141                 require "$self->{path}/$self->{dispatch}.pm";
 142                 File::Path::mkpath("$self->{prefix}/$self->{author}");
 143                 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
 144                 $self->{admin}->init;
 145                 @_ = ($class, _self => $self);
 146                 goto &{"$self->{name}::import"};
 147         }
 148
 149         *{"${who}::AUTOLOAD"} = $self->autoload;
 150         $self->preload;
 151
 152         # Unregister loader and worker packages so subdirs can use them again
 153         delete $INC{"$self->{file}"};
 154         delete $INC{"$self->{path}.pm"};
 155
 156         return 1;
 157 }
 158
 159 sub preload {
 160         my $self = shift;
 161         unless ( $self->{extensions} ) {
 162                 $self->load_extensions(
 163                         "$self->{prefix}/$self->{path}", $self
 164                 );
 165         }
 166
 167         my @exts = @{$self->{extensions}};
 168         unless ( @exts ) {
 169                 my $admin = $self->{admin};
 170                 @exts = $admin->load_all_extensions;
 171         }
 172
 173         my %seen;
 174         foreach my $obj ( @exts ) {
 175                 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
 176                         next unless $obj->can($method);
 177                         next if $method =~ /^_/;
 178                         next if $method eq uc($method);
 179                         $seen{$method}++;
 180                 }
 181         }
 182
 183         my $who = $self->_caller;
 184         foreach my $name ( sort keys %seen ) {
 185                 *{"${who}::$name"} = sub {
 186                         ${"${who}::AUTOLOAD"} = "${who}::$name";
 187                         goto &{"${who}::AUTOLOAD"};
 188                 };
 189         }
 190 }
 191
 192 sub new {
 193         my ($class, %args) = @_;
 194
 195         # ignore the prefix on extension modules built from top level.
 196         my $base_path = Cwd::abs_path($FindBin::Bin);
 197         unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
 198                 delete $args{prefix};
 199         }
 200
 201         return $args{_self} if $args{_self};
 202
 203         $args{dispatch} ||= 'Admin';
 204         $args{prefix}   ||= 'inc';
 205         $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
 206         $args{bundle}   ||= 'inc/BUNDLES';
 207         $args{base}     ||= $base_path;
 208         $class =~ s/^\Q$args{prefix}\E:://;
 209         $args{name}     ||= $class;
 210         $args{version}  ||= $class->VERSION;
 211         unless ( $args{path} ) {
 212                 $args{path}  = $args{name};
 213                 $args{path}  =~ s!::!/!g;
 214         }
 215         $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
 216         $args{wrote}      = 0;
 217
 218         bless( \%args, $class );
 219 }
 220
 221 sub call {
 222         my ($self, $method) = @_;
 223         my $obj = $self->load($method) or return;
 224         splice(@_, 0, 2, $obj);
 225         goto &{$obj->can($method)};
 226 }
 227
 228 sub load {
 229         my ($self, $method) = @_;
 230
 231         $self->load_extensions(
 232                 "$self->{prefix}/$self->{path}", $self
 233         ) unless $self->{extensions};
 234
 235         foreach my $obj (@{$self->{extensions}}) {
 236                 return $obj if $obj->can($method);
 237         }
 238
 239         my $admin = $self->{admin} or die <<"END_DIE";
 240 The '$method' method does not exist in the '$self->{prefix}' path!
 241 Please remove the '$self->{prefix}' directory and run $0 again to load it.
 242 END_DIE
 243
 244         my $obj = $admin->load($method, 1);
 245         push @{$self->{extensions}}, $obj;
 246
 247         $obj;
 248 }
 249
 250 sub load_extensions {
 251         my ($self, $path, $top) = @_;
 252
 253         unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
 254                 unshift @INC, $self->{prefix};
 255         }
 256
 257         foreach my $rv ( $self->find_extensions($path) ) {
 258                 my ($file, $pkg) = @{$rv};
 259                 next if $self->{pathnames}{$pkg};
 260
 261                 local $@;
 262                 my $new = eval { require $file; $pkg->can('new') };
 263                 unless ( $new ) {
 264                         warn $@ if $@;
 265                         next;
 266                 }
 267                 $self->{pathnames}{$pkg} = delete $INC{$file};
 268                 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
 269         }
 270
 271         $self->{extensions} ||= [];
 272 }
 273
 274 sub find_extensions {
 275         my ($self, $path) = @_;
 276
 277         my @found;
 278         File::Find::find( sub {
 279                 my $file = $File::Find::name;
 280                 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
 281                 my $subpath = $1;
 282                 return if lc($subpath) eq lc($self->{dispatch});
 283
 284                 $file = "$self->{path}/$subpath.pm";
 285                 my $pkg = "$self->{name}::$subpath";
 286                 $pkg =~ s!/!::!g;
 287
 288                 # If we have a mixed-case package name, assume case has been preserved
 289                 # correctly.  Otherwise, root through the file to locate the case-preserved
 290                 # version of the package name.
 291                 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
 292                         my $content = Module::Install::_read($subpath . '.pm');
 293                         my $in_pod  = 0;
 294                         foreach ( split //, $content ) {
 295                                 $in_pod = 1 if /^=\w/;
 296                                 $in_pod = 0 if /^=cut/;
 297                                 next if ($in_pod || /^=cut/);  # skip pod text
 298                                 next if /^\s*#/;               # and comments
 299                                 if ( m/^\s*package\s+($pkg)\s*;/i ) {
 300                                         $pkg = $1;
 301                                         last;
 302                                 }
 303                         }
 304                 }
 305
 306                 push @found, [ $file, $pkg ];
 307         }, $path ) if -d $path;
 308
 309         @found;
 310 }
 311
 312
 313
 314
 315
 316 #####################################################################
 317 # Utility Functions
 318
 319 sub _caller {
 320         my $depth = 0;
 321         my $call  = caller($depth);
 322         while ( $call eq __PACKAGE__ ) {
 323                 $depth++;
 324                 $call = caller($depth);
 325         }
 326         return $call;
 327 }
 328
 329 sub _read {
 330         local *FH;
 331         open FH, "< $_[0]" or die "open($_[0]): $!";
 332         my $str = do { local $/; <FH> };
 333         close FH or die "close($_[0]): $!";
 334         return $str;
 335 }
 336
 337 sub _write {
 338         local *FH;
 339         open FH, "> $_[0]" or die "open($_[0]): $!";
 340         foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
 341         close FH or die "close($_[0]): $!";
 342 }
 343
 344 # _version is for processing module versions (eg, 1.03_05) not
 345 # Perl versions (eg, 5.8.1).
 346
 347 sub _version ($) {
 348         my $s = shift || 0;
 349            $s =~ s/^(\d+)\.?//;
 350         my $l = $1 || 0;
 351         my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
 352            $l = $l . '.' . join '', @v if @v;
 353         return $l + 0;
 354 }
 355
 356 # Cloned from Params::Util::_CLASS
 357 sub _CLASS ($) {
 358         (
 359                 defined $_[0]
 360                 and
 361                 ! ref $_[0]
 362                 and
 363                 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
 364         ) ? $_[0] : undef;
 365 }
 366
 367 1;
 368
 369 # Copyright 2008 Adam Kennedy.