|
Packit |
c9e8cb |
#line 1
|
|
Packit |
c9e8cb |
package Module::Install;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
# For any maintainers:
|
|
Packit |
c9e8cb |
# The load order for Module::Install is a bit magic.
|
|
Packit |
c9e8cb |
# It goes something like this...
|
|
Packit |
c9e8cb |
#
|
|
Packit |
c9e8cb |
# IF ( host has Module::Install installed, creating author mode ) {
|
|
Packit |
c9e8cb |
# 1. Makefile.PL calls "use inc::Module::Install"
|
|
Packit |
c9e8cb |
# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
|
|
Packit |
c9e8cb |
# 3. The installed version of inc::Module::Install loads
|
|
Packit |
c9e8cb |
# 4. inc::Module::Install calls "require Module::Install"
|
|
Packit |
c9e8cb |
# 5. The ./inc/ version of Module::Install loads
|
|
Packit |
c9e8cb |
# } ELSE {
|
|
Packit |
c9e8cb |
# 1. Makefile.PL calls "use inc::Module::Install"
|
|
Packit |
c9e8cb |
# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
|
|
Packit |
c9e8cb |
# 3. The ./inc/ version of Module::Install loads
|
|
Packit |
c9e8cb |
# }
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
use 5.004;
|
|
Packit |
c9e8cb |
use strict 'vars';
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
use vars qw{$VERSION};
|
|
Packit |
c9e8cb |
BEGIN {
|
|
Packit |
c9e8cb |
# All Module::Install core packages now require synchronised versions.
|
|
Packit |
c9e8cb |
# This will be used to ensure we don't accidentally load old or
|
|
Packit |
c9e8cb |
# different versions of modules.
|
|
Packit |
c9e8cb |
# This is not enforced yet, but will be some time in the next few
|
|
Packit |
c9e8cb |
# releases once we can make sure it won't clash with custom
|
|
Packit |
c9e8cb |
# Module::Install extensions.
|
|
Packit |
c9e8cb |
$VERSION = '0.67';
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
# Whether or not inc::Module::Install is actually loaded, the
|
|
Packit |
c9e8cb |
# $INC{inc/Module/Install.pm} is what will still get set as long as
|
|
Packit |
c9e8cb |
# the caller loaded module this in the documented manner.
|
|
Packit |
c9e8cb |
# If not set, the caller may NOT have loaded the bundled version, and thus
|
|
Packit |
c9e8cb |
# they may not have a MI version that works with the Makefile.PL. This would
|
|
Packit |
c9e8cb |
# result in false errors or unexpected behaviour. And we don't want that.
|
|
Packit |
c9e8cb |
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
|
|
Packit |
c9e8cb |
unless ( $INC{$file} ) {
|
|
Packit |
c9e8cb |
die <<"END_DIE";
|
|
Packit |
c9e8cb |
Please invoke ${\__PACKAGE__} with:
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
use inc::${\__PACKAGE__};
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
not:
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
use ${\__PACKAGE__};
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
END_DIE
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
# If the script that is loading Module::Install is from the future,
|
|
Packit |
c9e8cb |
# then make will detect this and cause it to re-run over and over
|
|
Packit |
c9e8cb |
# again. This is bad. Rather than taking action to touch it (which
|
|
Packit |
c9e8cb |
# is unreliable on some platforms and requires write permissions)
|
|
Packit |
c9e8cb |
# for now we should catch this and refuse to run.
|
|
Packit |
c9e8cb |
if ( -f $0 and (stat($0))[9] > time ) {
|
|
Packit |
c9e8cb |
die << "END_DIE";
|
|
Packit |
c9e8cb |
Your installer $0 has a modification time in the future.
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
This is known to create infinite loops in make.
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
Please correct this, then run $0 again.
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
END_DIE
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
use Cwd ();
|
|
Packit |
c9e8cb |
use File::Find ();
|
|
Packit |
c9e8cb |
use File::Path ();
|
|
Packit |
c9e8cb |
use FindBin;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
*inc::Module::Install::VERSION = *VERSION;
|
|
Packit |
c9e8cb |
@inc::Module::Install::ISA = __PACKAGE__;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub autoload {
|
|
Packit |
c9e8cb |
my $self = shift;
|
|
Packit |
c9e8cb |
my $who = $self->_caller;
|
|
Packit |
c9e8cb |
my $cwd = Cwd::cwd();
|
|
Packit |
c9e8cb |
my $sym = "${who}::AUTOLOAD";
|
|
Packit |
c9e8cb |
$sym->{$cwd} = sub {
|
|
Packit |
c9e8cb |
my $pwd = Cwd::cwd();
|
|
Packit |
c9e8cb |
if ( my $code = $sym->{$pwd} ) {
|
|
Packit |
c9e8cb |
# delegate back to parent dirs
|
|
Packit |
c9e8cb |
goto &$code unless $cwd eq $pwd;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
|
|
Packit |
c9e8cb |
unshift @_, ($self, $1);
|
|
Packit |
c9e8cb |
goto &{$self->can('call')} unless uc($1) eq $1;
|
|
Packit |
c9e8cb |
};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub import {
|
|
Packit |
c9e8cb |
my $class = shift;
|
|
Packit |
c9e8cb |
my $self = $class->new(@_);
|
|
Packit |
c9e8cb |
my $who = $self->_caller;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
unless ( -f $self->{file} ) {
|
|
Packit |
c9e8cb |
require "$self->{path}/$self->{dispatch}.pm";
|
|
Packit |
c9e8cb |
File::Path::mkpath("$self->{prefix}/$self->{author}");
|
|
Packit |
c9e8cb |
$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
|
|
Packit |
c9e8cb |
$self->{admin}->init;
|
|
Packit |
c9e8cb |
@_ = ($class, _self => $self);
|
|
Packit |
c9e8cb |
goto &{"$self->{name}::import"};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
*{"${who}::AUTOLOAD"} = $self->autoload;
|
|
Packit |
c9e8cb |
$self->preload;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
# Unregister loader and worker packages so subdirs can use them again
|
|
Packit |
c9e8cb |
delete $INC{"$self->{file}"};
|
|
Packit |
c9e8cb |
delete $INC{"$self->{path}.pm"};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub preload {
|
|
Packit |
c9e8cb |
my ($self) = @_;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
unless ( $self->{extensions} ) {
|
|
Packit |
c9e8cb |
$self->load_extensions(
|
|
Packit |
c9e8cb |
"$self->{prefix}/$self->{path}", $self
|
|
Packit |
c9e8cb |
);
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
my @exts = @{$self->{extensions}};
|
|
Packit |
c9e8cb |
unless ( @exts ) {
|
|
Packit |
c9e8cb |
my $admin = $self->{admin};
|
|
Packit |
c9e8cb |
@exts = $admin->load_all_extensions;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
my %seen;
|
|
Packit |
c9e8cb |
foreach my $obj ( @exts ) {
|
|
Packit |
c9e8cb |
while (my ($method, $glob) = each %{ref($obj) . '::'}) {
|
|
Packit |
c9e8cb |
next unless $obj->can($method);
|
|
Packit |
c9e8cb |
next if $method =~ /^_/;
|
|
Packit |
c9e8cb |
next if $method eq uc($method);
|
|
Packit |
c9e8cb |
$seen{$method}++;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
my $who = $self->_caller;
|
|
Packit |
c9e8cb |
foreach my $name ( sort keys %seen ) {
|
|
Packit |
c9e8cb |
*{"${who}::$name"} = sub {
|
|
Packit |
c9e8cb |
${"${who}::AUTOLOAD"} = "${who}::$name";
|
|
Packit |
c9e8cb |
goto &{"${who}::AUTOLOAD"};
|
|
Packit |
c9e8cb |
};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub new {
|
|
Packit |
c9e8cb |
my ($class, %args) = @_;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
# ignore the prefix on extension modules built from top level.
|
|
Packit |
c9e8cb |
my $base_path = Cwd::abs_path($FindBin::Bin);
|
|
Packit |
c9e8cb |
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
|
|
Packit |
c9e8cb |
delete $args{prefix};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
return $args{_self} if $args{_self};
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
$args{dispatch} ||= 'Admin';
|
|
Packit |
c9e8cb |
$args{prefix} ||= 'inc';
|
|
Packit |
c9e8cb |
$args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
|
|
Packit |
c9e8cb |
$args{bundle} ||= 'inc/BUNDLES';
|
|
Packit |
c9e8cb |
$args{base} ||= $base_path;
|
|
Packit |
c9e8cb |
$class =~ s/^\Q$args{prefix}\E:://;
|
|
Packit |
c9e8cb |
$args{name} ||= $class;
|
|
Packit |
c9e8cb |
$args{version} ||= $class->VERSION;
|
|
Packit |
c9e8cb |
unless ( $args{path} ) {
|
|
Packit |
c9e8cb |
$args{path} = $args{name};
|
|
Packit |
c9e8cb |
$args{path} =~ s!::!/!g;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
$args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
bless( \%args, $class );
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub call {
|
|
Packit |
c9e8cb |
my ($self, $method) = @_;
|
|
Packit |
c9e8cb |
my $obj = $self->load($method) or return;
|
|
Packit |
c9e8cb |
splice(@_, 0, 2, $obj);
|
|
Packit |
c9e8cb |
goto &{$obj->can($method)};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub load {
|
|
Packit |
c9e8cb |
my ($self, $method) = @_;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
$self->load_extensions(
|
|
Packit |
c9e8cb |
"$self->{prefix}/$self->{path}", $self
|
|
Packit |
c9e8cb |
) unless $self->{extensions};
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
foreach my $obj (@{$self->{extensions}}) {
|
|
Packit |
c9e8cb |
return $obj if $obj->can($method);
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
my $admin = $self->{admin} or die <<"END_DIE";
|
|
Packit |
c9e8cb |
The '$method' method does not exist in the '$self->{prefix}' path!
|
|
Packit |
c9e8cb |
Please remove the '$self->{prefix}' directory and run $0 again to load it.
|
|
Packit |
c9e8cb |
END_DIE
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
my $obj = $admin->load($method, 1);
|
|
Packit |
c9e8cb |
push @{$self->{extensions}}, $obj;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
$obj;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub load_extensions {
|
|
Packit |
c9e8cb |
my ($self, $path, $top) = @_;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
|
|
Packit |
c9e8cb |
unshift @INC, $self->{prefix};
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
foreach my $rv ( $self->find_extensions($path) ) {
|
|
Packit |
c9e8cb |
my ($file, $pkg) = @{$rv};
|
|
Packit |
c9e8cb |
next if $self->{pathnames}{$pkg};
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
local $@;
|
|
Packit |
c9e8cb |
my $new = eval { require $file; $pkg->can('new') };
|
|
Packit |
c9e8cb |
unless ( $new ) {
|
|
Packit |
c9e8cb |
warn $@ if $@;
|
|
Packit |
c9e8cb |
next;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
$self->{pathnames}{$pkg} = delete $INC{$file};
|
|
Packit |
c9e8cb |
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
$self->{extensions} ||= [];
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub find_extensions {
|
|
Packit |
c9e8cb |
my ($self, $path) = @_;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
my @found;
|
|
Packit |
c9e8cb |
File::Find::find( sub {
|
|
Packit |
c9e8cb |
my $file = $File::Find::name;
|
|
Packit |
c9e8cb |
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
|
|
Packit |
c9e8cb |
my $subpath = $1;
|
|
Packit |
c9e8cb |
return if lc($subpath) eq lc($self->{dispatch});
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
$file = "$self->{path}/$subpath.pm";
|
|
Packit |
c9e8cb |
my $pkg = "$self->{name}::$subpath";
|
|
Packit |
c9e8cb |
$pkg =~ s!/!::!g;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
# If we have a mixed-case package name, assume case has been preserved
|
|
Packit |
c9e8cb |
# correctly. Otherwise, root through the file to locate the case-preserved
|
|
Packit |
c9e8cb |
# version of the package name.
|
|
Packit |
c9e8cb |
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
|
|
Packit |
c9e8cb |
open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
|
|
Packit |
c9e8cb |
my $in_pod = 0;
|
|
Packit |
c9e8cb |
while ( <PKGFILE> ) {
|
|
Packit |
c9e8cb |
$in_pod = 1 if /^=\w/;
|
|
Packit |
c9e8cb |
$in_pod = 0 if /^=cut/;
|
|
Packit |
c9e8cb |
next if ($in_pod || /^=cut/); # skip pod text
|
|
Packit |
c9e8cb |
next if /^\s*#/; # and comments
|
|
Packit |
c9e8cb |
if ( m/^\s*package\s+($pkg)\s*;/i ) {
|
|
Packit |
c9e8cb |
$pkg = $1;
|
|
Packit |
c9e8cb |
last;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
close PKGFILE;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
push @found, [ $file, $pkg ];
|
|
Packit |
c9e8cb |
}, $path ) if -d $path;
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
@found;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
sub _caller {
|
|
Packit |
c9e8cb |
my $depth = 0;
|
|
Packit |
c9e8cb |
my $call = caller($depth);
|
|
Packit |
c9e8cb |
while ( $call eq __PACKAGE__ ) {
|
|
Packit |
c9e8cb |
$depth++;
|
|
Packit |
c9e8cb |
$call = caller($depth);
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
return $call;
|
|
Packit |
c9e8cb |
}
|
|
Packit |
c9e8cb |
|
|
Packit |
c9e8cb |
1;
|