inc/Module/Install.pm

#line 1
package Module::Install;

# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
#     3. The installed version of inc::Module::Install loads
#     4. inc::Module::Install calls "require Module::Install"
#     5. The ./inc/ version of Module::Install loads
# } ELSE {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
#     3. The ./inc/ version of Module::Install loads
# }

BEGIN {
        require 5.004;
}
use strict 'vars';

use vars qw{$VERSION};
BEGIN {
        # All Module::Install core packages now require synchronised versions.
        # This will be used to ensure we don't accidentally load old or
        # different versions of modules.
        # This is not enforced yet, but will be some time in the next few
        # releases once we can make sure it won't clash with custom
        # Module::Install extensions.
        $VERSION = '0.76';

        *inc::Module::Install::VERSION = *VERSION;
        @inc::Module::Install::ISA     = __PACKAGE__;

}


# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }

Please invoke ${\__PACKAGE__} with:

        use inc::${\__PACKAGE__};

not:

        use ${\__PACKAGE__};

END_DIE


# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }

Your installer $0 has a modification time in the future.

This is known to create infinite loops in make.

Please correct this, then run $0 again.

END_DIE


# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }

Module::Install no longer supports Build.PL.

It was impossible to maintain duel backends, and has been deprecated.

Please remove all Build.PL files and only use the Makefile.PL installer.

END_DIE


# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));


use Cwd        ();
use File::Find ();
use File::Path ();
use FindBin;

sub autoload {
        my $self = shift;
        my $who  = $self->_caller;
        my $cwd  = Cwd::cwd();
        my $sym  = "${who}::AUTOLOAD";
        $sym->{$cwd} = sub {
                my $pwd = Cwd::cwd();
                if ( my $code = $sym->{$pwd} ) {
                        # delegate back to parent dirs
                        goto &$code unless $cwd eq $pwd;
                }
                $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
                unshift @_, ( $self, $1 );
                goto &{$self->can('call')} unless uc($1) eq $1;
        };
}

sub import {
        my $class = shift;
        my $self  = $class->new(@_);
        my $who   = $self->_caller;

        unless ( -f $self->{file} ) {
                require "$self->{path}/$self->{dispatch}.pm";
                File::Path::mkpath("$self->{prefix}/$self->{author}");
                $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
                $self->{admin}->init;
                @_ = ($class, _self => $self);
                goto &{"$self->{name}::import"};
        }

        *{"${who}::AUTOLOAD"} = $self->autoload;
        $self->preload;

        # Unregister loader and worker packages so subdirs can use them again
        delete $INC{"$self->{file}"};
        delete $INC{"$self->{path}.pm"};

        return 1;
}

sub preload {
        my $self = shift;
        unless ( $self->{extensions} ) {
                $self->load_extensions(
                        "$self->{prefix}/$self->{path}", $self
                );
        }

        my @exts = @{$self->{extensions}};
        unless ( @exts ) {
                my $admin = $self->{admin};
                @exts = $admin->load_all_extensions;
        }

        my %seen;
        foreach my $obj ( @exts ) {
                while (my ($method, $glob) = each %{ref($obj) . '::'}) {
                        next unless $obj->can($method);
                        next if $method =~ /^_/;
                        next if $method eq uc($method);
                        $seen{$method}++;
                }
        }

        my $who = $self->_caller;
        foreach my $name ( sort keys %seen ) {
                *{"${who}::$name"} = sub {
                        ${"${who}::AUTOLOAD"} = "${who}::$name";
                        goto &{"${who}::AUTOLOAD"};
                };
        }
}

sub new {
        my ($class, %args) = @_;

        # ignore the prefix on extension modules built from top level.
        my $base_path = Cwd::abs_path($FindBin::Bin);
        unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
                delete $args{prefix};
        }

        return $args{_self} if $args{_self};

        $args{dispatch} ||= 'Admin';
        $args{prefix}   ||= 'inc';
        $args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
        $args{bundle}   ||= 'inc/BUNDLES';
        $args{base}     ||= $base_path;
        $class =~ s/^\Q$args{prefix}\E:://;
        $args{name}     ||= $class;
        $args{version}  ||= $class->VERSION;
        unless ( $args{path} ) {
                $args{path}  = $args{name};
                $args{path}  =~ s!::!/!g;
        }
        $args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
        $args{wrote}      = 0;

        bless( \%args, $class );
}

sub call {
        my ($self, $method) = @_;
        my $obj = $self->load($method) or return;
        splice(@_, 0, 2, $obj);
        goto &{$obj->can($method)};
}

