| 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; |
Parent Directory
| 
Revision Log