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
20BEGIN {
21	require 5.004;
22}
23use strict 'vars';
24
25use vars qw{$VERSION};
26BEGIN {
27	# All Module::Install core packages now require synchronised versions.
28	# This will be used to ensure we don't accidentally load old or
29	# different versions of modules.
30	# This is not enforced yet, but will be some time in the next few
31	# releases once we can make sure it won't clash with custom
32	# Module::Install extensions.
33	$VERSION = '0.71';
34}
35
36
37
38
39
40# Whether or not inc::Module::Install is actually loaded, the
41# $INC{inc/Module/Install.pm} is what will still get set as long as
42# the caller loaded module this in the documented manner.
43# If not set, the caller may NOT have loaded the bundled version, and thus
44# they may not have a MI version that works with the Makefile.PL. This would
45# result in false errors or unexpected behaviour. And we don't want that.
46my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
47unless ( $INC{$file} ) { die <<"END_DIE" }
48
49Please invoke ${\__PACKAGE__} with:
50
51	use inc::${\__PACKAGE__};
52
53not:
54
55	use ${\__PACKAGE__};
56
57END_DIE
58
59
60
61
62
63# If the script that is loading Module::Install is from the future,
64# then make will detect this and cause it to re-run over and over
65# again. This is bad. Rather than taking action to touch it (which
66# is unreliable on some platforms and requires write permissions)
67# for now we should catch this and refuse to run.
68if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
69
70Your installer $0 has a modification time in the future.
71
72This is known to create infinite loops in make.
73
74Please correct this, then run $0 again.
75
76END_DIE
77
78
79
80
81
82# Build.PL was formerly supported, but no longer is due to excessive
83# difficulty in implementing every single feature twice.
84if ( $0 =~ /Build.PL$/i or -f 'Build.PL' ) { die <<"END_DIE" }
85
86Module::Install no longer supports Build.PL.
87
88It was impossible to maintain duel backends, and has been deprecated.
89
90Please remove all Build.PL files and only use the Makefile.PL installer.
91
92END_DIE
93
94
95
96
97
98use Cwd        ();
99use File::Find ();
100use File::Path ();
101use FindBin;
102
103*inc::Module::Install::VERSION = *VERSION;
104@inc::Module::Install::ISA     = __PACKAGE__;
105
106sub autoload {
107	my $self = shift;
108	my $who  = $self->_caller;
109	my $cwd  = Cwd::cwd();
110	my $sym  = "${who}::AUTOLOAD";
111	$sym->{$cwd} = sub {
112		my $pwd = Cwd::cwd();
113		if ( my $code = $sym->{$pwd} ) {
114			# delegate back to parent dirs
115			goto &$code unless $cwd eq $pwd;
116		}
117		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
118		unshift @_, ( $self, $1 );
119		goto &{$self->can('call')} unless uc($1) eq $1;
120	};
121}
122
123sub import {
124	my $class = shift;
125	my $self  = $class->new(@_);
126	my $who   = $self->_caller;
127
128	unless ( -f $self->{file} ) {
129		require "$self->{path}/$self->{dispatch}.pm";
130		File::Path::mkpath("$self->{prefix}/$self->{author}");
131		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
132		$self->{admin}->init;
133		@_ = ($class, _self => $self);
134		goto &{"$self->{name}::import"};
135	}
136
137	*{"${who}::AUTOLOAD"} = $self->autoload;
138	$self->preload;
139
140	# Unregister loader and worker packages so subdirs can use them again
141	delete $INC{"$self->{file}"};
142	delete $INC{"$self->{path}.pm"};
143
144	return 1;
145}
146
147sub preload {
148	my $self = shift;
149	unless ( $self->{extensions} ) {
150		$self->load_extensions(
151			"$self->{prefix}/$self->{path}", $self
152		);
153	}
154
155	my @exts = @{$self->{extensions}};
156	unless ( @exts ) {
157		my $admin = $self->{admin};
158		@exts = $admin->load_all_extensions;
159	}
160
161	my %seen;
162	foreach my $obj ( @exts ) {
163		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
164			next unless $obj->can($method);
165			next if $method =~ /^_/;
166			next if $method eq uc($method);
167			$seen{$method}++;
168		}
169	}
170
171	my $who = $self->_caller;
172	foreach my $name ( sort keys %seen ) {
173		*{"${who}::$name"} = sub {
174			${"${who}::AUTOLOAD"} = "${who}::$name";
175			goto &{"${who}::AUTOLOAD"};
176		};
177	}
178}
179
180sub new {
181	my ($class, %args) = @_;
182
183	# ignore the prefix on extension modules built from top level.
184	my $base_path = Cwd::abs_path($FindBin::Bin);
185	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
186		delete $args{prefix};
187	}
188
189	return $args{_self} if $args{_self};
190
191	$args{dispatch} ||= 'Admin';
192	$args{prefix}   ||= 'inc';
193	$args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
194	$args{bundle}   ||= 'inc/BUNDLES';
195	$args{base}     ||= $base_path;
196	$class =~ s/^\Q$args{prefix}\E:://;
197	$args{name}     ||= $class;
198	$args{version}  ||= $class->VERSION;
199	unless ( $args{path} ) {
200		$args{path}  = $args{name};
201		$args{path}  =~ s!::!/!g;
202	}
203	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
204	$args{wrote}      = 0;
205
206	bless( \%args, $class );
207}
208
209sub call {
210	my ($self, $method) = @_;
211	my $obj = $self->load($method) or return;
212        splice(@_, 0, 2, $obj);
213	goto &{$obj->can($method)};
214}
215
216sub load {
217	my ($self, $method) = @_;
218
219	$self->load_extensions(
220		"$self->{prefix}/$self->{path}", $self
221	) unless $self->{extensions};
222
223	foreach my $obj (@{$self->{extensions}}) {
224		return $obj if $obj->can($method);
225	}
226
227	my $admin = $self->{admin} or die <<"END_DIE";
228The '$method' method does not exist in the '$self->{prefix}' path!
229Please remove the '$self->{prefix}' directory and run $0 again to load it.
230END_DIE
231
232	my $obj = $admin->load($method, 1);
233	push @{$self->{extensions}}, $obj;
234
235	$obj;
236}
237
238sub load_extensions {
239	my ($self, $path, $top) = @_;
240
241	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
242		unshift @INC, $self->{prefix};
243	}
244
245	foreach my $rv ( $self->find_extensions($path) ) {
246		my ($file, $pkg) = @{$rv};
247		next if $self->{pathnames}{$pkg};
248
249		local $@;
250		my $new = eval { require $file; $pkg->can('new') };
251		unless ( $new ) {
252			warn $@ if $@;
253			next;
254		}
255		$self->{pathnames}{$pkg} = delete $INC{$file};
256		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
257	}
258
259	$self->{extensions} ||= [];
260}
261
262sub find_extensions {
263	my ($self, $path) = @_;
264
265	my @found;
266	File::Find::find( sub {
267		my $file = $File::Find::name;
268		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
269		my $subpath = $1;
270		return if lc($subpath) eq lc($self->{dispatch});
271
272		$file = "$self->{path}/$subpath.pm";
273		my $pkg = "$self->{name}::$subpath";
274		$pkg =~ s!/!::!g;
275
276		# If we have a mixed-case package name, assume case has been preserved
277		# correctly.  Otherwise, root through the file to locate the case-preserved
278		# version of the package name.
279		if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
280			my $content = Module::Install::_read($subpath . '.pm');
281			my $in_pod  = 0;
282			foreach ( split //, $content ) {
283				$in_pod = 1 if /^=\w/;
284				$in_pod = 0 if /^=cut/;
285				next if ($in_pod || /^=cut/);  # skip pod text
286				next if /^\s*#/;               # and comments
287				if ( m/^\s*package\s+($pkg)\s*;/i ) {
288					$pkg = $1;
289					last;
290				}
291			}
292		}
293
294		push @found, [ $file, $pkg ];
295	}, $path ) if -d $path;
296
297	@found;
298}
299
300
301
302
303
304#####################################################################
305# Utility Functions
306
307sub _caller {
308	my $depth = 0;
309	my $call  = caller($depth);
310	while ( $call eq __PACKAGE__ ) {
311		$depth++;
312		$call = caller($depth);
313	}
314	return $call;
315}
316
317sub _read {
318	local *FH;
319	open FH, "< $_[0]" or die "open($_[0]): $!";
320	my $str = do { local $/; <FH> };
321	close FH or die "close($_[0]): $!";
322	return $str;
323}
324
325sub _write {
326	local *FH;
327	open FH, "> $_[0]" or die "open($_[0]): $!";
328	foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
329	close FH or die "close($_[0]): $!";
330}
331
332sub _version {
333	my $s = shift || 0;
334	   $s =~ s/^(\d+)\.?//;
335	my $l = $1 || 0;
336	my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
337	   $l = $l . '.' . join '', @v if @v;
338	return $l + 0;
339}
340
3411;
342
343# Copyright 2008 Adam Kennedy.
344