sub load {
        my ($self, $method) = @_;

        $self->load_extensions(
                "$self->{prefix}/$self->{path}", $self
        ) unless $self->{extensions};

        foreach my $obj (@{$self->{extensions}}) {
                return $obj if $obj->can($method);
        }

        my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE

        my $obj = $admin->load($method, 1);
        push @{$self->{extensions}}, $obj;

        $obj;
}

sub load_extensions {
        my ($self, $path, $top) = @_;

        unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
                unshift @INC, $self->{prefix};
        }

        foreach my $rv ( $self->find_extensions($path) ) {
                my ($file, $pkg) = @{$rv};
                next if $self->{pathnames}{$pkg};

                local $@;
                my $new = eval { require $file; $pkg->can('new') };
                unless ( $new ) {
                        warn $@ if $@;
                        next;
                }
                $self->{pathnames}{$pkg} = delete $INC{$file};
                push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
        }

        $self->{extensions} ||= [];
}

sub find_extensions {
        my ($self, $path) = @_;

        my @found;
        File::Find::find( sub {
                my $file = $File::Find::name;
                return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
                my $subpath = $1;
                return if lc($subpath) eq lc($self->{dispatch});

                $file = "$self->{path}/$subpath.pm";
                my $pkg = "$self->{name}::$subpath";
                $pkg =~ s!/!::!g;

                # If we have a mixed-case package name, assume case has been preserved
                # correctly.  Otherwise, root through the file to locate the case-preserved
                # version of the package name.
                if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
                        my $content = Module::Install::_read($subpath . '.pm');
                        my $in_pod  = 0;
                        foreach ( split //, $content ) {
                                $in_pod = 1 if /^=\w/;
                                $in_pod = 0 if /^=cut/;
                                next if ($in_pod || /^=cut/);  # skip pod text
                                next if /^\s*#/;               # and comments
                                if ( m/^\s*package\s+($pkg)\s*;/i ) {
                                        $pkg = $1;
                                        last;
                                }
                        }
                }

                push @found, [ $file, $pkg ];
        }, $path ) if -d $path;

        @found;
}


#####################################################################
# Utility Functions

sub _caller {
        my $depth = 0;
        my $call  = caller($depth);
        while ( $call eq __PACKAGE__ ) {
                $depth++;
                $call = caller($depth);
        }
        return $call;
}

sub _read {
        local *FH;
        open FH, "< $_[0]" or die "open($_[0]): $!";
        my $str = do { local $/; <FH> };
        close FH or die "close($_[0]): $!";
        return $str;
}

sub _write {
        local *FH;
        open FH, "> $_[0]" or die "open($_[0]): $!";
        foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
        close FH or die "close($_[0]): $!";
}

sub _version ($) {
        my $s = shift || 0;
           $s =~ s/^(\d+)\.?//;
        my $l = $1 || 0;
        my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
           $l = $l . '.' . join '', @v if @v;
        return $l + 0;
}

# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
        (
                defined $_[0]
                and
                ! ref $_[0]
                and
                $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
        ) ? $_[0] : undef;
}

1;

