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 20use 5.005; 21use strict 'vars'; 22 23use vars qw{$VERSION $MAIN}; 24BEGIN { 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.91'; 32 33 # Storage for the pseudo-singleton 34 $MAIN = undef; 35 36 *inc::Module::Install::VERSION = *VERSION; 37 @inc::Module::Install::ISA = __PACKAGE__; 38 39} 40 41 42 43 44 45# Whether or not inc::Module::Install is actually loaded, the 46# $INC{inc/Module/Install.pm} is what will still get set as long as 47# the caller loaded module this in the documented manner. 48# If not set, the caller may NOT have loaded the bundled version, and thus 49# they may not have a MI version that works with the Makefile.PL. This would 50# result in false errors or unexpected behaviour. And we don't want that. 51my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 52unless ( $INC{$file} ) { die <<"END_DIE" } 53 54Please invoke ${\__PACKAGE__} with: 55 56 use inc::${\__PACKAGE__}; 57 58not: 59 60 use ${\__PACKAGE__}; 61 62END_DIE 63 64 65 66 67 68# If the script that is loading Module::Install is from the future, 69# then make will detect this and cause it to re-run over and over 70# again. This is bad. Rather than taking action to touch it (which 71# is unreliable on some platforms and requires write permissions) 72# for now we should catch this and refuse to run. 73if ( -f $0 ) { 74 my $s = (stat($0))[9]; 75 76 # If the modification time is only slightly in the future, 77 # sleep briefly to remove the problem. 78 my $a = $s - time; 79 if ( $a > 0 and $a < 5 ) { sleep 5 } 80 81 # Too far in the future, throw an error. 82 my $t = time; 83 if ( $s > $t ) { die <<"END_DIE" } 84 85Your installer $0 has a modification time in the future ($s > $t). 86 87This is known to create infinite loops in make. 88 89Please correct this, then run $0 again. 90 91END_DIE 92} 93 94 95 96 97 98# Build.PL was formerly supported, but no longer is due to excessive 99# difficulty in implementing every single feature twice. 100if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } 101 102Module::Install no longer supports Build.PL. 103 104It was impossible to maintain duel backends, and has been deprecated. 105 106Please remove all Build.PL files and only use the Makefile.PL installer. 107 108END_DIE 109 110 111 112 113 114# To save some more typing in Module::Install installers, every... 115# use inc::Module::Install 116# ...also acts as an implicit use strict. 117$^H |= strict::bits(qw(refs subs vars)); 118 119 120 121 122 123use Cwd (); 124use File::Find (); 125use File::Path (); 126use FindBin; 127 128sub autoload { 129 my $self = shift; 130 my $who = $self->_caller; 131 my $cwd = Cwd::cwd(); 132 my $sym = "${who}::AUTOLOAD"; 133 $sym->{$cwd} = sub { 134 my $pwd = Cwd::cwd(); 135 if ( my $code = $sym->{$pwd} ) { 136 # Delegate back to parent dirs 137 goto &$code unless $cwd eq $pwd; 138 } 139 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 140 my $method = $1; 141 if ( uc($method) eq $method ) { 142 # Do nothing 143 return; 144 } elsif ( $method =~ /^_/ and $self->can($method) ) { 145 # Dispatch to the root M:I class 146 return $self->$method(@_); 147 } 148 149 # Dispatch to the appropriate plugin 150 unshift @_, ( $self, $1 ); 151 goto &{$self->can('call')}; 152 }; 153} 154 155sub import { 156 my $class = shift; 157 my $self = $class->new(@_); 158 my $who = $self->_caller; 159 160 unless ( -f $self->{file} ) { 161 require "$self->{path}/$self->{dispatch}.pm"; 162 File::Path::mkpath("$self->{prefix}/$self->{author}"); 163 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 164 $self->{admin}->init; 165 @_ = ($class, _self => $self); 166 goto &{"$self->{name}::import"}; 167 } 168 169 *{"${who}::AUTOLOAD"} = $self->autoload; 170 $self->preload; 171 172 # Unregister loader and worker packages so subdirs can use them again 173 delete $INC{"$self->{file}"}; 174 delete $INC{"$self->{path}.pm"}; 175 176 # Save to the singleton 177 $MAIN = $self; 178 179 return 1; 180} 181 182sub preload { 183 my $self = shift; 184 unless ( $self->{extensions} ) { 185 $self->load_extensions( 186 "$self->{prefix}/$self->{path}", $self 187 ); 188 } 189 190 my @exts = @{$self->{extensions}}; 191 unless ( @exts ) { 192 @exts = $self->{admin}->load_all_extensions; 193 } 194 195 my %seen; 196 foreach my $obj ( @exts ) { 197 while (my ($method, $glob) = each %{ref($obj) . '::'}) { 198 next unless $obj->can($method); 199 next if $method =~ /^_/; 200 next if $method eq uc($method); 201 $seen{$method}++; 202 } 203 } 204 205 my $who = $self->_caller; 206 foreach my $name ( sort keys %seen ) { 207 *{"${who}::$name"} = sub { 208 ${"${who}::AUTOLOAD"} = "${who}::$name"; 209 goto &{"${who}::AUTOLOAD"}; 210 }; 211 } 212} 213 214sub new { 215 my ($class, %args) = @_; 216 217 # ignore the prefix on extension modules built from top level. 218 my $base_path = Cwd::abs_path($FindBin::Bin); 219 unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { 220 delete $args{prefix}; 221 } 222 223 return $args{_self} if $args{_self}; 224 225 $args{dispatch} ||= 'Admin'; 226 $args{prefix} ||= 'inc'; 227 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 228 $args{bundle} ||= 'inc/BUNDLES'; 229 $args{base} ||= $base_path; 230 $class =~ s/^\Q$args{prefix}\E:://; 231 $args{name} ||= $class; 232 $args{version} ||= $class->VERSION; 233 unless ( $args{path} ) { 234 $args{path} = $args{name}; 235 $args{path} =~ s!::!/!g; 236 } 237 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 238 $args{wrote} = 0; 239 240 bless( \%args, $class ); 241} 242 243sub call { 244 my ($self, $method) = @_; 245 my $obj = $self->load($method) or return; 246 splice(@_, 0, 2, $obj); 247 goto &{$obj->can($method)}; 248} 249 250sub load { 251 my ($self, $method) = @_; 252 253 $self->load_extensions( 254 "$self->{prefix}/$self->{path}", $self 255 ) unless $self->{extensions}; 256 257 foreach my $obj (@{$self->{extensions}}) { 258 return $obj if $obj->can($method); 259 } 260 261 my $admin = $self->{admin} or die <<"END_DIE"; 262The '$method' method does not exist in the '$self->{prefix}' path! 263Please remove the '$self->{prefix}' directory and run $0 again to load it. 264END_DIE 265 266 my $obj = $admin->load($method, 1); 267 push @{$self->{extensions}}, $obj; 268 269 $obj; 270} 271 272sub load_extensions { 273 my ($self, $path, $top) = @_; 274 275 unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 276 unshift @INC, $self->{prefix}; 277 } 278 279 foreach my $rv ( $self->find_extensions($path) ) { 280 my ($file, $pkg) = @{$rv}; 281 next if $self->{pathnames}{$pkg}; 282 283 local $@; 284 my $new = eval { require $file; $pkg->can('new') }; 285 unless ( $new ) { 286 warn $@ if $@; 287 next; 288 } 289 $self->{pathnames}{$pkg} = delete $INC{$file}; 290 push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 291 } 292 293 $self->{extensions} ||= []; 294} 295 296sub find_extensions { 297 my ($self, $path) = @_; 298 299 my @found; 300 File::Find::find( sub { 301 my $file = $File::Find::name; 302 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 303 my $subpath = $1; 304 return if lc($subpath) eq lc($self->{dispatch}); 305 306 $file = "$self->{path}/$subpath.pm"; 307 my $pkg = "$self->{name}::$subpath"; 308 $pkg =~ s!/!::!g; 309 310 # If we have a mixed-case package name, assume case has been preserved 311 # correctly. Otherwise, root through the file to locate the case-preserved 312 # version of the package name. 313 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 314 my $content = Module::Install::_read($subpath . '.pm'); 315 my $in_pod = 0; 316 foreach ( split //, $content ) { 317 $in_pod = 1 if /^=\w/; 318 $in_pod = 0 if /^=cut/; 319 next if ($in_pod || /^=cut/); # skip pod text 320 next if /^\s*#/; # and comments 321 if ( m/^\s*package\s+($pkg)\s*;/i ) { 322 $pkg = $1; 323 last; 324 } 325 } 326 } 327 328 push @found, [ $file, $pkg ]; 329 }, $path ) if -d $path; 330 331 @found; 332} 333 334 335 336 337 338##################################################################### 339# Common Utility Functions 340 341sub _caller { 342 my $depth = 0; 343 my $call = caller($depth); 344 while ( $call eq __PACKAGE__ ) { 345 $depth++; 346 $call = caller($depth); 347 } 348 return $call; 349} 350 351sub _read { 352 local *FH; 353 if ( $] >= 5.006 ) { 354 open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 355 } else { 356 open( FH, "< $_[0]" ) or die "open($_[0]): $!"; 357 } 358 my $string = do { local $/; <FH> }; 359 close FH or die "close($_[0]): $!"; 360 return $string; 361} 362 363sub _readperl { 364 my $string = Module::Install::_read($_[0]); 365 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 366 $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 367 $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 368 return $string; 369} 370 371sub _readpod { 372 my $string = Module::Install::_read($_[0]); 373 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 374 return $string if $_[0] =~ /\.pod\z/; 375 $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 376 $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 377 $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 378 $string =~ s/^\n+//s; 379 return $string; 380} 381 382sub _write { 383 local *FH; 384 if ( $] >= 5.006 ) { 385 open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 386 } else { 387 open( FH, "> $_[0]" ) or die "open($_[0]): $!"; 388 } 389 foreach ( 1 .. $#_ ) { 390 print FH $_[$_] or die "print($_[0]): $!"; 391 } 392 close FH or die "close($_[0]): $!"; 393} 394 395# _version is for processing module versions (eg, 1.03_05) not 396# Perl versions (eg, 5.8.1). 397sub _version ($) { 398 my $s = shift || 0; 399 my $d =()= $s =~ /(\.)/g; 400 if ( $d >= 2 ) { 401 # Normalise multipart versions 402 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 403 } 404 $s =~ s/^(\d+)\.?//; 405 my $l = $1 || 0; 406 my @v = map { 407 $_ . '0' x (3 - length $_) 408 } $s =~ /(\d{1,3})\D?/g; 409 $l = $l . '.' . join '', @v if @v; 410 return $l + 0; 411} 412 413sub _cmp ($$) { 414 _version($_[0]) <=> _version($_[1]); 415} 416 417# Cloned from Params::Util::_CLASS 418sub _CLASS ($) { 419 ( 420 defined $_[0] 421 and 422 ! ref $_[0] 423 and 424 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 425 ) ? $_[0] : undef; 426} 427 4281; 429 430# Copyright 2008 - 2009 Adam Kennedy. 431