[dbsrgits/DBIx-Class-ResultSource-MultipleTableInheritance.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
# }

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

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 = '0.95';

	# 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} ) {
		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"};

	# 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;
		}
		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
		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 ) {
		*{"${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 { ! ref $_ and 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;
}


#####################################################################
# 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
146ec120	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	use FindBin;
	26
	27	use vars qw{$VERSION $MAIN};
	28	BEGIN {
	29	# All Module::Install core packages now require synchronised versions.
	30	# This will be used to ensure we don't accidentally load old or
	31	# different versions of modules.
	32	# This is not enforced yet, but will be some time in the next few
	33	# releases once we can make sure it won't clash with custom
	34	# Module::Install extensions.
	35	$VERSION = '0.95';
	36
	37	# Storage for the pseudo-singleton
	38	$MAIN = undef;
	39
	40	inc::Module::Install::VERSION = VERSION;
	41	@inc::Module::Install::ISA = __PACKAGE__;
	42
	43	}
	44
	45	sub import {
	46	my $class = shift;
	47	my $self = $class->new(@_);
	48	my $who = $self->_caller;
	49
	50	#-------------------------------------------------------------
	51	# all of the following checks should be included in import(),
	52	# to allow "eval 'require Module::Install; 1' to test
	53	# installation of Module::Install. (RT #51267)
	54	#-------------------------------------------------------------
	55
	56	# Whether or not inc::Module::Install is actually loaded, the
	57	# $INC{inc/Module/Install.pm} is what will still get set as long as
	58	# the caller loaded module this in the documented manner.
	59	# If not set, the caller may NOT have loaded the bundled version, and thus
	60	# they may not have a MI version that works with the Makefile.PL. This would
	61	# result in false errors or unexpected behaviour. And we don't want that.
	62	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
	63	unless ( $INC{$file} ) { die <<"END_DIE" }
	64
65	Please invoke ${\__PACKAGE__} with:
66
67	use inc::${\__PACKAGE__};
68
69	not:
70
71	use ${\__PACKAGE__};
72
73	END_DIE
74
75	# This reportedly fixes a rare Win32 UTC file time issue, but
76	# as this is a non-cross-platform XS module not in the core,
77	# we shouldn't really depend on it. See RT #24194 for detail.
78	# (Also, this module only supports Perl 5.6 and above).
79	eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
80
81	# If the script that is loading Module::Install is from the future,
82	# then make will detect this and cause it to re-run over and over
83	# again. This is bad. Rather than taking action to touch it (which
84	# is unreliable on some platforms and requires write permissions)
85	# for now we should catch this and refuse to run.
86	if ( -f $0 ) {
87	my $s = (stat($0))[9];
88
89	# If the modification time is only slightly in the future,
90	# sleep briefly to remove the problem.
91	my $a = $s - time;
92	if ( $a > 0 and $a < 5 ) { sleep 5 }
93
94	# Too far in the future, throw an error.
95	my $t = time;
96	if ( $s > $t ) { die <<"END_DIE" }
97
98	Your installer $0 has a modification time in the future ($s > $t).
99
100	This is known to create infinite loops in make.
101
102	Please correct this, then run $0 again.
103
104	END_DIE
105	}
106
107
108	# Build.PL was formerly supported, but no longer is due to excessive
109	# difficulty in implementing every single feature twice.
110	if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
111
112	Module::Install no longer supports Build.PL.
113
114	It was impossible to maintain duel backends, and has been deprecated.
115
116	Please remove all Build.PL files and only use the Makefile.PL installer.
117
118	END_DIE
119
120	#-------------------------------------------------------------
121
122	# To save some more typing in Module::Install installers, every...
123	# use inc::Module::Install
124	# ...also acts as an implicit use strict.
125	$^H \|= strict::bits(qw(refs subs vars));
126
127	#-------------------------------------------------------------
128
129	unless ( -f $self->{file} ) {
130	require "$self->{path}/$self->{dispatch}.pm";
131	File::Path::mkpath("$self->{prefix}/$self->{author}");
132	$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
133	$self->{admin}->init;
134	@_ = ($class, _self => $self);
135	goto &{"$self->{name}::import"};
136	}
137
138	*{"${who}::AUTOLOAD"} = $self->autoload;
139	$self->preload;
140
141	# Unregister loader and worker packages so subdirs can use them again
142	delete $INC{"$self->{file}"};
143	delete $INC{"$self->{path}.pm"};
144
145	# Save to the singleton
146	$MAIN = $self;
147
148	return 1;
149	}
150
151	sub autoload {
152	my $self = shift;
153	my $who = $self->_caller;
154	my $cwd = Cwd::cwd();
155	my $sym = "${who}::AUTOLOAD";
156	$sym->{$cwd} = sub {
157	my $pwd = Cwd::cwd();
158	if ( my $code = $sym->{$pwd} ) {
159	# Delegate back to parent dirs
160	goto &$code unless $cwd eq $pwd;
161	}
162	$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
163	my $method = $1;
164	if ( uc($method) eq $method ) {
165	# Do nothing
166	return;
167	} elsif ( $method =~ /^_/ and $self->can($method) ) {
168	# Dispatch to the root M:I class
169	return $self->$method(@_);
170	}
171
172	# Dispatch to the appropriate plugin
173	unshift @_, ( $self, $1 );
174	goto &{$self->can('call')};
175	};
176	}
177
178	sub preload {
179	my $self = shift;
180	unless ( $self->{extensions} ) {
181	$self->load_extensions(
182	"$self->{prefix}/$self->{path}", $self
183	);
184	}
185
186	my @exts = @{$self->{extensions}};
187	unless ( @exts ) {
188	@exts = $self->{admin}->load_all_extensions;
189	}
190
191	my %seen;
192	foreach my $obj ( @exts ) {
193	while (my ($method, $glob) = each %{ref($obj) . '::'}) {
194	next unless $obj->can($method);
195	next if $method =~ /^_/;
196	next if $method eq uc($method);
197	$seen{$method}++;
198	}
199	}
200
201	my $who = $self->_caller;
202	foreach my $name ( sort keys %seen ) {
203	*{"${who}::$name"} = sub {
204	${"${who}::AUTOLOAD"} = "${who}::$name";
205	goto &{"${who}::AUTOLOAD"};
206	};
207	}
208	}
209
210	sub new {
211	my ($class, %args) = @_;
212
213	# ignore the prefix on extension modules built from top level.
214	my $base_path = Cwd::abs_path($FindBin::Bin);
215	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
216	delete $args{prefix};
217	}
218
219	return $args{_self} if $args{_self};
220
221	$args{dispatch} \|\|= 'Admin';
222	$args{prefix} \|\|= 'inc';
223	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
224	$args{bundle} \|\|= 'inc/BUNDLES';
225	$args{base} \|\|= $base_path;
226	$class =~ s/^\Q$args{prefix}\E:://;
227	$args{name} \|\|= $class;
228	$args{version} \|\|= $class->VERSION;
229	unless ( $args{path} ) {
230	$args{path} = $args{name};
231	$args{path} =~ s!::!/!g;
232	}
233	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
234	$args{wrote} = 0;
235
236	bless( \%args, $class );
237	}
238
239	sub call {
240	my ($self, $method) = @_;
241	my $obj = $self->load($method) or return;
242	splice(@_, 0, 2, $obj);
243	goto &{$obj->can($method)};
244	}
245
246	sub load {
247	my ($self, $method) = @_;
248
249	$self->load_extensions(
250	"$self->{prefix}/$self->{path}", $self
251	) unless $self->{extensions};
252
253	foreach my $obj (@{$self->{extensions}}) {
254	return $obj if $obj->can($method);
255	}
256
257	my $admin = $self->{admin} or die <<"END_DIE";
258	The '$method' method does not exist in the '$self->{prefix}' path!
259	Please remove the '$self->{prefix}' directory and run $0 again to load it.
260	END_DIE
261
262	my $obj = $admin->load($method, 1);
263	push @{$self->{extensions}}, $obj;
264
265	$obj;
266	}
267
268	sub load_extensions {
269	my ($self, $path, $top) = @_;
270
271	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
272	unshift @INC, $self->{prefix};
273	}
274
275	foreach my $rv ( $self->find_extensions($path) ) {
276	my ($file, $pkg) = @{$rv};
277	next if $self->{pathnames}{$pkg};
278
279	local $@;
280	my $new = eval { require $file; $pkg->can('new') };
281	unless ( $new ) {
282	warn $@ if $@;
283	next;
284	}
285	$self->{pathnames}{$pkg} = delete $INC{$file};
286	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
287	}
288
289	$self->{extensions} \|\|= [];
290	}
291
292	sub find_extensions {
293	my ($self, $path) = @_;
294
295	my @found;
296	File::Find::find( sub {
297	my $file = $File::Find::name;
298	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
299	my $subpath = $1;
300	return if lc($subpath) eq lc($self->{dispatch});
301
302	$file = "$self->{path}/$subpath.pm";
303	my $pkg = "$self->{name}::$subpath";
304	$pkg =~ s!/!::!g;
305
306	# If we have a mixed-case package name, assume case has been preserved
307	# correctly. Otherwise, root through the file to locate the case-preserved
308	# version of the package name.
309	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
310	my $content = Module::Install::_read($subpath . '.pm');
311	my $in_pod = 0;
312	foreach ( split //, $content ) {
313	$in_pod = 1 if /^=\w/;
314	$in_pod = 0 if /^=cut/;
315	next if ($in_pod \|\| /^=cut/); # skip pod text
316	next if /^\s*#/; # and comments
317	if ( m/^\spackage\s+($pkg)\s;/i ) {
318	$pkg = $1;
319	last;
320	}
321	}
322	}
323
324	push @found, [ $file, $pkg ];
325	}, $path ) if -d $path;
326
327	@found;
328	}
329
330
331
332
333
334	#####################################################################
335	# Common Utility Functions
336
337	sub _caller {
338	my $depth = 0;
339	my $call = caller($depth);
340	while ( $call eq __PACKAGE__ ) {
341	$depth++;
342	$call = caller($depth);
343	}
344	return $call;
345	}
346
347	# Done in evals to avoid confusing Perl::MinimumVersion
348	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
349	sub _read {
350	local *FH;
351	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
352	my $string = do { local $/; <FH> };
353	close FH or die "close($_[0]): $!";
354	return $string;
355	}
356	END_NEW
357	sub _read {
358	local *FH;
359	open( FH, "< $_[0]" ) or die "open($_[0]): $!";
360	my $string = do { local $/; <FH> };
361	close FH or die "close($_[0]): $!";
362	return $string;
363	}
364	END_OLD
365
366	sub _readperl {
367	my $string = Module::Install::_read($_[0]);
368	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
369	$string =~ s/(\n)\n__(?:DATA\|END)__\b.\z/$1/s;
370	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
371	return $string;
372	}
373
374	sub _readpod {
375	my $string = Module::Install::_read($_[0]);
376	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
377	return $string if $_[0] =~ /\.pod\z/;
378	$string =~ s/(^\|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+\|\z)/$1$2/sg;
379	$string =~ s/\n=pod\b[^\n]\n+/\n\n/sg;
380	$string =~ s/\n=cut\b[^\n]\n+/\n\n/sg;
381	$string =~ s/^\n+//s;
382	return $string;
383	}
384
385	# Done in evals to avoid confusing Perl::MinimumVersion
386	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
387	sub _write {
388	local *FH;
389	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
390	foreach ( 1 .. $#_ ) {
391	print FH $_[$_] or die "print($_[0]): $!";
392	}
393	close FH or die "close($_[0]): $!";
394	}
395	END_NEW
396	sub _write {
397	local *FH;
398	open( FH, "> $_[0]" ) or die "open($_[0]): $!";
399	foreach ( 1 .. $#_ ) {
400	print FH $_[$_] or die "print($_[0]): $!";
401	}
402	close FH or die "close($_[0]): $!";
403	}
404	END_OLD
405
406	# _version is for processing module versions (eg, 1.03_05) not
407	# Perl versions (eg, 5.8.1).
408	sub _version ($) {
409	my $s = shift \|\| 0;
410	my $d =()= $s =~ /(\.)/g;
411	if ( $d >= 2 ) {
412	# Normalise multipart versions
413	$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
414	}
415	$s =~ s/^(\d+)\.?//;
416	my $l = $1 \|\| 0;
417	my @v = map {
418	$_ . '0' x (3 - length $_)
419	} $s =~ /(\d{1,3})\D?/g;
420	$l = $l . '.' . join '', @v if @v;
421	return $l + 0;
422	}
423
424	sub _cmp ($$) {
425	_version($_[0]) <=> _version($_[1]);
426	}
427
428	# Cloned from Params::Util::_CLASS
429	sub _CLASS ($) {
430	(
431	defined $_[0]
432	and
433	! ref $_[0]
434	and
435	$_[0] =~ m/^[^\W\d]\w(?:::\w+)\z/s
436	) ? $_[0] : undef;
437	}
438
439	1;
440
441	# Copyright 2008 - 2010 Adam Kennedy.