[p5sagit/Devel-Size.git] / inc / Module / Install.pm

#line 1
package Module::Install;

# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
#     3. The installed version of inc::Module::Install loads
#     4. inc::Module::Install calls "require Module::Install"
#     5. The ./inc/ version of Module::Install loads
# } ELSE {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
#     3. The ./inc/ version of Module::Install loads
# }

BEGIN {
	require 5.004;
}
use strict 'vars';

use vars qw{$VERSION};
BEGIN {
	# All Module::Install core packages now require synchronised versions.
	# This will be used to ensure we don't accidentally load old or
	# different versions of modules.
	# This is not enforced yet, but will be some time in the next few
	# releases once we can make sure it won't clash with custom
	# Module::Install extensions.
	$VERSION = '0.77';

	*inc::Module::Install::VERSION = *VERSION;
	@inc::Module::Install::ISA     = __PACKAGE__;

}


# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }

Please invoke ${\__PACKAGE__} with:

	use inc::${\__PACKAGE__};

not:

	use ${\__PACKAGE__};

END_DIE


# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }

Your installer $0 has a modification time in the future.

This is known to create infinite loops in make.

Please correct this, then run $0 again.

END_DIE


# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }

Module::Install no longer supports Build.PL.

It was impossible to maintain duel backends, and has been deprecated.

Please remove all Build.PL files and only use the Makefile.PL installer.

END_DIE


# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));


use Cwd        ();
use File::Find ();
use File::Path ();
use FindBin;

sub autoload {
	my $self = shift;
	my $who  = $self->_caller;
	my $cwd  = Cwd::cwd();
	my $sym  = "${who}::AUTOLOAD";
	$sym->{$cwd} = sub {
		my $pwd = Cwd::cwd();
		if ( my $code = $sym->{$pwd} ) {
			# delegate back to parent dirs
			goto &$code unless $cwd eq $pwd;
		}
		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
		unless ( uc($1) eq $1 ) {
			unshift @_, ( $self, $1 );
			goto &{$self->can('call')};
		}
	};
}

sub import {
	my $class = shift;
	my $self  = $class->new(@_);
	my $who   = $self->_caller;

	unless ( -f $self->{file} ) {
		require "$self->{path}/$self->{dispatch}.pm";
		File::Path::mkpath("$self->{prefix}/$self->{author}");
		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
		$self->{admin}->init;
		@_ = ($class, _self => $self);
		goto &{"$self->{name}::import"};
	}

	*{"${who}::AUTOLOAD"} = $self->autoload;
	$self->preload;

	# Unregister loader and worker packages so subdirs can use them again
	delete $INC{"$self->{file}"};
	delete $INC{"$self->{path}.pm"};

	return 1;
}

sub preload {
	my $self = shift;
	unless ( $self->{extensions} ) {
		$self->load_extensions(
			"$self->{prefix}/$self->{path}", $self
		);
	}

	my @exts = @{$self->{extensions}};
	unless ( @exts ) {
		my $admin = $self->{admin};
		@exts = $admin->load_all_extensions;
	}

	my %seen;
	foreach my $obj ( @exts ) {
		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
			next unless $obj->can($method);
			next if $method =~ /^_/;
			next if $method eq uc($method);
			$seen{$method}++;
		}
	}

	my $who = $self->_caller;
	foreach my $name ( sort keys %seen ) {
		*{"${who}::$name"} = sub {
			${"${who}::AUTOLOAD"} = "${who}::$name";
			goto &{"${who}::AUTOLOAD"};
		};
	}
}

sub new {
	my ($class, %args) = @_;

	# ignore the prefix on extension modules built from top level.
	my $base_path = Cwd::abs_path($FindBin::Bin);
	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
		delete $args{prefix};
	}

	return $args{_self} if $args{_self};

	$args{dispatch} ||= 'Admin';
	$args{prefix}   ||= 'inc';
	$args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
	$args{bundle}   ||= 'inc/BUNDLES';
	$args{base}     ||= $base_path;
	$class =~ s/^\Q$args{prefix}\E:://;
	$args{name}     ||= $class;
	$args{version}  ||= $class->VERSION;
	unless ( $args{path} ) {
		$args{path}  = $args{name};
		$args{path}  =~ s!::!/!g;
	}
	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
	$args{wrote}      = 0;

	bless( \%args, $class );
}

sub call {
	my ($self, $method) = @_;
	my $obj = $self->load($method) or return;
        splice(@_, 0, 2, $obj);
	goto &{$obj->can($method)};
}

sub load {
	my ($self, $method) = @_;

	$self->load_extensions(
		"$self->{prefix}/$self->{path}", $self
	) unless $self->{extensions};

	foreach my $obj (@{$self->{extensions}}) {
		return $obj if $obj->can($method);
	}

	my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE

	my $obj = $admin->load($method, 1);
	push @{$self->{extensions}}, $obj;

	$obj;
}

sub load_extensions {
	my ($self, $path, $top) = @_;

	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
		unshift @INC, $self->{prefix};
	}

	foreach my $rv ( $self->find_extensions($path) ) {
		my ($file, $pkg) = @{$rv};
		next if $self->{pathnames}{$pkg};

		local $@;
		my $new = eval { require $file; $pkg->can('new') };
		unless ( $new ) {
			warn $@ if $@;
			next;
		}
		$self->{pathnames}{$pkg} = delete $INC{$file};
		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	}

	$self->{extensions} ||= [];
}

sub find_extensions {
	my ($self, $path) = @_;

	my @found;
	File::Find::find( sub {
		my $file = $File::Find::name;
		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
		my $subpath = $1;
		return if lc($subpath) eq lc($self->{dispatch});

		$file = "$self->{path}/$subpath.pm";
		my $pkg = "$self->{name}::$subpath";
		$pkg =~ s!/!::!g;

		# If we have a mixed-case package name, assume case has been preserved
		# correctly.  Otherwise, root through the file to locate the case-preserved
		# version of the package name.
		if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
			my $content = Module::Install::_read($subpath . '.pm');
			my $in_pod  = 0;
			foreach ( split //, $content ) {
				$in_pod = 1 if /^=\w/;
				$in_pod = 0 if /^=cut/;
				next if ($in_pod || /^=cut/);  # skip pod text
				next if /^\s*#/;               # and comments
				if ( m/^\s*package\s+($pkg)\s*;/i ) {
					$pkg = $1;
					last;
				}
			}
		}

		push @found, [ $file, $pkg ];
	}, $path ) if -d $path;

	@found;
}


#####################################################################
# Utility Functions

sub _caller {
	my $depth = 0;
	my $call  = caller($depth);
	while ( $call eq __PACKAGE__ ) {
		$depth++;
		$call = caller($depth);
	}
	return $call;
}

sub _read {
	local *FH;
	open FH, "< $_[0]" or die "open($_[0]): $!";
	my $str = do { local $/; <FH> };
	close FH or die "close($_[0]): $!";
	return $str;
}

sub _write {
	local *FH;
	open FH, "> $_[0]" or die "open($_[0]): $!";
	foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
	close FH or die "close($_[0]): $!";
}

# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).

sub _version ($) {
	my $s = shift || 0;
	   $s =~ s/^(\d+)\.?//;
	my $l = $1 || 0;
	my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
	   $l = $l . '.' . join '', @v if @v;
	return $l + 0;
}

# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
	(
		defined $_[0]
		and
		! ref $_[0]
		and
		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
	) ? $_[0] : undef;
}

1;

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