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