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