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
20use 5.005;
21use strict 'vars';
22
23use vars qw{$VERSION $MAIN};
24BEGIN {
25	# All Module::Install core packages now require synchronised versions.
26	# This will be used to ensure we don't accidentally load old or
27	# different versions of modules.
28	# This is not enforced yet, but will be some time in the next few
29	# releases once we can make sure it won't clash with custom
30	# Module::Install extensions.
31	$VERSION = '0.93';
32
33	# Storage for the pseudo-singleton
34	$MAIN    = undef;
35
36	*inc::Module::Install::VERSION = *VERSION;
37	@inc::Module::Install::ISA     = __PACKAGE__;
38
39}
40
41
42
43
44
45# Whether or not inc::Module::Install is actually loaded, the
46# $INC{inc/Module/Install.pm} is what will still get set as long as
47# the caller loaded module this in the documented manner.
48# If not set, the caller may NOT have loaded the bundled version, and thus
49# they may not have a MI version that works with the Makefile.PL. This would
50# result in false errors or unexpected behaviour. And we don't want that.
51my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
52unless ( $INC{$file} ) { die <<"END_DIE" }
53
54Please invoke ${\__PACKAGE__} with:
55
56	use inc::${\__PACKAGE__};
57
58not:
59
60	use ${\__PACKAGE__};
61
62END_DIE
63
64
65
66
67
68# If the script that is loading Module::Install is from the future,
69# then make will detect this and cause it to re-run over and over
70# again. This is bad. Rather than taking action to touch it (which
71# is unreliable on some platforms and requires write permissions)
72# for now we should catch this and refuse to run.
73if ( -f $0 ) {
74	my $s = (stat($0))[9];
75
76	# If the modification time is only slightly in the future,
77	# sleep briefly to remove the problem.
78	my $a = $s - time;
79	if ( $a > 0 and $a < 5 ) { sleep 5 }
80
81	# Too far in the future, throw an error.
82	my $t = time;
83	if ( $s > $t ) { die <<"END_DIE" }
84
85Your installer $0 has a modification time in the future ($s > $t).
86
87This is known to create infinite loops in make.
88
89Please correct this, then run $0 again.
90
91END_DIE
92}
93
94
95
96
97
98# Build.PL was formerly supported, but no longer is due to excessive
99# difficulty in implementing every single feature twice.
100if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
101
102Module::Install no longer supports Build.PL.
103
104It was impossible to maintain duel backends, and has been deprecated.
105
106Please remove all Build.PL files and only use the Makefile.PL installer.
107
108END_DIE
109
110
111
112
113
114# To save some more typing in Module::Install installers, every...
115# use inc::Module::Install
116# ...also acts as an implicit use strict.
117$^H |= strict::bits(qw(refs subs vars));
118
119
120
121
122
123use Cwd        ();
124use File::Find ();
125use File::Path ();
126use FindBin;
127
128sub autoload {
129	my $self = shift;
130	my $who  = $self->_caller;
131	my $cwd  = Cwd::cwd();
132	my $sym  = "${who}::AUTOLOAD";
133	$sym->{$cwd} = sub {
134		my $pwd = Cwd::cwd();
135		if ( my $code = $sym->{$pwd} ) {
136			# Delegate back to parent dirs
137			goto &$code unless $cwd eq $pwd;
138		}
139		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
140		my $method = $1;
141		if ( uc($method) eq $method ) {
142			# Do nothing
143			return;
144		} elsif ( $method =~ /^_/ and $self->can($method) ) {
145			# Dispatch to the root M:I class
146			return $self->$method(@_);
147		}
148
149		# Dispatch to the appropriate plugin
150		unshift @_, ( $self, $1 );
151		goto &{$self->can('call')};
152	};
153}
154
155sub import {
156	my $class = shift;
157	my $self  = $class->new(@_);
158	my $who   = $self->_caller;
159
160	unless ( -f $self->{file} ) {
161		require "$self->{path}/$self->{dispatch}.pm";
162		File::Path::mkpath("$self->{prefix}/$self->{author}");
163		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
164		$self->{admin}->init;
165		@_ = ($class, _self => $self);
166		goto &{"$self->{name}::import"};
167	}
168
169	*{"${who}::AUTOLOAD"} = $self->autoload;
170	$self->preload;
171
172	# Unregister loader and worker packages so subdirs can use them again
173	delete $INC{"$self->{file}"};
174	delete $INC{"$self->{path}.pm"};
175
176	# Save to the singleton
177	$MAIN = $self;
178
179	return 1;
180}
181
182sub preload {
183	my $self = shift;
184	unless ( $self->{extensions} ) {
185		$self->load_extensions(
186			"$self->{prefix}/$self->{path}", $self
187		);
188	}
189
190	my @exts = @{$self->{extensions}};
191	unless ( @exts ) {
192		@exts = $self->{admin}->load_all_extensions;
193	}
194
195	my %seen;
196	foreach my $obj ( @exts ) {
197		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
198			next unless $obj->can($method);
199			next if $method =~ /^_/;
200			next if $method eq uc($method);
201			$seen{$method}++;
202		}
203	}
204
205	my $who = $self->_caller;
206	foreach my $name ( sort keys %seen ) {
207		*{"${who}::$name"} = sub {
208			${"${who}::AUTOLOAD"} = "${who}::$name";
209			goto &{"${who}::AUTOLOAD"};
210		};
211	}
212}
213
214sub new {
215	my ($class, %args) = @_;
216
217	# ignore the prefix on extension modules built from top level.
218	my $base_path = Cwd::abs_path($FindBin::Bin);
219	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
220		delete $args{prefix};
221	}
222
223	return $args{_self} if $args{_self};
224
225	$args{dispatch} ||= 'Admin';
226	$args{prefix}   ||= 'inc';
227	$args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
228	$args{bundle}   ||= 'inc/BUNDLES';
229	$args{base}     ||= $base_path;
230	$class =~ s/^\Q$args{prefix}\E:://;
231	$args{name}     ||= $class;
232	$args{version}  ||= $class->VERSION;
233	unless ( $args{path} ) {
234		$args{path}  = $args{name};
235		$args{path}  =~ s!::!/!g;
236	}
237	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
238	$args{wrote}      = 0;
239
240	bless( \%args, $class );
241}
242
243sub call {
244	my ($self, $method) = @_;
245	my $obj = $self->load($method) or return;
246        splice(@_, 0, 2, $obj);
247	goto &{$obj->can($method)};
248}
249
250sub load {
251	my ($self, $method) = @_;
252
253	$self->load_extensions(
254		"$self->{prefix}/$self->{path}", $self
255	) unless $self->{extensions};
256
257	foreach my $obj (@{$self->{extensions}}) {
258		return $obj if $obj->can($method);
259	}
260
261	my $admin = $self->{admin} or die <<"END_DIE";
262The '$method' method does not exist in the '$self->{prefix}' path!
263Please remove the '$self->{prefix}' directory and run $0 again to load it.
264END_DIE
265
266	my $obj = $admin->load($method, 1);
267	push @{$self->{extensions}}, $obj;
268
269	$obj;
270}
271
272sub load_extensions {
273	my ($self, $path, $top) = @_;
274
275	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
276		unshift @INC, $self->{prefix};
277	}
278
279	foreach my $rv ( $self->find_extensions($path) ) {
280		my ($file, $pkg) = @{$rv};
281		next if $self->{pathnames}{$pkg};
282
283		local $@;
284		my $new = eval { require $file; $pkg->can('new') };
285		unless ( $new ) {
286			warn $@ if $@;
287			next;
288		}
289		$self->{pathnames}{$pkg} = delete $INC{$file};
290		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
291	}
292
293	$self->{extensions} ||= [];
294}
295
296sub find_extensions {
297	my ($self, $path) = @_;
298
299	my @found;
300	File::Find::find( sub {
301		my $file = $File::Find::name;
302		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
303		my $subpath = $1;
304		return if lc($subpath) eq lc($self->{dispatch});
305
306		$file = "$self->{path}/$subpath.pm";
307		my $pkg = "$self->{name}::$subpath";
308		$pkg =~ s!/!::!g;
309
310		# If we have a mixed-case package name, assume case has been preserved
311		# correctly.  Otherwise, root through the file to locate the case-preserved
312		# version of the package name.
313		if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
314			my $content = Module::Install::_read($subpath . '.pm');
315			my $in_pod  = 0;
316			foreach ( split //, $content ) {
317				$in_pod = 1 if /^=\w/;
318				$in_pod = 0 if /^=cut/;
319				next if ($in_pod || /^=cut/);  # skip pod text
320				next if /^\s*#/;               # and comments
321				if ( m/^\s*package\s+($pkg)\s*;/i ) {
322					$pkg = $1;
323					last;
324				}
325			}
326		}
327
328		push @found, [ $file, $pkg ];
329	}, $path ) if -d $path;
330
331	@found;
332}
333
334
335
336
337
338#####################################################################
339# Common Utility Functions
340
341sub _caller {
342	my $depth = 0;
343	my $call  = caller($depth);
344	while ( $call eq __PACKAGE__ ) {
345		$depth++;
346		$call = caller($depth);
347	}
348	return $call;
349}
350
351# Done in evals to avoid confusing Perl::MinimumVersion
352eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
353sub _read {
354	local *FH;
355	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
356	my $string = do { local $/; <FH> };
357	close FH or die "close($_[0]): $!";
358	return $string;
359}
360END_NEW
361sub _read {
362	local *FH;
363	open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
364	my $string = do { local $/; <FH> };
365	close FH or die "close($_[0]): $!";
366	return $string;
367}
368END_OLD
369
370sub _readperl {
371	my $string = Module::Install::_read($_[0]);
372	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
373	$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
374	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
375	return $string;
376}
377
378sub _readpod {
379	my $string = Module::Install::_read($_[0]);
380	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
381	return $string if $_[0] =~ /\.pod\z/;
382	$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
383	$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
384	$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
385	$string =~ s/^\n+//s;
386	return $string;
387}
388
389# Done in evals to avoid confusing Perl::MinimumVersion
390eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
391sub _write {
392	local *FH;
393	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
394	foreach ( 1 .. $#_ ) {
395		print FH $_[$_] or die "print($_[0]): $!";
396	}
397	close FH or die "close($_[0]): $!";
398}
399END_NEW
400sub _write {
401	local *FH;
402	open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
403	foreach ( 1 .. $#_ ) {
404		print FH $_[$_] or die "print($_[0]): $!";
405	}
406	close FH or die "close($_[0]): $!";
407}
408END_OLD
409
410# _version is for processing module versions (eg, 1.03_05) not
411# Perl versions (eg, 5.8.1).
412sub _version ($) {
413	my $s = shift || 0;
414	my $d =()= $s =~ /(\.)/g;
415	if ( $d >= 2 ) {
416		# Normalise multipart versions
417		$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
418	}
419	$s =~ s/^(\d+)\.?//;
420	my $l = $1 || 0;
421	my @v = map {
422		$_ . '0' x (3 - length $_)
423	} $s =~ /(\d{1,3})\D?/g;
424	$l = $l . '.' . join '', @v if @v;
425	return $l + 0;
426}
427
428sub _cmp ($$) {
429	_version($_[0]) <=> _version($_[1]);
430}
431
432# Cloned from Params::Util::_CLASS
433sub _CLASS ($) {
434	(
435		defined $_[0]
436		and
437		! ref $_[0]
438		and
439		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
440	) ? $_[0] : undef;
441}
442
4431;
444
445# Copyright 2008 - 2010 Adam Kennedy.
446