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
25 use vars qw{$VERSION};
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.
35 *inc::Module::Install::VERSION = *VERSION;
36 @inc::Module::Install::ISA = __PACKAGE__;
44 # Whether or not inc::Module::Install is actually loaded, the
45 # $INC{inc/Module/Install.pm} is what will still get set as long as
46 # the caller loaded module this in the documented manner.
47 # If not set, the caller may NOT have loaded the bundled version, and thus
48 # they may not have a MI version that works with the Makefile.PL. This would
49 # result in false errors or unexpected behaviour. And we don't want that.
50 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
51 unless ( $INC{$file} ) { die <<"END_DIE" }
53 Please invoke ${\__PACKAGE__} with:
55 use inc::${\__PACKAGE__};
67 # If the script that is loading Module::Install is from the future,
68 # then make will detect this and cause it to re-run over and over
69 # again. This is bad. Rather than taking action to touch it (which
70 # is unreliable on some platforms and requires write permissions)
71 # for now we should catch this and refuse to run.
72 if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
74 Your installer $0 has a modification time in the future.
76 This is known to create infinite loops in make.
78 Please correct this, then run $0 again.
86 # Build.PL was formerly supported, but no longer is due to excessive
87 # difficulty in implementing every single feature twice.
88 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
90 Module::Install no longer supports Build.PL.
92 It was impossible to maintain duel backends, and has been deprecated.
94 Please remove all Build.PL files and only use the Makefile.PL installer.
102 # To save some more typing in Module::Install installers, every...
103 # use inc::Module::Install
104 # ...also acts as an implicit use strict.
105 $^H |= strict::bits(qw(refs subs vars));
118 my $who = $self->_caller;
119 my $cwd = Cwd::cwd();
120 my $sym = "${who}::AUTOLOAD";
122 my $pwd = Cwd::cwd();
123 if ( my $code = $sym->{$pwd} ) {
124 # delegate back to parent dirs
125 goto &$code unless $cwd eq $pwd;
127 $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
128 unless ( uc($1) eq $1 ) {
129 unshift @_, ( $self, $1 );
130 goto &{$self->can('call')};
137 my $self = $class->new(@_);
138 my $who = $self->_caller;
140 unless ( -f $self->{file} ) {
141 require "$self->{path}/$self->{dispatch}.pm";
142 File::Path::mkpath("$self->{prefix}/$self->{author}");
143 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
144 $self->{admin}->init;
145 @_ = ($class, _self => $self);
146 goto &{"$self->{name}::import"};
149 *{"${who}::AUTOLOAD"} = $self->autoload;
152 # Unregister loader and worker packages so subdirs can use them again
153 delete $INC{"$self->{file}"};
154 delete $INC{"$self->{path}.pm"};
161 unless ( $self->{extensions} ) {
162 $self->load_extensions(
163 "$self->{prefix}/$self->{path}", $self
167 my @exts = @{$self->{extensions}};
169 my $admin = $self->{admin};
170 @exts = $admin->load_all_extensions;
174 foreach my $obj ( @exts ) {
175 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
176 next unless $obj->can($method);
177 next if $method =~ /^_/;
178 next if $method eq uc($method);
183 my $who = $self->_caller;
184 foreach my $name ( sort keys %seen ) {
185 *{"${who}::$name"} = sub {
186 ${"${who}::AUTOLOAD"} = "${who}::$name";
187 goto &{"${who}::AUTOLOAD"};
193 my ($class, %args) = @_;
195 # ignore the prefix on extension modules built from top level.
196 my $base_path = Cwd::abs_path($FindBin::Bin);
197 unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
198 delete $args{prefix};
201 return $args{_self} if $args{_self};
203 $args{dispatch} ||= 'Admin';
204 $args{prefix} ||= 'inc';
205 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
206 $args{bundle} ||= 'inc/BUNDLES';
207 $args{base} ||= $base_path;
208 $class =~ s/^\Q$args{prefix}\E:://;
209 $args{name} ||= $class;
210 $args{version} ||= $class->VERSION;
211 unless ( $args{path} ) {
212 $args{path} = $args{name};
213 $args{path} =~ s!::!/!g;
215 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
218 bless( \%args, $class );
222 my ($self, $method) = @_;
223 my $obj = $self->load($method) or return;
224 splice(@_, 0, 2, $obj);
225 goto &{$obj->can($method)};
229 my ($self, $method) = @_;
231 $self->load_extensions(
232 "$self->{prefix}/$self->{path}", $self
233 ) unless $self->{extensions};
235 foreach my $obj (@{$self->{extensions}}) {
236 return $obj if $obj->can($method);
239 my $admin = $self->{admin} or die <<"END_DIE";
240 The '$method' method does not exist in the '$self->{prefix}' path!
241 Please remove the '$self->{prefix}' directory and run $0 again to load it.
244 my $obj = $admin->load($method, 1);
245 push @{$self->{extensions}}, $obj;
250 sub load_extensions {
251 my ($self, $path, $top) = @_;
253 unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
254 unshift @INC, $self->{prefix};
257 foreach my $rv ( $self->find_extensions($path) ) {
258 my ($file, $pkg) = @{$rv};
259 next if $self->{pathnames}{$pkg};
262 my $new = eval { require $file; $pkg->can('new') };
267 $self->{pathnames}{$pkg} = delete $INC{$file};
268 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
271 $self->{extensions} ||= [];
274 sub find_extensions {
275 my ($self, $path) = @_;
278 File::Find::find( sub {
279 my $file = $File::Find::name;
280 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
282 return if lc($subpath) eq lc($self->{dispatch});
284 $file = "$self->{path}/$subpath.pm";
285 my $pkg = "$self->{name}::$subpath";
288 # If we have a mixed-case package name, assume case has been preserved
289 # correctly. Otherwise, root through the file to locate the case-preserved
290 # version of the package name.
291 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
292 my $content = Module::Install::_read($subpath . '.pm');
294 foreach ( split //, $content ) {
295 $in_pod = 1 if /^=\w/;
296 $in_pod = 0 if /^=cut/;
297 next if ($in_pod || /^=cut/); # skip pod text
298 next if /^\s*#/; # and comments
299 if ( m/^\s*package\s+($pkg)\s*;/i ) {
306 push @found, [ $file, $pkg ];
307 }, $path ) if -d $path;
316 #####################################################################
321 my $call = caller($depth);
322 while ( $call eq __PACKAGE__ ) {
324 $call = caller($depth);
331 open FH, "< $_[0]" or die "open($_[0]): $!";
332 my $str = do { local $/; <FH> };
333 close FH or die "close($_[0]): $!";
339 open FH, "> $_[0]" or die "open($_[0]): $!";
340 foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
341 close FH or die "close($_[0]): $!";
344 # _version is for processing module versions (eg, 1.03_05) not
345 # Perl versions (eg, 5.8.1).
351 my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
352 $l = $l . '.' . join '', @v if @v;
356 # Cloned from Params::Util::_CLASS
363 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
369 # Copyright 2008 Adam Kennedy.