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