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.006;
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.19';
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::getcwd();
160	my $sym  = "${who}::AUTOLOAD";
161	$sym->{$cwd} = sub {
162		my $pwd = Cwd::getcwd();
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::getcwd()) eq $base_path ) {
243		delete $args{prefix};
244	}
245	return $args{_self} if $args{_self};
246
247	$base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS';
248
249	$args{dispatch} ||= 'Admin';
250	$args{prefix}   ||= 'inc';
251	$args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
252	$args{bundle}   ||= 'inc/BUNDLES';
253	$args{base}     ||= $base_path;
254	$class =~ s/^\Q$args{prefix}\E:://;
255	$args{name}     ||= $class;
256	$args{version}  ||= $class->VERSION;
257	unless ( $args{path} ) {
258		$args{path}  = $args{name};
259		$args{path}  =~ s!::!/!g;
260	}
261	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
262	$args{wrote}      = 0;
263
264	bless( \%args, $class );
265}
266
267sub call {
268	my ($self, $method) = @_;
269	my $obj = $self->load($method) or return;
270        splice(@_, 0, 2, $obj);
271	goto &{$obj->can($method)};
272}
273
274sub load {
275	my ($self, $method) = @_;
276
277	$self->load_extensions(
278		"$self->{prefix}/$self->{path}", $self
279	) unless $self->{extensions};
280
281	foreach my $obj (@{$self->{extensions}}) {
282		return $obj if $obj->can($method);
283	}
284
285	my $admin = $self->{admin} or die <<"END_DIE";
286The '$method' method does not exist in the '$self->{prefix}' path!
287Please remove the '$self->{prefix}' directory and run $0 again to load it.
288END_DIE
289
290	my $obj = $admin->load($method, 1);
291	push @{$self->{extensions}}, $obj;
292
293	$obj;
294}
295
296sub load_extensions {
297	my ($self, $path, $top) = @_;
298
299	my $should_reload = 0;
300	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
301		unshift @INC, $self->{prefix};
302		$should_reload = 1;
303	}
304
305	foreach my $rv ( $self->find_extensions($path) ) {
306		my ($file, $pkg) = @{$rv};
307		next if $self->{pathnames}{$pkg};
308
309		local $@;
310		my $new = eval { local $^W; require $file; $pkg->can('new') };
311		unless ( $new ) {
312			warn $@ if $@;
313			next;
314		}
315		$self->{pathnames}{$pkg} =
316			$should_reload ? delete $INC{$file} : $INC{$file};
317		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
318	}
319
320	$self->{extensions} ||= [];
321}
322
323sub find_extensions {
324	my ($self, $path) = @_;
325
326	my @found;
327	File::Find::find( {no_chdir => 1, wanted => sub {
328		my $file = $File::Find::name;
329		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
330		my $subpath = $1;
331		return if lc($subpath) eq lc($self->{dispatch});
332
333		$file = "$self->{path}/$subpath.pm";
334		my $pkg = "$self->{name}::$subpath";
335		$pkg =~ s!/!::!g;
336
337		# If we have a mixed-case package name, assume case has been preserved
338		# correctly.  Otherwise, root through the file to locate the case-preserved
339		# version of the package name.
340		if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
341			my $content = Module::Install::_read($File::Find::name);
342			my $in_pod  = 0;
343			foreach ( split /\n/, $content ) {
344				$in_pod = 1 if /^=\w/;
345				$in_pod = 0 if /^=cut/;
346				next if ($in_pod || /^=cut/);  # skip pod text
347				next if /^\s*#/;               # and comments
348				if ( m/^\s*package\s+($pkg)\s*;/i ) {
349					$pkg = $1;
350					last;
351				}
352			}
353		}
354
355		push @found, [ $file, $pkg ];
356	}}, $path ) if -d $path;
357
358	@found;
359}
360
361
362
363
364
365#####################################################################
366# Common Utility Functions
367
368sub _caller {
369	my $depth = 0;
370	my $call  = caller($depth);
371	while ( $call eq __PACKAGE__ ) {
372		$depth++;
373		$call = caller($depth);
374	}
375	return $call;
376}
377
378sub _read {
379	local *FH;
380	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
381	binmode FH;
382	my $string = do { local $/; <FH> };
383	close FH or die "close($_[0]): $!";
384	return $string;
385}
386
387sub _readperl {
388	my $string = Module::Install::_read($_[0]);
389	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
390	$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
391	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
392	return $string;
393}
394
395sub _readpod {
396	my $string = Module::Install::_read($_[0]);
397	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
398	return $string if $_[0] =~ /\.pod\z/;
399	$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
400	$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
401	$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
402	$string =~ s/^\n+//s;
403	return $string;
404}
405
406sub _write {
407	local *FH;
408	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
409	binmode FH;
410	foreach ( 1 .. $#_ ) {
411		print FH $_[$_] or die "print($_[0]): $!";
412	}
413	close FH or die "close($_[0]): $!";
414}
415
416# _version is for processing module versions (eg, 1.03_05) not
417# Perl versions (eg, 5.8.1).
418sub _version {
419	my $s = shift || 0;
420	my $d =()= $s =~ /(\.)/g;
421	if ( $d >= 2 ) {
422		# Normalise multipart versions
423		$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
424	}
425	$s =~ s/^(\d+)\.?//;
426	my $l = $1 || 0;
427	my @v = map {
428		$_ . '0' x (3 - length $_)
429	} $s =~ /(\d{1,3})\D?/g;
430	$l = $l . '.' . join '', @v if @v;
431	return $l + 0;
432}
433
434sub _cmp {
435	_version($_[1]) <=> _version($_[2]);
436}
437
438# Cloned from Params::Util::_CLASS
439sub _CLASS {
440	(
441		defined $_[0]
442		and
443		! ref $_[0]
444		and
445		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
446	) ? $_[0] : undef;
447}
448
4491;
450
451# Copyright 2008 - 2012 Adam Kennedy.
452