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