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.004; 21use strict 'vars'; 22 23use vars qw{$VERSION}; 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.64'; 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. 40my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 41unless ( $INC{$file} ) { 42 die <<"END_DIE"; 43Please invoke ${\__PACKAGE__} with: 44 45 use inc::${\__PACKAGE__}; 46 47not: 48 49 use ${\__PACKAGE__}; 50 51END_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. 59if ( -f $0 and (stat($0))[9] > time ) { 60 die << "END_DIE"; 61Your installer $0 has a modification time in the future. 62 63This is known to create infinite loops in make. 64 65Please correct this, then run $0 again. 66 67END_DIE 68} 69 70use Cwd (); 71use File::Find (); 72use File::Path (); 73use FindBin; 74 75*inc::Module::Install::VERSION = *VERSION; 76@inc::Module::Install::ISA = __PACKAGE__; 77 78sub 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 95sub 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 117sub 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 151sub 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 179sub 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 186sub 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"; 198The '$method' method does not exist in the '$self->{prefix}' path! 199Please remove the '$self->{prefix}' directory and run $0 again to load it. 200END_DIE 201 202 my $obj = $admin->load($method, 1); 203 push @{$self->{extensions}}, $obj; 204 205 $obj; 206} 207 208sub 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 232sub 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 271sub _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 2811; 282