[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.71';
}


# 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 or -f 'Build.PL' ) { 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


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

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

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";
		unshift @_, ( $self, $1 );
		goto &{$self->can('call')} unless uc($1) eq $1;
	};
}

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]): $!";
}

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;
}

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.
	33	$VERSION = '0.71';
0430b7f7	34	}
0430b7f7	35
6ea94d90	36
	37
	38
	39
0430b7f7	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.
	46	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
6ea94d90	47	unless ( $INC{$file} ) { die <<"END_DIE" }
6ea94d90	48
0430b7f7	49	Please invoke ${\__PACKAGE__} with:
0430b7f7	50
6ea94d90	51	use inc::${\__PACKAGE__};
0430b7f7	52
	53	not:
	54
6ea94d90	55	use ${\__PACKAGE__};
0430b7f7	56
0430b7f7	57	END_DIE
6ea94d90	58
	59
	60
	61
0430b7f7	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.
6ea94d90	68	if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
6ea94d90	69
0430b7f7	70	Your installer $0 has a modification time in the future.
	71
	72	This is known to create infinite loops in make.
	73
	74	Please correct this, then run $0 again.
	75
	76	END_DIE
6ea94d90	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.
	84	if ( $0 =~ /Build.PL$/i or -f 'Build.PL' ) { die <<"END_DIE" }
	85
	86	Module::Install no longer supports Build.PL.
	87
	88	It was impossible to maintain duel backends, and has been deprecated.
	89
	90	Please remove all Build.PL files and only use the Makefile.PL installer.
	91
	92	END_DIE
	93
	94
	95
	96
0430b7f7	97
	98	use Cwd ();
	99	use File::Find ();
	100	use File::Path ();
	101	use FindBin;
	102
	103	inc::Module::Install::VERSION = VERSION;
	104	@inc::Module::Install::ISA = __PACKAGE__;
	105
	106	sub autoload {
6ea94d90	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	};
0430b7f7	121	}
	122
	123	sub import {
6ea94d90	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;
0430b7f7	145	}
	146
	147	sub preload {
6ea94d90	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	}
0430b7f7	178	}
	179
	180	sub new {
6ea94d90	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 );
0430b7f7	207	}
	208
	209	sub 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
	216	sub load {
6ea94d90	217	my ($self, $method) = @_;
0430b7f7	218
6ea94d90	219	$self->load_extensions(
	220	"$self->{prefix}/$self->{path}", $self
	221	) unless $self->{extensions};
0430b7f7	222
6ea94d90	223	foreach my $obj (@{$self->{extensions}}) {
	224	return $obj if $obj->can($method);
	225	}
0430b7f7	226
6ea94d90	227	my $admin = $self->{admin} or die <<"END_DIE";
0430b7f7	228	The '$method' method does not exist in the '$self->{prefix}' path!
	229	Please remove the '$self->{prefix}' directory and run $0 again to load it.
	230	END_DIE
	231
6ea94d90	232	my $obj = $admin->load($method, 1);
6ea94d90	233	push @{$self->{extensions}}, $obj;
0430b7f7	234
6ea94d90	235	$obj;
0430b7f7	236	}
	237
	238	sub load_extensions {
6ea94d90	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} \|\|= [];
0430b7f7	260	}
	261
	262	sub find_extensions {
6ea94d90	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/^\spackage\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;
0430b7f7	298	}
0430b7f7	299
6ea94d90	300
	301
	302
	303
	304	#####################################################################
	305	# Utility Functions
	306
0430b7f7	307	sub _caller {
6ea94d90	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
	317	sub _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
	325	sub _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
	332	sub _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;
0430b7f7	339	}
	340
	341	1;
6ea94d90	342
6ea94d90	343	# Copyright 2008 Adam Kennedy.