# Copyright 2008 Adam Kennedy.
1	dpavlin	34	#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	dpavlin	52	BEGIN {
21			require 5.004;
22			}
23	dpavlin	34	use strict 'vars';
24
25			use vars qw{$VERSION};
26			BEGIN {
27	dpavlin	52	# 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.
33			$VERSION = '0.76';
34
35			inc::Module::Install::VERSION = VERSION;
36			@inc::Module::Install::ISA = __PACKAGE__;
37
38	dpavlin	34	}
39
40	dpavlin	52
41
42
43
44	dpavlin	34	# 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	dpavlin	52	unless ( $INC{$file} ) { die <<"END_DIE" }
52
53	dpavlin	34	Please invoke ${\__PACKAGE__} with:
54
55	dpavlin	52	use inc::${\__PACKAGE__};
56	dpavlin	34
57			not:
58
59	dpavlin	52	use ${\__PACKAGE__};
60	dpavlin	34
61			END_DIE
62
63	dpavlin	52
64
65
66
67	dpavlin	34	# 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	dpavlin	52	if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
73
74	dpavlin	34	Your installer $0 has a modification time in the future.
75
76			This is known to create infinite loops in make.
77
78			Please correct this, then run $0 again.
79
80			END_DIE
81
82	dpavlin	52
83
84
85
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" }
89
90			Module::Install no longer supports Build.PL.
91
92			It was impossible to maintain duel backends, and has been deprecated.
93
94			Please remove all Build.PL files and only use the Makefile.PL installer.
95
96			END_DIE
97
98
99
100
101
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));
106
107
108
109
110
111	dpavlin	34	use Cwd ();
112			use File::Find ();
113			use File::Path ();
114			use FindBin;
115
116			sub autoload {
117	dpavlin	52	my $self = shift;
118			my $who = $self->_caller;
119			my $cwd = Cwd::cwd();
120			my $sym = "${who}::AUTOLOAD";
121			$sym->{$cwd} = sub {
122			my $pwd = Cwd::cwd();
123			if ( my $code = $sym->{$pwd} ) {
124			# delegate back to parent dirs
125			goto &$code unless $cwd eq $pwd;
126			}
127			$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
128			unshift @_, ( $self, $1 );
129			goto &{$self->can('call')} unless uc($1) eq $1;
130			};
131	dpavlin	34	}
132
133			sub import {
134	dpavlin	52	my $class = shift;
135			my $self = $class->new(@_);
136			my $who = $self->_caller;
137	dpavlin	34
138	dpavlin	52	unless ( -f $self->{file} ) {
139			require "$self->{path}/$self->{dispatch}.pm";
140			File::Path::mkpath("$self->{prefix}/$self->{author}");
141			$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
142			$self->{admin}->init;
143			@_ = ($class, _self => $self);
144			goto &{"$self->{name}::import"};
145			}
146	dpavlin	34
147	dpavlin	52	*{"${who}::AUTOLOAD"} = $self->autoload;
148			$self->preload;
149	dpavlin	34
150	dpavlin	52	# Unregister loader and worker packages so subdirs can use them again
151			delete $INC{"$self->{file}"};
152			delete $INC{"$self->{path}.pm"};
153
154			return 1;
155	dpavlin	34	}
156
157			sub preload {
158	dpavlin	52	my $self = shift;
159			unless ( $self->{extensions} ) {
160			$self->load_extensions(
161			"$self->{prefix}/$self->{path}", $self
162			);
163			}
164	dpavlin	34
165	dpavlin	52	my @exts = @{$self->{extensions}};
166			unless ( @exts ) {
167			my $admin = $self->{admin};
168			@exts = $admin->load_all_extensions;
169			}
170	dpavlin	34
171	dpavlin	52	my %seen;
172			foreach my $obj ( @exts ) {
173			while (my ($method, $glob) = each %{ref($obj) . '::'}) {
174			next unless $obj->can($method);
175			next if $method =~ /^_/;
176			next if $method eq uc($method);
177			$seen{$method}++;
178			}
179			}
180	dpavlin	34
181	dpavlin	52	my $who = $self->_caller;
182			foreach my $name ( sort keys %seen ) {
183			*{"${who}::$name"} = sub {
184			${"${who}::AUTOLOAD"} = "${who}::$name";
185			goto &{"${who}::AUTOLOAD"};
186			};
187			}
188	dpavlin	34	}
189
190			sub new {
191	dpavlin	52	my ($class, %args) = @_;
192	dpavlin	34
193	dpavlin	52	# ignore the prefix on extension modules built from top level.
194			my $base_path = Cwd::abs_path($FindBin::Bin);
195			unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
196			delete $args{prefix};
197			}
198	dpavlin	34
199	dpavlin	52	return $args{_self} if $args{_self};
200	dpavlin	34
201	dpavlin	52	$args{dispatch} \|\|= 'Admin';
202			$args{prefix} \|\|= 'inc';
203			$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
204			$args{bundle} \|\|= 'inc/BUNDLES';
205			$args{base} \|\|= $base_path;
206			$class =~ s/^\Q$args{prefix}\E:://;
207			$args{name} \|\|= $class;
208			$args{version} \|\|= $class->VERSION;
209			unless ( $args{path} ) {
210			$args{path} = $args{name};
211			$args{path} =~ s!::!/!g;
212			}
213			$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
214			$args{wrote} = 0;
215	dpavlin	34
216	dpavlin	52	bless( \%args, $class );
217	dpavlin	34	}
218
219			sub call {
220			my ($self, $method) = @_;
221			my $obj = $self->load($method) or return;
222			splice(@_, 0, 2, $obj);
223			goto &{$obj->can($method)};
224			}
225
226			sub load {
227	dpavlin	52	my ($self, $method) = @_;
228	dpavlin	34
229	dpavlin	52	$self->load_extensions(
230			"$self->{prefix}/$self->{path}", $self
231			) unless $self->{extensions};
232	dpavlin	34
233	dpavlin	52	foreach my $obj (@{$self->{extensions}}) {
234			return $obj if $obj->can($method);
235			}
236	dpavlin	34
237	dpavlin	52	my $admin = $self->{admin} or die <<"END_DIE";
238	dpavlin	34	The '$method' method does not exist in the '$self->{prefix}' path!
239			Please remove the '$self->{prefix}' directory and run $0 again to load it.
240			END_DIE
241
242	dpavlin	52	my $obj = $admin->load($method, 1);
243			push @{$self->{extensions}}, $obj;
244	dpavlin	34
245	dpavlin	52	$obj;
246	dpavlin	34	}
247
248			sub load_extensions {
249	dpavlin	52	my ($self, $path, $top) = @_;
250	dpavlin	34
251	dpavlin	52	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
252			unshift @INC, $self->{prefix};
253			}
254	dpavlin	34
255	dpavlin	52	foreach my $rv ( $self->find_extensions($path) ) {
256			my ($file, $pkg) = @{$rv};
257			next if $self->{pathnames}{$pkg};
258	dpavlin	34
259	dpavlin	52	local $@;
260			my $new = eval { require $file; $pkg->can('new') };
261			unless ( $new ) {
262			warn $@ if $@;
263			next;
264			}
265			$self->{pathnames}{$pkg} = delete $INC{$file};
266			push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
267			}
268	dpavlin	34
269	dpavlin	52	$self->{extensions} \|\|= [];
270	dpavlin	34	}
271
272			sub find_extensions {
273	dpavlin	52	my ($self, $path) = @_;
274	dpavlin	34
275	dpavlin	52	my @found;
276			File::Find::find( sub {
277			my $file = $File::Find::name;
278			return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
279			my $subpath = $1;
280			return if lc($subpath) eq lc($self->{dispatch});
281	dpavlin	34
282	dpavlin	52	$file = "$self->{path}/$subpath.pm";
283			my $pkg = "$self->{name}::$subpath";
284			$pkg =~ s!/!::!g;
285	dpavlin	34
286	dpavlin	52	# If we have a mixed-case package name, assume case has been preserved
287			# correctly. Otherwise, root through the file to locate the case-preserved
288			# version of the package name.
289			if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
290			my $content = Module::Install::_read($subpath . '.pm');
291			my $in_pod = 0;
292			foreach ( split //, $content ) {
293			$in_pod = 1 if /^=\w/;
294			$in_pod = 0 if /^=cut/;
295			next if ($in_pod \|\| /^=cut/); # skip pod text
296			next if /^\s*#/; # and comments
297			if ( m/^\spackage\s+($pkg)\s;/i ) {
298			$pkg = $1;
299			last;
300			}
301			}
302			}
303	dpavlin	34
304	dpavlin	52	push @found, [ $file, $pkg ];
305			}, $path ) if -d $path;
306	dpavlin	34
307	dpavlin	52	@found;
308	dpavlin	34	}
309
310	dpavlin	52
311
312
313
314			#####################################################################
315			# Utility Functions
316
317	dpavlin	34	sub _caller {
318	dpavlin	52	my $depth = 0;
319			my $call = caller($depth);
320			while ( $call eq __PACKAGE__ ) {
321			$depth++;
322			$call = caller($depth);
323			}
324			return $call;
325	dpavlin	34	}
326
327	dpavlin	52	sub _read {
328			local *FH;
329			open FH, "< $_[0]" or die "open($_[0]): $!";
330			my $str = do { local $/; <FH> };
331			close FH or die "close($_[0]): $!";
332			return $str;
333			}
334
335			sub _write {
336			local *FH;
337			open FH, "> $_[0]" or die "open($_[0]): $!";
338			foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
339			close FH or die "close($_[0]): $!";
340			}
341
342			sub _version ($) {
343			my $s = shift \|\| 0;
344			$s =~ s/^(\d+)\.?//;
345			my $l = $1 \|\| 0;
346			my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
347			$l = $l . '.' . join '', @v if @v;
348			return $l + 0;
349			}
350
351			# Cloned from Params::Util::_CLASS
352			sub _CLASS ($) {
353			(
354			defined $_[0]
355			and
356			! ref $_[0]
357			and
358			$_[0] =~ m/^[^\W\d]\w(?:::\w+)$/s
359			) ? $_[0] : undef;
360			}
361
362	dpavlin	34	1;
363	dpavlin	52
364			# Copyright 2008 Adam Kennedy.