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	#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	BEGIN {
21	require 5.004;
22	}
23	use strict 'vars';
24
25	use vars qw{$VERSION};
26	BEGIN {
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.
33	$VERSION = '0.76';
34
35	inc::Module::Install::VERSION = VERSION;
36	@inc::Module::Install::ISA = __PACKAGE__;
37
38	}
39
40
41
42
43
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" }
52
53	Please invoke ${\__PACKAGE__} with:
54
55	use inc::${\__PACKAGE__};
56
57	not:
58
59	use ${\__PACKAGE__};
60
61	END_DIE
62
63
64
65
66
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" }
73
74	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
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	use Cwd ();
112	use File::Find ();
113	use File::Path ();
114	use FindBin;
115
116	sub autoload {
117	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	}
132
133	sub import {
134	my $class = shift;
135	my $self = $class->new(@_);
136	my $who = $self->_caller;
137
138	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
147	*{"${who}::AUTOLOAD"} = $self->autoload;
148	$self->preload;
149
150	# 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	}
156
157	sub preload {
158	my $self = shift;
159	unless ( $self->{extensions} ) {
160	$self->load_extensions(
161	"$self->{prefix}/$self->{path}", $self
162	);
163	}
164
165	my @exts = @{$self->{extensions}};
166	unless ( @exts ) {
167	my $admin = $self->{admin};
168	@exts = $admin->load_all_extensions;
169	}
170
171	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
181	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	}
189
190	sub new {
191	my ($class, %args) = @_;
192
193	# 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
199	return $args{_self} if $args{_self};
200
201	$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
216	bless( \%args, $class );
217	}
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	my ($self, $method) = @_;
228
229	$self->load_extensions(
230	"$self->{prefix}/$self->{path}", $self
231	) unless $self->{extensions};
232
233	foreach my $obj (@{$self->{extensions}}) {
234	return $obj if $obj->can($method);
235	}
236
237	my $admin = $self->{admin} or die <<"END_DIE";
238	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	my $obj = $admin->load($method, 1);
243	push @{$self->{extensions}}, $obj;
244
245	$obj;
246	}
247
248	sub load_extensions {
249	my ($self, $path, $top) = @_;
250
251	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
252	unshift @INC, $self->{prefix};
253	}
254
255	foreach my $rv ( $self->find_extensions($path) ) {
256	my ($file, $pkg) = @{$rv};
257	next if $self->{pathnames}{$pkg};
258
259	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
269	$self->{extensions} \|\|= [];
270	}
271
272	sub find_extensions {
273	my ($self, $path) = @_;
274
275	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
282	$file = "$self->{path}/$subpath.pm";
283	my $pkg = "$self->{name}::$subpath";
284	$pkg =~ s!/!::!g;
285
286	# 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
304	push @found, [ $file, $pkg ];
305	}, $path ) if -d $path;
306
307	@found;
308	}
309
310
311
312
313
314	#####################################################################
315	# Utility Functions
316
317	sub _caller {
318	my $depth = 0;
319	my $call = caller($depth);
320	while ( $call eq __PACKAGE__ ) {
321	$depth++;
322	$call = caller($depth);
323	}
324	return $call;
325	}
326
327	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	1;
363
364	# Copyright 2008 Adam Kennedy.