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.87';
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
351sub _read {
352	local *FH;
353	if ( $] >= 5.006 ) {
354		open( FH, '<', $_[0] ) or die "open($_[0]): $!";
355	} else {
356		open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
357	}
358	my $string = do { local $/; <FH> };
359	close FH or die "close($_[0]): $!";
360	return $string;
361}
362
363sub _readperl {
364	my $string = Module::Install::_read($_[0]);
365	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
366	$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
367	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
368	return $string;
369}
370
371sub _readpod {
372	my $string = Module::Install::_read($_[0]);
373	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
374	return $string if $_[0] =~ /\.pod\z/;
375	$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
376	$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
377	$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
378	$string =~ s/^\n+//s;
379	return $string;
380}
381
382sub _write {
383	local *FH;
384	if ( $] >= 5.006 ) {
385		open( FH, '>', $_[0] ) or die "open($_[0]): $!";
386	} else {
387		open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
388	}
389	foreach ( 1 .. $#_ ) {
390		print FH $_[$_] or die "print($_[0]): $!";
391	}
392	close FH or die "close($_[0]): $!";
393}
394
395# _version is for processing module versions (eg, 1.03_05) not
396# Perl versions (eg, 5.8.1).
397sub _version ($) {
398	my $s = shift || 0;
399	my $d =()= $s =~ /(\.)/g;
400	if ( $d >= 2 ) {
401		# Normalise multipart versions
402		$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
403	}
404	$s =~ s/^(\d+)\.?//;
405	my $l = $1 || 0;
406	my @v = map {
407		$_ . '0' x (3 - length $_)
408	} $s =~ /(\d{1,3})\D?/g;
409	$l = $l . '.' . join '', @v if @v;
410	return $l + 0;
411}
412
413sub _cmp ($$) {
414	_version($_[0]) <=> _version($_[1]);
415}
416
417# Cloned from Params::Util::_CLASS
418sub _CLASS ($) {
419	(
420		defined $_[0]
421		and
422		! ref $_[0]
423		and
424		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
425	) ? $_[0] : undef;
426}
427
4281;
429
430# Copyright 2008 - 2009 Adam Kennedy.
431