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.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. 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 unless ( uc($1) eq $1 ) { 129 unshift @_, ( $self, $1 ); 130 goto &{$self->can('call')}; 131 } 132 }; 133} 134 135sub 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 159sub 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 192sub 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 221sub 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 228sub 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"; 240The '$method' method does not exist in the '$self->{prefix}' path! 241Please remove the '$self->{prefix}' directory and run $0 again to load it. 242END_DIE 243 244 my $obj = $admin->load($method, 1); 245 push @{$self->{extensions}}, $obj; 246 247 $obj; 248} 249 250sub 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 274sub 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 319sub _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 329sub _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 337sub _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 347sub _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 357sub _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 3671; 368 369# Copyright 2008 Adam Kennedy. 370