1#line 1
2package 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
20BEGIN {
21	require 5.004;
22}
23use strict 'vars';
24
25use vars qw{$VERSION};
26BEGIN {
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.
50my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
51unless ( $INC{$file} ) { die <<"END_DIE" }
52
53Please invoke ${\__PACKAGE__} with:
54
55	use inc::${\__PACKAGE__};
56
57not:
58
59	use ${\__PACKAGE__};
60
61END_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.
72if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
73
74Your installer $0 has a modification time in the future.
75
76This is known to create infinite loops in make.
77
78Please correct this, then run $0 again.
79
80END_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.
88if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
89
90Module::Install no longer supports Build.PL.
91
92It was impossible to maintain duel backends, and has been deprecated.
93
94Please remove all Build.PL files and only use the Makefile.PL installer.
95
96END_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
111use Cwd        ();
112use File::Find ();
113use File::Path ();
114use FindBin;
115
116sub 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
133sub 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
157sub 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
190sub 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
219sub 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
226sub 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";
238The '$method' method does not exist in the '$self->{prefix}' path!
239Please remove the '$self->{prefix}' directory and run $0 again to load it.
240END_DIE
241
242	my $obj = $admin->load($method, 1);
243	push @{$self->{extensions}}, $obj;
244
245	$obj;
246}
247
248sub 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
272sub 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/^\s*package\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
317sub _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
327sub _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
335sub _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
342sub _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
352sub _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
3621;
363
364# Copyright 2008 Adam Kennedy.
365