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.71'; 34} 35 36 37 38 39 40# Whether or not inc::Module::Install is actually loaded, the 41# $INC{inc/Module/Install.pm} is what will still get set as long as 42# the caller loaded module this in the documented manner. 43# If not set, the caller may NOT have loaded the bundled version, and thus 44# they may not have a MI version that works with the Makefile.PL. This would 45# result in false errors or unexpected behaviour. And we don't want that. 46my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 47unless ( $INC{$file} ) { die <<"END_DIE" } 48 49Please invoke ${\__PACKAGE__} with: 50 51 use inc::${\__PACKAGE__}; 52 53not: 54 55 use ${\__PACKAGE__}; 56 57END_DIE 58 59 60 61 62 63# If the script that is loading Module::Install is from the future, 64# then make will detect this and cause it to re-run over and over 65# again. This is bad. Rather than taking action to touch it (which 66# is unreliable on some platforms and requires write permissions) 67# for now we should catch this and refuse to run. 68if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } 69 70Your installer $0 has a modification time in the future. 71 72This is known to create infinite loops in make. 73 74Please correct this, then run $0 again. 75 76END_DIE 77 78 79 80 81 82# Build.PL was formerly supported, but no longer is due to excessive 83# difficulty in implementing every single feature twice. 84if ( $0 =~ /Build.PL$/i or -f 'Build.PL' ) { die <<"END_DIE" } 85 86Module::Install no longer supports Build.PL. 87 88It was impossible to maintain duel backends, and has been deprecated. 89 90Please remove all Build.PL files and only use the Makefile.PL installer. 91 92END_DIE 93 94 95 96 97 98use Cwd (); 99use File::Find (); 100use File::Path (); 101use FindBin; 102 103*inc::Module::Install::VERSION = *VERSION; 104@inc::Module::Install::ISA = __PACKAGE__; 105 106sub autoload { 107 my $self = shift; 108 my $who = $self->_caller; 109 my $cwd = Cwd::cwd(); 110 my $sym = "${who}::AUTOLOAD"; 111 $sym->{$cwd} = sub { 112 my $pwd = Cwd::cwd(); 113 if ( my $code = $sym->{$pwd} ) { 114 # delegate back to parent dirs 115 goto &$code unless $cwd eq $pwd; 116 } 117 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 118 unshift @_, ( $self, $1 ); 119 goto &{$self->can('call')} unless uc($1) eq $1; 120 }; 121} 122 123sub import { 124 my $class = shift; 125 my $self = $class->new(@_); 126 my $who = $self->_caller; 127 128 unless ( -f $self->{file} ) { 129 require "$self->{path}/$self->{dispatch}.pm"; 130 File::Path::mkpath("$self->{prefix}/$self->{author}"); 131 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 132 $self->{admin}->init; 133 @_ = ($class, _self => $self); 134 goto &{"$self->{name}::import"}; 135 } 136 137 *{"${who}::AUTOLOAD"} = $self->autoload; 138 $self->preload; 139 140 # Unregister loader and worker packages so subdirs can use them again 141 delete $INC{"$self->{file}"}; 142 delete $INC{"$self->{path}.pm"}; 143 144 return 1; 145} 146 147sub preload { 148 my $self = shift; 149 unless ( $self->{extensions} ) { 150 $self->load_extensions( 151 "$self->{prefix}/$self->{path}", $self 152 ); 153 } 154 155 my @exts = @{$self->{extensions}}; 156 unless ( @exts ) { 157 my $admin = $self->{admin}; 158 @exts = $admin->load_all_extensions; 159 } 160 161 my %seen; 162 foreach my $obj ( @exts ) { 163 while (my ($method, $glob) = each %{ref($obj) . '::'}) { 164 next unless $obj->can($method); 165 next if $method =~ /^_/; 166 next if $method eq uc($method); 167 $seen{$method}++; 168 } 169 } 170 171 my $who = $self->_caller; 172 foreach my $name ( sort keys %seen ) { 173 *{"${who}::$name"} = sub { 174 ${"${who}::AUTOLOAD"} = "${who}::$name"; 175 goto &{"${who}::AUTOLOAD"}; 176 }; 177 } 178} 179 180sub new { 181 my ($class, %args) = @_; 182 183 # ignore the prefix on extension modules built from top level. 184 my $base_path = Cwd::abs_path($FindBin::Bin); 185 unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { 186 delete $args{prefix}; 187 } 188 189 return $args{_self} if $args{_self}; 190 191 $args{dispatch} ||= 'Admin'; 192 $args{prefix} ||= 'inc'; 193 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 194 $args{bundle} ||= 'inc/BUNDLES'; 195 $args{base} ||= $base_path; 196 $class =~ s/^\Q$args{prefix}\E:://; 197 $args{name} ||= $class; 198 $args{version} ||= $class->VERSION; 199 unless ( $args{path} ) { 200 $args{path} = $args{name}; 201 $args{path} =~ s!::!/!g; 202 } 203 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 204 $args{wrote} = 0; 205 206 bless( \%args, $class ); 207} 208 209sub call { 210 my ($self, $method) = @_; 211 my $obj = $self->load($method) or return; 212 splice(@_, 0, 2, $obj); 213 goto &{$obj->can($method)}; 214} 215 216sub load { 217 my ($self, $method) = @_; 218 219 $self->load_extensions( 220 "$self->{prefix}/$self->{path}", $self 221 ) unless $self->{extensions}; 222 223 foreach my $obj (@{$self->{extensions}}) { 224 return $obj if $obj->can($method); 225 } 226 227 my $admin = $self->{admin} or die <<"END_DIE"; 228The '$method' method does not exist in the '$self->{prefix}' path! 229Please remove the '$self->{prefix}' directory and run $0 again to load it. 230END_DIE 231 232 my $obj = $admin->load($method, 1); 233 push @{$self->{extensions}}, $obj; 234 235 $obj; 236} 237 238sub load_extensions { 239 my ($self, $path, $top) = @_; 240 241 unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { 242 unshift @INC, $self->{prefix}; 243 } 244 245 foreach my $rv ( $self->find_extensions($path) ) { 246 my ($file, $pkg) = @{$rv}; 247 next if $self->{pathnames}{$pkg}; 248 249 local $@; 250 my $new = eval { require $file; $pkg->can('new') }; 251 unless ( $new ) { 252 warn $@ if $@; 253 next; 254 } 255 $self->{pathnames}{$pkg} = delete $INC{$file}; 256 push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 257 } 258 259 $self->{extensions} ||= []; 260} 261 262sub find_extensions { 263 my ($self, $path) = @_; 264 265 my @found; 266 File::Find::find( sub { 267 my $file = $File::Find::name; 268 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 269 my $subpath = $1; 270 return if lc($subpath) eq lc($self->{dispatch}); 271 272 $file = "$self->{path}/$subpath.pm"; 273 my $pkg = "$self->{name}::$subpath"; 274 $pkg =~ s!/!::!g; 275 276 # If we have a mixed-case package name, assume case has been preserved 277 # correctly. Otherwise, root through the file to locate the case-preserved 278 # version of the package name. 279 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 280 my $content = Module::Install::_read($subpath . '.pm'); 281 my $in_pod = 0; 282 foreach ( split //, $content ) { 283 $in_pod = 1 if /^=\w/; 284 $in_pod = 0 if /^=cut/; 285 next if ($in_pod || /^=cut/); # skip pod text 286 next if /^\s*#/; # and comments 287 if ( m/^\s*package\s+($pkg)\s*;/i ) { 288 $pkg = $1; 289 last; 290 } 291 } 292 } 293 294 push @found, [ $file, $pkg ]; 295 }, $path ) if -d $path; 296 297 @found; 298} 299 300 301 302 303 304##################################################################### 305# Utility Functions 306 307sub _caller { 308 my $depth = 0; 309 my $call = caller($depth); 310 while ( $call eq __PACKAGE__ ) { 311 $depth++; 312 $call = caller($depth); 313 } 314 return $call; 315} 316 317sub _read { 318 local *FH; 319 open FH, "< $_[0]" or die "open($_[0]): $!"; 320 my $str = do { local $/; <FH> }; 321 close FH or die "close($_[0]): $!"; 322 return $str; 323} 324 325sub _write { 326 local *FH; 327 open FH, "> $_[0]" or die "open($_[0]): $!"; 328 foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" } 329 close FH or die "close($_[0]): $!"; 330} 331 332sub _version { 333 my $s = shift || 0; 334 $s =~ s/^(\d+)\.?//; 335 my $l = $1 || 0; 336 my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; 337 $l = $l . '.' . join '', @v if @v; 338 return $l + 0; 339} 340 3411; 342 343# Copyright 2008 Adam Kennedy. 344