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.77';
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		unless ( uc($1) eq $1 ) {
129			unshift @_, ( $self, $1 );
130			goto &{$self->can('call')};
131		}
132	};
133}
134
135sub import {
136	my $class = shift;
137	my $self  = $class->new(@_);
138	my $who   = $self->_caller;
139
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"};
147	}
148
149	*{"${who}::AUTOLOAD"} = $self->autoload;
150	$self->preload;
151
152	# Unregister loader and worker packages so subdirs can use them again
153	delete $INC{"$self->{file}"};
154	delete $INC{"$self->{path}.pm"};
155
156	return 1;
157}
158
159sub preload {
160	my $self = shift;
161	unless ( $self->{extensions} ) {
162		$self->load_extensions(
163			"$self->{prefix}/$self->{path}", $self
164		);
165	}
166
167	my @exts = @{$self->{extensions}};
168	unless ( @exts ) {
169		my $admin = $self->{admin};
170		@exts = $admin->load_all_extensions;
171	}
172
173	my %seen;
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);
179			$seen{$method}++;
180		}
181	}
182
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"};
188		};
189	}
190}
191
192sub new {
193	my ($class, %args) = @_;
194
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};
199	}
200
201	return $args{_self} if $args{_self};
202
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;
214	}
215	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
216	$args{wrote}      = 0;
217
218	bless( \%args, $class );
219}
220
221sub call {
222	my ($self, $method) = @_;
223	my $obj = $self->load($method) or return;
224        splice(@_, 0, 2, $obj);
225	goto &{$obj->can($method)};
226}
227
228sub load {
229	my ($self, $method) = @_;
230
231	$self->load_extensions(
232		"$self->{prefix}/$self->{path}", $self
233	) unless $self->{extensions};
234
235	foreach my $obj (@{$self->{extensions}}) {
236		return $obj if $obj->can($method);
237	}
238
239	my $admin = $self->{admin} or die <<"END_DIE";
240The '$method' method does not exist in the '$self->{prefix}' path!
241Please remove the '$self->{prefix}' directory and run $0 again to load it.
242END_DIE
243
244	my $obj = $admin->load($method, 1);
245	push @{$self->{extensions}}, $obj;
246
247	$obj;
248}
249
250sub load_extensions {
251	my ($self, $path, $top) = @_;
252
253	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
254		unshift @INC, $self->{prefix};
255	}
256
257	foreach my $rv ( $self->find_extensions($path) ) {
258		my ($file, $pkg) = @{$rv};
259		next if $self->{pathnames}{$pkg};
260
261		local $@;
262		my $new = eval { require $file; $pkg->can('new') };
263		unless ( $new ) {
264			warn $@ if $@;
265			next;
266		}
267		$self->{pathnames}{$pkg} = delete $INC{$file};
268		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
269	}
270
271	$self->{extensions} ||= [];
272}
273
274sub find_extensions {
275	my ($self, $path) = @_;
276
277	my @found;
278	File::Find::find( sub {
279		my $file = $File::Find::name;
280		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
281		my $subpath = $1;
282		return if lc($subpath) eq lc($self->{dispatch});
283
284		$file = "$self->{path}/$subpath.pm";
285		my $pkg = "$self->{name}::$subpath";
286		$pkg =~ s!/!::!g;
287
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');
293			my $in_pod  = 0;
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 ) {
300					$pkg = $1;
301					last;
302				}
303			}
304		}
305
306		push @found, [ $file, $pkg ];
307	}, $path ) if -d $path;
308
309	@found;
310}
311
312
313
314
315
316#####################################################################
317# Utility Functions
318
319sub _caller {
320	my $depth = 0;
321	my $call  = caller($depth);
322	while ( $call eq __PACKAGE__ ) {
323		$depth++;
324		$call = caller($depth);
325	}
326	return $call;
327}
328
329sub _read {
330	local *FH;
331	open FH, "< $_[0]" or die "open($_[0]): $!";
332	my $str = do { local $/; <FH> };
333	close FH or die "close($_[0]): $!";
334	return $str;
335}
336
337sub _write {
338	local *FH;
339	open FH, "> $_[0]" or die "open($_[0]): $!";
340	foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
341	close FH or die "close($_[0]): $!";
342}
343
344# _version is for processing module versions (eg, 1.03_05) not
345# Perl versions (eg, 5.8.1).
346
347sub _version ($) {
348	my $s = shift || 0;
349	   $s =~ s/^(\d+)\.?//;
350	my $l = $1 || 0;
351	my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
352	   $l = $l . '.' . join '', @v if @v;
353	return $l + 0;
354}
355
356# Cloned from Params::Util::_CLASS
357sub _CLASS ($) {
358	(
359		defined $_[0]
360		and
361		! ref $_[0]
362		and
363		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
364	) ? $_[0] : undef;
365}
366
3671;
368
369# Copyright 2008 Adam Kennedy.
370