2 package Module::Install;
5 # The load order for Module::Install is a bit magic.
6 # It goes something like this...
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
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
23 use vars qw{$VERSION};
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.
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} ) {
43 Please invoke ${\__PACKAGE__} with:
45 use inc::${\__PACKAGE__};
59 *inc::Module::Install::VERSION = *VERSION;
60 @inc::Module::Install::ISA = __PACKAGE__;
64 my $who = $self->_caller;
66 my $sym = "${who}::AUTOLOAD";
69 if ( my $code = $sym->{$pwd} ) {
70 # delegate back to parent dirs
71 goto &$code unless $cwd eq $pwd;
73 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
74 unshift @_, ($self, $1);
75 goto &{$self->can('call')} unless uc($1) eq $1;
81 my $self = $class->new(@_);
82 my $who = $self->_caller;
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 );
89 @_ = ($class, _self => $self);
90 goto &{"$self->{name}::import"};
93 *{"${who}::AUTOLOAD"} = $self->autoload;
96 # Unregister loader and worker packages so subdirs can use them again
97 delete $INC{"$self->{file}"};
98 delete $INC{"$self->{path}.pm"};
104 unless ( $self->{extensions} ) {
105 $self->load_extensions(
106 "$self->{prefix}/$self->{path}", $self
110 my @exts = @{$self->{extensions}};
112 my $admin = $self->{admin};
113 @exts = $admin->load_all_extensions;
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);
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"};
136 my ($class, %args) = @_;
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};
144 return $args{_self} if $args{_self};
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;
158 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
160 bless( \%args, $class );
164 my ($self, $method) = @_;
165 my $obj = $self->load($method) or return;
166 splice(@_, 0, 2, $obj);
167 goto &{$obj->can($method)};
171 my ($self, $method) = @_;
173 $self->load_extensions(
174 "$self->{prefix}/$self->{path}", $self
175 ) unless $self->{extensions};
177 foreach my $obj (@{$self->{extensions}}) {
178 return $obj if $obj->can($method);
181 my $admin = $self->{admin} or die <<"END_DIE";
182 The '$method' method does not exist in the '$self->{prefix}' path!
183 Please remove the '$self->{prefix}' directory and run $0 again to load it.
186 my $obj = $admin->load($method, 1);
187 push @{$self->{extensions}}, $obj;
192 sub load_extensions {
193 my ($self, $path, $top) = @_;
195 unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
196 unshift @INC, $self->{prefix};
199 foreach my $rv ( $self->find_extensions($path) ) {
200 my ($file, $pkg) = @{$rv};
201 next if $self->{pathnames}{$pkg};
204 my $new = eval { require $file; $pkg->can('new') };
209 $self->{pathnames}{$pkg} = delete $INC{$file};
210 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
213 $self->{extensions} ||= [];
216 sub find_extensions {
217 my ($self, $path) = @_;
220 File::Find::find( sub {
221 my $file = $File::Find::name;
222 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
224 return if lc($subpath) eq lc($self->{dispatch});
226 $file = "$self->{path}/$subpath.pm";
227 my $pkg = "$self->{name}::$subpath";
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: $!";
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 ) {
249 push @found, [ $file, $pkg ];
250 }, $path ) if -d $path;
257 my $call = caller($depth);
258 while ( $call eq __PACKAGE__ ) {
260 $call = caller($depth);