[scpubgit/Test-Harness-Selenium.git] / examples / THSelenium-Test / 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
# }

use 5.005;
use strict 'vars';
use Cwd        ();
use File::Find ();
use File::Path ();

use vars qw{$VERSION $MAIN};
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 = '1.00';

	# Storage for the pseudo-singleton
	$MAIN    = undef;

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

}

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

	#-------------------------------------------------------------
	# all of the following checks should be included in import(),
	# to allow "eval 'require Module::Install; 1' to test
	# installation of Module::Install. (RT #51267)
	#-------------------------------------------------------------

	# 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

	# This reportedly fixes a rare Win32 UTC file time issue, but
	# as this is a non-cross-platform XS module not in the core,
	# we shouldn't really depend on it. See RT #24194 for detail.
	# (Also, this module only supports Perl 5.6 and above).
	eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;

	# 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 ) {
		my $s = (stat($0))[9];

		# If the modification time is only slightly in the future,
		# sleep briefly to remove the problem.
		my $a = $s - time;
		if ( $a > 0 and $a < 5 ) { sleep 5 }

		# Too far in the future, throw an error.
		my $t = time;
		if ( $s > $t ) { die <<"END_DIE" }

Your installer $0 has a modification time in the future ($s > $t).

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

	#-------------------------------------------------------------

	unless ( -f $self->{file} ) {
		foreach my $key (keys %INC) {
			delete $INC{$key} if $key =~ /Module\/Install/;
		}

		local $^W;
		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"};
	}

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

	# Unregister loader and worker packages so subdirs can use them again
	delete $INC{'inc/Module/Install.pm'};
	delete $INC{'Module/Install.pm'};

	# Save to the singleton
	$MAIN = $self;

	return 1;
}

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;
		}
		unless ($$sym =~ s/([^:]+)$//) {
			# XXX: it looks like we can't retrieve the missing function
			# via $$sym (usually $main::AUTOLOAD) in this case.
			# I'm still wondering if we should slurp Makefile.PL to
			# get some context or not ...
			my ($package, $file, $line) = caller;
			die <<"EOT";
Unknown function is found at $file line $line.
Execution of $file aborted due to runtime errors.

If you're a contributor to a project, you may need to install
some Module::Install extensions from CPAN (or other repository).
If you're a user of a module, please contact the author.
EOT
		}
		my $method = $1;
		if ( uc($method) eq $method ) {
			# Do nothing
			return;
		} elsif ( $method =~ /^_/ and $self->can($method) ) {
			# Dispatch to the root M:I class
			return $self->$method(@_);
		}

		# Dispatch to the appropriate plugin
		unshift @_, ( $self, $1 );
		goto &{$self->can('call')};
	};
}

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

	my @exts = @{$self->{extensions}};
	unless ( @exts ) {
		@exts = $self->{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 ) {
		local $^W;
		*{"${who}::$name"} = sub {
			${"${who}::AUTOLOAD"} = "${who}::$name";
			goto &{"${who}::AUTOLOAD"};
		};
	}
}

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

	delete $INC{'FindBin.pm'};
	{
		# to suppress the redefine warning
		local $SIG{__WARN__} = sub {};
		require FindBin;
	}

	# 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) = @_;

	my $should_reload = 0;
	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
		unshift @INC, $self->{prefix};
		$should_reload = 1;
	}

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

		local $@;
		my $new = eval { local $^W; require $file; $pkg->can('new') };
		unless ( $new ) {
			warn $@ if $@;
			next;
		}
		$self->{pathnames}{$pkg} =
			$should_reload ? delete $INC{$file} : $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;
}


#####################################################################
# Common Utility Functions

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

# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
	local *FH;
	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
	my $string = do { local $/; <FH> };
	close FH or die "close($_[0]): $!";
	return $string;
}
END_NEW
sub _read {
	local *FH;
	open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
	my $string = do { local $/; <FH> };
	close FH or die "close($_[0]): $!";
	return $string;
}
END_OLD

sub _readperl {
	my $string = Module::Install::_read($_[0]);
	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
	$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
	return $string;
}

sub _readpod {
	my $string = Module::Install::_read($_[0]);
	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
	return $string if $_[0] =~ /\.pod\z/;
	$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
	$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
	$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
	$string =~ s/^\n+//s;
	return $string;
}

# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
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]): $!";
}
END_NEW
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]): $!";
}
END_OLD

# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
	my $s = shift || 0;
	my $d =()= $s =~ /(\.)/g;
	if ( $d >= 2 ) {
		# Normalise multipart versions
		$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
	}
	$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;
}

sub _cmp ($$) {
	_version($_[0]) <=> _version($_[1]);
}

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

1;

# Copyright 2008 - 2010 Adam Kennedy.
Commit	Line	Data
4e138785	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
	20	use 5.005;
	21	use strict 'vars';
	22	use Cwd ();
	23	use File::Find ();
	24	use File::Path ();
	25
	26	use vars qw{$VERSION $MAIN};
	27	BEGIN {
	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 = '1.00';
	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
	44	sub 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
	64	Please invoke ${\__PACKAGE__} with:
65
66	use inc::${\__PACKAGE__};
67
68	not:
69
70	use ${\__PACKAGE__};
71
72	END_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
97	Your installer $0 has a modification time in the future ($s > $t).
98
99	This is known to create infinite loops in make.
100
101	Please correct this, then run $0 again.
102
103	END_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
111	Module::Install no longer supports Build.PL.
112
113	It was impossible to maintain duel backends, and has been deprecated.
114
115	Please remove all Build.PL files and only use the Makefile.PL installer.
116
117	END_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
156	sub 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";
174	Unknown function is found at $file line $line.
175	Execution of $file aborted due to runtime errors.
176
177	If you're a contributor to a project, you may need to install
178	some Module::Install extensions from CPAN (or other repository).
179	If you're a user of a module, please contact the author.
180	EOT
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
197	sub 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
230	sub new {
231	my ($class, %args) = @_;
232
233	delete $INC{'FindBin.pm'};
234	{
235	# to suppress the redefine warning
236	local $SIG{__WARN__} = sub {};
237	require FindBin;
238	}
239
240	# ignore the prefix on extension modules built from top level.
241	my $base_path = Cwd::abs_path($FindBin::Bin);
242	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
243	delete $args{prefix};
244	}
245	return $args{_self} if $args{_self};
246
247	$args{dispatch} \|\|= 'Admin';
248	$args{prefix} \|\|= 'inc';
249	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
250	$args{bundle} \|\|= 'inc/BUNDLES';
251	$args{base} \|\|= $base_path;
252	$class =~ s/^\Q$args{prefix}\E:://;
253	$args{name} \|\|= $class;
254	$args{version} \|\|= $class->VERSION;
255	unless ( $args{path} ) {
256	$args{path} = $args{name};
257	$args{path} =~ s!::!/!g;
258	}
259	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
260	$args{wrote} = 0;
261
262	bless( \%args, $class );
263	}
264
265	sub call {
266	my ($self, $method) = @_;
267	my $obj = $self->load($method) or return;
268	splice(@_, 0, 2, $obj);
269	goto &{$obj->can($method)};
270	}
271
272	sub load {
273	my ($self, $method) = @_;
274
275	$self->load_extensions(
276	"$self->{prefix}/$self->{path}", $self
277	) unless $self->{extensions};
278
279	foreach my $obj (@{$self->{extensions}}) {
280	return $obj if $obj->can($method);
281	}
282
283	my $admin = $self->{admin} or die <<"END_DIE";
284	The '$method' method does not exist in the '$self->{prefix}' path!
285	Please remove the '$self->{prefix}' directory and run $0 again to load it.
286	END_DIE
287
288	my $obj = $admin->load($method, 1);
289	push @{$self->{extensions}}, $obj;
290
291	$obj;
292	}
293
294	sub load_extensions {
295	my ($self, $path, $top) = @_;
296
297	my $should_reload = 0;
298	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
299	unshift @INC, $self->{prefix};
300	$should_reload = 1;
301	}
302
303	foreach my $rv ( $self->find_extensions($path) ) {
304	my ($file, $pkg) = @{$rv};
305	next if $self->{pathnames}{$pkg};
306
307	local $@;
308	my $new = eval { local $^W; require $file; $pkg->can('new') };
309	unless ( $new ) {
310	warn $@ if $@;
311	next;
312	}
313	$self->{pathnames}{$pkg} =
314	$should_reload ? delete $INC{$file} : $INC{$file};
315	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
316	}
317
318	$self->{extensions} \|\|= [];
319	}
320
321	sub find_extensions {
322	my ($self, $path) = @_;
323
324	my @found;
325	File::Find::find( sub {
326	my $file = $File::Find::name;
327	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
328	my $subpath = $1;
329	return if lc($subpath) eq lc($self->{dispatch});
330
331	$file = "$self->{path}/$subpath.pm";
332	my $pkg = "$self->{name}::$subpath";
333	$pkg =~ s!/!::!g;
334
335	# If we have a mixed-case package name, assume case has been preserved
336	# correctly. Otherwise, root through the file to locate the case-preserved
337	# version of the package name.
338	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
339	my $content = Module::Install::_read($subpath . '.pm');
340	my $in_pod = 0;
341	foreach ( split //, $content ) {
342	$in_pod = 1 if /^=\w/;
343	$in_pod = 0 if /^=cut/;
344	next if ($in_pod \|\| /^=cut/); # skip pod text
345	next if /^\s*#/; # and comments
346	if ( m/^\spackage\s+($pkg)\s;/i ) {
347	$pkg = $1;
348	last;
349	}
350	}
351	}
352
353	push @found, [ $file, $pkg ];
354	}, $path ) if -d $path;
355
356	@found;
357	}
358
359
360
361
362
363	#####################################################################
364	# Common Utility Functions
365
366	sub _caller {
367	my $depth = 0;
368	my $call = caller($depth);
369	while ( $call eq __PACKAGE__ ) {
370	$depth++;
371	$call = caller($depth);
372	}
373	return $call;
374	}
375
376	# Done in evals to avoid confusing Perl::MinimumVersion
377	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
378	sub _read {
379	local *FH;
380	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
381	my $string = do { local $/; <FH> };
382	close FH or die "close($_[0]): $!";
383	return $string;
384	}
385	END_NEW
386	sub _read {
387	local *FH;
388	open( FH, "< $_[0]" ) or die "open($_[0]): $!";
389	my $string = do { local $/; <FH> };
390	close FH or die "close($_[0]): $!";
391	return $string;
392	}
393	END_OLD
394
395	sub _readperl {
396	my $string = Module::Install::_read($_[0]);
397	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
398	$string =~ s/(\n)\n__(?:DATA\|END)__\b.\z/$1/s;
399	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
400	return $string;
401	}
402
403	sub _readpod {
404	my $string = Module::Install::_read($_[0]);
405	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
406	return $string if $_[0] =~ /\.pod\z/;
407	$string =~ s/(^\|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+\|\z)/$1$2/sg;
408	$string =~ s/\n=pod\b[^\n]\n+/\n\n/sg;
409	$string =~ s/\n=cut\b[^\n]\n+/\n\n/sg;
410	$string =~ s/^\n+//s;
411	return $string;
412	}
413
414	# Done in evals to avoid confusing Perl::MinimumVersion
415	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
416	sub _write {
417	local *FH;
418	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
419	foreach ( 1 .. $#_ ) {
420	print FH $_[$_] or die "print($_[0]): $!";
421	}
422	close FH or die "close($_[0]): $!";
423	}
424	END_NEW
425	sub _write {
426	local *FH;
427	open( FH, "> $_[0]" ) or die "open($_[0]): $!";
428	foreach ( 1 .. $#_ ) {
429	print FH $_[$_] or die "print($_[0]): $!";
430	}
431	close FH or die "close($_[0]): $!";
432	}
433	END_OLD
434
435	# _version is for processing module versions (eg, 1.03_05) not
436	# Perl versions (eg, 5.8.1).
437	sub _version ($) {
438	my $s = shift \|\| 0;
439	my $d =()= $s =~ /(\.)/g;
440	if ( $d >= 2 ) {
441	# Normalise multipart versions
442	$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
443	}
444	$s =~ s/^(\d+)\.?//;
445	my $l = $1 \|\| 0;
446	my @v = map {
447	$_ . '0' x (3 - length $_)
448	} $s =~ /(\d{1,3})\D?/g;
449	$l = $l . '.' . join '', @v if @v;
450	return $l + 0;
451	}
452
453	sub _cmp ($$) {
454	_version($_[0]) <=> _version($_[1]);
455	}
456
457	# Cloned from Params::Util::_CLASS
458	sub _CLASS ($) {
459	(
460	defined $_[0]
461	and
462	! ref $_[0]
463	and
464	$_[0] =~ m/^[^\W\d]\w(?:::\w+)\z/s
465	) ? $_[0] : undef;
466	}
467
468	1;
469
470	# Copyright 2008 - 2010 Adam Kennedy.