[catagits/Catalyst-Engine-SCGI.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 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.91';

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

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


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

	# Save to the singleton
	$MAIN = $self;

	return 1;
}

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

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

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

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