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.62'; 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 54use Cwd (); 55use File::Find (); 56use File::Path (); 57use FindBin; 58 59*inc::Module::Install::VERSION = *VERSION; 60@inc::Module::Install::ISA = __PACKAGE__; 61 62sub autoload { 63 my $self = shift; 64 my $who = $self->_caller; 65 my $cwd = Cwd::cwd(); 66 my $sym = "${who}::AUTOLOAD"; 67 $sym->{$cwd} = sub { 68 my $pwd = Cwd::cwd(); 69 if ( my $code = $sym->{$pwd} ) { 70 # delegate back to parent dirs 71 goto &$code unless $cwd eq $pwd; 72 } 73 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 74 unshift @_, ($self, $1); 75 goto &{$self->can('call')} unless uc($1) eq $1; 76 }; 77} 78 79sub import { 80 my $class = shift; 81 my $self = $class->new(@_); 82 my $who = $self->_caller; 83 84 unless ( -f $self->{file} ) { 85 require "$self->{path}/$self->{dispatch}.pm"; 86 File::Path::mkpath("$self->{prefix}/$self->{author}"); 87 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 88 $self->{admin}->init; 89 @_ = ($class, _self => $self); 90 goto &{"$self->{name}::import"}; 91 } 92 93 *{"${who}::AUTOLOAD"} = $self->autoload; 94 $self->preload; 95 96 # Unregister loader and worker packages so subdirs can use them again 97 delete $INC{"$self->{file}"}; 98 delete $INC{"$self->{path}.pm"}; 99} 100 101sub preload { 102 my ($self) = @_; 103 104 unless ( $self->{extensions} ) { 105 $self->load_extensions( 106 "$self->{prefix}/$self->{path}", $self 107 ); 108 } 109 110 my @exts = @{$self->{extensions}}; 111 unless ( @exts ) { 112 my $admin = $self->{admin}; 113 @exts = $admin->load_all_extensions; 114 } 115 116 my %seen; 117 foreach my $obj ( @exts ) { 118 while (my ($method, $glob) = each %{ref($obj) . '::'}) { 119 next unless exists &{ref($obj).'::'.$method}; 120 next if $method =~ /^_/; 121 next if $method eq uc($method); 122 $seen{$method}++; 123 } 124 } 125 126 my $who = $self->_caller; 127 foreach my $name ( sort keys %seen ) { 128 *{"${who}::$name"} = sub { 129 ${"${who}::AUTOLOAD"} = "${who}::$name"; 130 goto &{"${who}::AUTOLOAD"}; 131 }; 132 } 133} 134 135sub new { 136 my ($class, %args) = @_; 137 138 # ignore the prefix on extension modules built from top level. 139 my $base_path = Cwd::abs_path($FindBin::Bin); 140 unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { 141 delete $args{prefix}; 142 } 143 144 return $args{_self} if $args{_self}; 145 146 $args{dispatch} ||= 'Admin'; 147 $args{prefix} ||= 'inc'; 148 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 149 $args{bundle} ||= 'inc/BUNDLES'; 150 $args{base} ||= $base_path; 151 $class =~ s/^\Q$args{prefix}\E:://; 152 $args{name} ||= $class; 153 $args{version} ||= $class->VERSION; 154 unless ( $args{path} ) { 155 $args{path} = $args{name}; 156 $args{path} =~ s!::!/!g; 157 } 158 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 159 160 bless( \%args, $class ); 161} 162 163sub call { 164 my ($self, $method) = @_; 165 my $obj = $self->load($method) or return; 166 splice(@_, 0, 2, $obj); 167 goto &{$obj->can($method)}; 168} 169 170sub load { 171 my ($self, $method) = @_; 172 173 $self->load_extensions( 174 "$self->{prefix}/$self->{path}", $self 175 ) unless $self->{extensions}; 176 177 foreach my $obj (@{$self->{extensions}}) { 178 return $obj if $obj->can($method); 179 } 180 181 my $admin = $self->{admin} or die <<"END_DIE"; 182The '$method' method does not exist in the '$self->{prefix}' path! 183Please remove the '$self->{prefix}' directory and run $0 again to load it. 184END_DIE 185 186 my $obj = $admin->load($method, 1); 187 push @{$self->{extensions}}, $obj; 188 189 $obj; 190} 191 192sub load_extensions { 193 my ($self, $path, $top) = @_; 194 195 unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { 196 unshift @INC, $self->{prefix}; 197 } 198 199 foreach my $rv ( $self->find_extensions($path) ) { 200 my ($file, $pkg) = @{$rv}; 201 next if $self->{pathnames}{$pkg}; 202 203 local $@; 204 my $new = eval { require $file; $pkg->can('new') }; 205 unless ( $new ) { 206 warn $@ if $@; 207 next; 208 } 209 $self->{pathnames}{$pkg} = delete $INC{$file}; 210 push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 211 } 212 213 $self->{extensions} ||= []; 214} 215 216sub find_extensions { 217 my ($self, $path) = @_; 218 219 my @found; 220 File::Find::find( sub { 221 my $file = $File::Find::name; 222 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 223 my $subpath = $1; 224 return if lc($subpath) eq lc($self->{dispatch}); 225 226 $file = "$self->{path}/$subpath.pm"; 227 my $pkg = "$self->{name}::$subpath"; 228 $pkg =~ s!/!::!g; 229 230 # If we have a mixed-case package name, assume case has been preserved 231 # correctly. Otherwise, root through the file to locate the case-preserved 232 # version of the package name. 233 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 234 open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; 235 my $in_pod = 0; 236 while ( <PKGFILE> ) { 237 $in_pod = 1 if /^=\w/; 238 $in_pod = 0 if /^=cut/; 239 next if ($in_pod || /^=cut/); # skip pod text 240 next if /^\s*#/; # and comments 241 if ( m/^\s*package\s+($pkg)\s*;/i ) { 242 $pkg = $1; 243 last; 244 } 245 } 246 close PKGFILE; 247 } 248 249 push @found, [ $file, $pkg ]; 250 }, $path ) if -d $path; 251 252 @found; 253} 254 255sub _caller { 256 my $depth = 0; 257 my $call = caller($depth); 258 while ( $call eq __PACKAGE__ ) { 259 $depth++; 260 $call = caller($depth); 261 } 262 return $call; 263} 264 2651; 266