Commit f57239a42a28fb4aec0397a753477ecadb15c7ad - libclass-returnvalue-perl

[svn-inject] Installing original source of libclass-returnvalue-perl Niko Tyni 17 years ago

20 changed file(s) with 2800 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all

+28

-0

Changes less more

	0	Revision history for Perl extension Return::Value.
	1
	2	0.53 Mon May 30 16:52:44 EDT 2005
	3	- sub error_condition returns undef, not 0 -- Thanks to Dave Glasser
	4
	5	0.52 Oct 08, 2003
	6	- Ported to Module::Install
	7
	8	0.40 Sept 15, 2002
	9	- MAJOR API CHANGES. (to fix some bugs in trying to marshall into an
	10	array directly)
	11
	12	0.22 Wed Aug 14 21:02:18 EDT 2002
	13	- Fixing dependency list
	14
	15	0.21 Fri Jul 5 23:49:23 EDT 2002
	16	- Fixing test suite bugs.
	17
	18	0.20 Fri Jul 5 17:49:23 EDT 2002
	19	- Depend on Devel::StackTrace
	20	- Add a couple new accessors
	21	- Fixed a crashing bug on 5.6.1 which toasted when evaluating as a boolean
	22
	23
	24	0.01 Fri Jan 18 14:21:03 2002
	25	- original version; created by h2xs 1.1.1.4 with options
	26	-X -A -n Return::Value
	27

+20

-0

MANIFEST less more

	0	Changes
	1	MANIFEST
	2	MANIFEST.SKIP
	3	META.yml
	4	Makefile.PL
	5	SIGNATURE
	6	inc/Module/Install.pm
	7	inc/Module/Install/Base.pm
	8	inc/Module/Install/Can.pm
	9	inc/Module/Install/Fetch.pm
	10	inc/Module/Install/Include.pm
	11	inc/Module/Install/Makefile.pm
	12	inc/Module/Install/Metadata.pm
	13	inc/Module/Install/Win32.pm
	14	inc/Test/Builder.pm
	15	inc/Test/Inline.pm
	16	inc/Test/More.pm
	17	lib/Class/ReturnValue.pm
	18	t/embedded-Class-ReturnValue.t
	19	t/test.pl

-0

MANIFEST.SKIP less more

	0	^config$
	1	^aegis.log$
	2	^Makefile$
	3	^blib/
	4	^pm_to_blib/

+14

-0

META.yml less more

	0	name: Class-ReturnValue
	1	version: 0.52
	2	abstract: A smart return value object
	3	author: Jesse Vincent <jesse@bestpractical.com>
	4	license: perl
	5	distribution_type: module
	6	requires:
	7	Test::More: 0
	8	Test::Inline: 0
	9	Devel::StackTrace: 0
	10	private:
	11	directory:
	12	- inc
	13	generated_by: Module::Install version 0.24

+44

-0

Makefile.PL less more

	0	use inc::Module::Install;
	1
	2	name('Class-ReturnValue');
	3	abstract('A smart return value object');
	4	author('Jesse Vincent <jesse@bestpractical.com>');
	5	version_from('lib/Class/ReturnValue.pm');
	6	license('perl');
	7	include_deps('Test::More', 5.004);
	8	include_deps('Test::Inline');
	9	requires('Test::More');
	10	requires('Test::Inline');
	11	requires('Devel::StackTrace');
	12	check_nmake(); # check and download nmake.exe for Win32
	13
	14
	15	{
	16
	17	package MY;
	18
	19	sub top_targets {
	20	my ($self) = @_;
	21	my $out = "POD2TEST_EXE = pod2test\n";
	22
	23	$out .= $self->SUPER::top_targets(@_);
	24	# $out =~ s/^(pure_all\b.*)/$1 testifypods/m;
	25
	26	$out .= "\n\ntestifypods : \n";
	27	foreach
	28	my $pod ( keys %{ $self->{MAN1PODS} }, keys %{ $self->{MAN3PODS} } )
	29	{
	30	( my $test = $pod ) =~ s/\.(pm\|pod)$//;
	31	$test =~ s\|/\|-\|g;
	32	$test =~ s/^lib\W//;
	33	$test =~ s/\W/-/;
	34	$test = "embedded-$test.t";
	35	$out .= "\t$self->{NOECHO}\$(POD2TEST_EXE) " . "$pod t/$test\n";
	36	}
	37
	38	return $out;
	39	}
	40	}
	41	&Meta->write;
	42	&Makefile->write;
	43

+42

-0

SIGNATURE less more

	0	This file contains message digests of all files listed in MANIFEST,
	1	signed via the Module::Signature module, version 0.41.
	2
	3	To verify the content in this distribution, first make sure you have
	4	Module::Signature installed, then type:
	5
	6	% cpansign -v
	7
	8	It would check each file's integrity, as well as the signature's
	9	validity. If "==> Signature verified OK! <==" is not displayed,
	10	the distribution may already have been compromised, and you should
	11	not run its Makefile.PL or Build.PL.
	12
	13	-----BEGIN PGP SIGNED MESSAGE-----
	14	Hash: SHA1
	15
	16	SHA1 1d082cfa58708b57d74c5e453041dda607bfcdcf Changes
	17	SHA1 e06b8d9a55f965cd4427f24931ff9c3a08c04ac9 MANIFEST
	18	SHA1 4569b321148f7fbc4c6ac1b2fa0db2b430fdec34 MANIFEST.SKIP
	19	SHA1 e4ec7f27c1dea6aa535a6d1eaee71966a1db97f0 META.yml
	20	SHA1 eeafb4c5e01576e377bf8e069e08209e75081689 Makefile.PL
	21	SHA1 f9569c4340d4105598a318f7c736e2a10108347e inc/Module/Install.pm
	22	SHA1 adfe7bd31491c5499b508340aa6d1af75b39160e inc/Module/Install/Base.pm
	23	SHA1 c5e4dd819a1bd9613e95a47ace2a4558f32eef53 inc/Module/Install/Can.pm
	24	SHA1 fc88b7b683e3f0527b05ee500ee41eb379df1432 inc/Module/Install/Fetch.pm
	25	SHA1 1a1269cea863bf5a9a4446034e4353002fd29d98 inc/Module/Install/Include.pm
	26	SHA1 107ac73515efc2b423994623342b4f7faf898000 inc/Module/Install/Makefile.pm
	27	SHA1 02a89263781b0a3364d09c3c8f2bafb83f1f4549 inc/Module/Install/Metadata.pm
	28	SHA1 eb3a15cf26737881d10b02c51d5074cc9fe10443 inc/Module/Install/Win32.pm
	29	SHA1 cfdbe8918158c2f562661cbbed3888e37f8a4c22 inc/Test/Builder.pm
	30	SHA1 eaf48bc02c21d258a46dee904fc74bbf6ed7db7b inc/Test/Inline.pm
	31	SHA1 8103929b0ee190d2f99bdb020221ce2f7de5c08e inc/Test/More.pm
	32	SHA1 215bc6bc8876a08af60666259e072abfa5e2db00 lib/Class/ReturnValue.pm
	33	SHA1 155549e6689decabf90abc4283f737bc356d933b t/embedded-Class-ReturnValue.t
	34	SHA1 b063c38d2d3be785585c1e0d0d12e66bb790889c t/test.pl
	35	-----BEGIN PGP SIGNATURE-----
	36	Version: GnuPG v1.2.5 (GNU/Linux)
	37
	38	iD8DBQFCm349Ei9d9xCOQEYRAoy9AJwLy8KANGuLqjXSQkGNPOb2UBsw2QCdFCdb
	39	MLKFMSOzZFbT/kAbmvh7ZLk=
	40	=x+Lq
	41	-----END PGP SIGNATURE-----

+57

-0

inc/Module/Install/Base.pm less more

	0	#line 1 "inc/Module/Install/Base.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Base.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Base.pm $ $Author: autrijus $
	2	# $Revision: #9 $ $Change: 1665 $ $DateTime: 2003/08/18 07:52:47 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Base;
	5
	6	#line 31
	7
	8	sub new {
	9	my ($class, %args) = @_;
	10
	11	foreach my $method (qw(call load)) {
	12	*{"$class\::$method"} = sub {
	13	+shift->_top->$method(@_);
	14	} unless defined &{"$class\::$method"};
	15	}
	16
	17	bless(\%args, $class);
	18	}
	19
	20	#line 49
	21
	22	sub AUTOLOAD {
	23	my $self = shift;
	24	goto &{$self->_top->autoload};
	25	}
	26
	27	#line 60
	28
	29	sub _top { $_[0]->{_top} }
	30
	31	#line 71
	32
	33	sub admin {
	34	my $self = shift;
	35	$self->_top->{admin} or Module::Install::Base::FakeAdmin->new;
	36	}
	37
	38	sub is_admin {
	39	my $self = shift;
	40	$self->admin->VERSION;
	41	}
	42
	43	sub DESTROY {}
	44
	45	package Module::Install::Base::FakeAdmin;
	46
	47	my $Fake;
	48	sub new { $Fake \|\|= bless(\@_, $_[0]) }
	49	sub AUTOLOAD {}
	50	sub DESTROY {}
	51
	52	1;
	53
	54	__END__
	55
	56	#line 115

+36

-0

inc/Module/Install/Can.pm less more

	0	#line 1 "inc/Module/Install/Can.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Can.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Can.pm $ $Author: ingy $
	2	# $Revision: #5 $ $Change: 1377 $ $DateTime: 2003/03/20 15:11:54 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Can;
	5	use Module::Install::Base; @ISA = qw(Module::Install::Base);
	6	$VERSION = '0.01';
	7	use strict;
	8
	9	# check if we can run some command
	10	sub can_run {
	11	my ($self, $cmd) = @_;
	12
	13	require Config;
	14	require File::Spec;
	15	require ExtUtils::MakeMaker;
	16
	17	my $_cmd = $cmd;
	18	return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
	19
	20	for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
	21	my $abs = File::Spec->catfile($dir, $_[1]);
	22	return $abs if (-x $abs or $abs = MM->maybe_command($abs));
	23	}
	24
	25	return;
	26	}
	27
	28	sub can_cc {
	29	my $self = shift;
	30	require Config;
	31	my $cc = $Config::Config{cc} or return;
	32	$self->can_run($cc);
	33	}
	34
	35	1;

+89

-0

inc/Module/Install/Fetch.pm less more

	0	#line 1 "inc/Module/Install/Fetch.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Fetch.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Fetch.pm $ $Author: autrijus $
	2	# $Revision: #8 $ $Change: 1374 $ $DateTime: 2003/03/18 11:50:15 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Fetch;
	5	use Module::Install::Base; @ISA = qw(Module::Install::Base);
	6
	7	$VERSION = '0.01';
	8
	9	sub get_file {
	10	my ($self, %args) = @_;
	11	my ($scheme, $host, $path, $file) =
	12	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
	13
	14	if ($scheme eq 'http' and !eval { require LWP::Simple; 1 }) {
	15	$args{url} = $args{ftp_url}
	16	or (warn("LWP support unavailable!\n"), return);
	17	($scheme, $host, $path, $file) =
	18	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
	19	}
	20
	21	$\|++;
	22	print "Fetching '$file' from $host... ";
	23
	24	unless (eval { require Socket; Socket::inet_aton($host) }) {
	25	warn "'$host' resolve failed!\n";
	26	return;
	27	}
	28
	29	return unless $scheme eq 'ftp' or $scheme eq 'http';
	30
	31	require Cwd;
	32	my $dir = Cwd::getcwd();
	33	chdir $args{local_dir} or return if exists $args{local_dir};
	34
	35	if (eval { require LWP::Simple; 1 }) {
	36	LWP::Simple::mirror($args{url}, $file);
	37	}
	38	elsif (eval { require Net::FTP; 1 }) { eval {
	39	# use Net::FTP to get past firewall
	40	my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
	41	$ftp->login("anonymous", 'anonymous@example.com');
	42	$ftp->cwd($path);
	43	$ftp->binary;
	44	$ftp->get($file) or (warn("$!\n"), return);
	45	$ftp->quit;
	46	} }
	47	elsif (my $ftp = $self->can_run('ftp')) { eval {
	48	# no Net::FTP, fallback to ftp.exe
	49	require FileHandle;
	50	my $fh = FileHandle->new;
	51
	52	local $SIG{CHLD} = 'IGNORE';
	53	unless ($fh->open("\|$ftp -n")) {
	54	warn "Couldn't open ftp: $!\n";
	55	chdir $dir; return;
	56	}
	57
	58	my @dialog = split(/\n/, << ".");
	59	open $host
	60	user anonymous anonymous\@example.com
	61	cd $path
	62	binary
	63	get $file $file
	64	quit
	65	.
	66	foreach (@dialog) { $fh->print("$_\n") }
	67	$fh->close;
	68	} }
	69	else {
	70	warn "No working 'ftp' program available!\n";
	71	chdir $dir; return;
	72	}
	73
	74	unless (-f $file) {
	75	warn "Fetching failed: $@\n";
	76	chdir $dir; return;
	77	}
	78
	79	return if exists $args{size} and -s $file != $args{size};
	80	system($args{run}) if exists $args{run};
	81	unlink($file) if $args{remove};
	82
	83	print(((!exists $args{check_for} or -e $args{check_for})
	84	? "done!" : "failed! ($!)"), "\n");
	85	chdir $dir; return !$?;
	86	}
	87
	88	1;

+26

-0

inc/Module/Install/Include.pm less more

	0	#line 1 "inc/Module/Install/Include.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Include.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Include.pm $ $Author: autrijus $
	2	# $Revision: #7 $ $Change: 1375 $ $DateTime: 2003/03/18 12:29:32 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Include;
	5	use Module::Install::Base; @ISA = qw(Module::Install::Base);
	6
	7	sub include {
	8	my ($self, $pattern) = @_;
	9
	10	foreach my $rv ( $self->admin->glob_in_inc($pattern) ) {
	11	$self->admin->copy_package(@$rv);
	12	}
	13	return $file;
	14	}
	15
	16	sub include_deps {
	17	my ($self, $pkg, $perl_version) = @_;
	18	my $deps = $self->admin->scan_dependencies($pkg, $perl_version) or return;
	19
	20	foreach my $key (sort keys %$deps) {
	21	$self->include($key, $deps->{$key});
	22	}
	23	}
	24
	25	1;

+113

-0

inc/Module/Install/Makefile.pm less more

	0	#line 1 "inc/Module/Install/Makefile.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Makefile.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Makefile.pm $ $Author: autrijus $
	2	# $Revision: #45 $ $Change: 1645 $ $DateTime: 2003/07/16 01:05:06 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Makefile;
	5	use Module::Install::Base; @ISA = qw(Module::Install::Base);
	6
	7	$VERSION = '0.01';
	8
	9	use strict 'vars';
	10	use vars '$VERSION';
	11
	12	use ExtUtils::MakeMaker ();
	13
	14	sub Makefile { $_[0] }
	15
	16	sub prompt {
	17	shift;
	18	goto &ExtUtils::MakeMaker::prompt;
	19	}
	20
	21	sub makemaker_args {
	22	my $self = shift;
	23	my $args = ($self->{makemaker_args} \|\|= {});
	24	%$args = ( %$args, @_ ) if @_;
	25	$args;
	26	}
	27
	28	sub clean_files {
	29	my $self = shift;
	30	$self->makemaker_args( clean => { FILES => "@_ " } );
	31	}
	32
	33	sub write {
	34	my $self = shift;
	35	die "&Makefile->write() takes no arguments\n" if @_;
	36
	37	my $args = $self->makemaker_args;
	38
	39	$args->{DISTNAME} = $self->name;
	40	$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);
	41	$args->{VERSION} = $self->version \|\| $self->determine_VERSION($args);
	42	$args->{NAME} =~ s/-/::/g;
	43
	44	if ($] >= 5.005) {
	45	$args->{ABSTRACT} = $self->abstract;
	46	$args->{AUTHOR} = $self->author;
	47	}
	48	if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 )
	49	{
	50	$args->{NO_META} = 1;
	51	}
	52
	53	# merge both kinds of requires into prereq_pm
	54	my $prereq = ($args->{PREREQ_PM} \|\|= {});
	55	%$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
	56	($self->build_requires, $self->requires) );
	57
	58	# merge both kinds of requires into prereq_pm
	59	my $dir = ($args->{DIR} \|\|= []);
	60	push @$dir, map "$self->{prefix}/$self->{bundle}/$_->[1]", @{$self->bundles}
	61	if $self->bundles;
	62
	63	my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args;
	64
	65	if ($self->admin->preop) {
	66	$args{dist} = $self->admin->preop;
	67	}
	68
	69	ExtUtils::MakeMaker::WriteMakefile(%args);
	70
	71	$self->fix_up_makefile();
	72	}
	73
	74	sub fix_up_makefile {
	75	my $self = shift;
	76	my $top_class = ref($self->_top) \|\| '';
	77	my $top_version = $self->_top->VERSION \|\| '';
	78
	79	my $preamble = $self->preamble
	80	? "# Preamble by $top_class $top_version\n" . $self->preamble
	81	: '';
	82	my $postamble = "# Postamble by $top_class $top_version\n" .
	83	($self->postamble \|\| '');
	84
	85	open MAKEFILE, '< Makefile' or die $!;
	86	my $makefile = do { local $/; <MAKEFILE> };
	87	close MAKEFILE;
	88
	89	open MAKEFILE, '> Makefile' or die $!;
	90	print MAKEFILE "$preamble$makefile$postamble";
	91	close MAKEFILE;
	92	}
	93
	94	sub preamble {
	95	my ($self, $text) = @_;
	96	$self->{preamble} = $text . $self->{preamble} if defined $text;
	97	$self->{preamble};
	98	}
	99
	100	sub postamble {
	101	my ($self, $text) = @_;
	102
	103	$self->{postamble} \|\|= $self->admin->postamble;
	104	$self->{postamble} .= $text if defined $text;
	105	$self->{postamble}
	106	}
	107
	108	1;
	109
	110	__END__
	111
	112	#line 242

+126

-0

inc/Module/Install/Metadata.pm less more

	0	#line 1 "inc/Module/Install/Metadata.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Metadata.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Metadata.pm $ $Author: autrijus $
	2	# $Revision: #25 $ $Change: 1665 $ $DateTime: 2003/08/18 07:52:47 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Metadata;
	5	use Module::Install::Base; @ISA = qw(Module::Install::Base);
	6
	7	$VERSION = '0.01';
	8
	9	use strict 'vars';
	10	use vars qw($VERSION);
	11
	12	sub Meta { shift }
	13
	14	my @scalar_keys = qw(name module_name version abstract author license distribution_type);
	15	my @tuple_keys = qw(build_requires requires recommends bundles);
	16
	17	foreach my $key (@scalar_keys) {
	18	*$key = sub {
	19	my $self = shift;
	20	return $self->{values}{$key} unless @_;
	21	$self->{values}{$key} = shift;
	22	return $self;
	23	};
	24	}
	25
	26	foreach my $key (@tuple_keys) {
	27	*$key = sub {
	28	my $self = shift;
	29	return $self->{values}{$key} unless @_;
	30	my @rv;
	31	while (@_) {
	32	my $module = shift or last;
	33	my $version = shift \|\| 0;
	34	my $rv = [$module, $version];
	35	push @{$self->{values}{$key}}, $rv;
	36	push @rv, $rv;
	37	}
	38	return @rv;
	39	};
	40	}
	41
	42	sub features {
	43	my $self = shift;
	44	while (my ($name, $mods) = splice(@_, 0, 2)) {
	45	my $count = 0;
	46	push @{$self->{values}{features}}, ($name => [
	47	map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods
	48	] );
	49	}
	50	return @{$self->{values}{features}};
	51	}
	52
	53	sub _dump {
	54	my $self = shift;
	55	my $package = ref($self->_top);
	56	my $version = $self->_top->VERSION;
	57	my %values = %{$self->{values}};
	58	$values{distribution_type} \|\|= 'module';
	59	$values{name} \|\|= do {
	60	my $name = $values{module_name};
	61	$name =~ s/::/-/g;
	62	$name;
	63	} if $values{module_name};
	64
	65	my $dump = '';
	66	foreach my $key (@scalar_keys) {
	67	$dump .= "$key: $values{$key}\n" if exists $values{$key};
	68	}
	69	foreach my $key (@tuple_keys) {
	70	next unless exists $values{$key};
	71	$dump .= "$key:\n";
	72	$dump .= " $_->[0]: $_->[1]\n" for @{$values{$key}};
	73	}
	74
	75	return($dump . "private:\n directory:\n - inc\ngenerated_by: $package version $version\n");
	76	}
	77
	78	sub read {
	79	my $self = shift;
	80	$self->include_deps( 'YAML', 0 );
	81	require YAML;
	82	my $data = YAML::LoadFile( 'META.yml' );
	83	# Call methods explicitly in case user has already set some values.
	84	while ( my ($key, $value) = each %$data ) {
	85	next unless $self->can( $key );
	86	if (ref $value eq 'HASH') {
	87	while (my ($module, $version) = each %$value) {
	88	$self->$key( $module => $version );
	89	}
	90	}
	91	else {
	92	$self->$key( $value );
	93	}
	94	}
	95	return $self;
	96	}
	97
	98	sub write {
	99	my $self = shift;
	100	return $self unless $self->is_admin;
	101
	102	META_NOT_OURS: {
	103	local *FH;
	104	if (open FH, "META.yml") {
	105	while (<FH>) {
	106	last META_NOT_OURS if /^generated_by: Module::Install\b/;
	107	}
	108	return $self;
	109	}
	110	}
	111
	112	warn "Writing META.yml\n";
	113	open META, "> META.yml" or warn "Cannot write to META.yml: $!";
	114	print META $self->_dump;
	115	close META;
	116	return $self;
	117	}
	118
	119	sub version_from {
	120	my ($self, $version_from) = @_;
	121	require ExtUtils::MM_Unix;
	122	$self->version(ExtUtils::MM_Unix->parse_version($version_from));
	123	}
	124
	125	1;

+65

-0

inc/Module/Install/Win32.pm less more

	0	#line 1 "inc/Module/Install/Win32.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install/Win32.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install/Win32.pm $ $Author: autrijus $
	2	# $Revision: #8 $ $Change: 1374 $ $DateTime: 2003/03/18 11:50:15 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install::Win32;
	5	use Module::Install::Base; @ISA = qw(Module::Install::Base);
	6
	7	$VERSION = '0.01';
	8
	9	use strict;
	10
	11	# determine if the user needs nmake, and download it if needed
	12	sub check_nmake {
	13	my $self = shift;
	14	$self->load('can_run');
	15	$self->load('get_file');
	16
	17	require Config;
	18	return unless (
	19	$Config::Config{make} and
	20	$Config::Config{make} =~ /^nmake\b/i and
	21	$^O eq 'MSWin32' and
	22	!$self->can_run('nmake')
	23	);
	24
	25	print "The required 'nmake' executable not found, fetching it...\n";
	26
	27	require File::Basename;
	28	my $rv = $self->get_file(
	29	url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/nmake15.exe',
	30	ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe',
	31	local_dir => File::Basename::dirname($^X),
	32	size => 51928,
	33	run => 'nmake15.exe /o > nul',
	34	check_for => 'nmake.exe',
	35	remove => 1,
	36	);
	37
	38	if (!$rv) {
	39	die << '.';
	40
	41	-------------------------------------------------------------------------------
	42
	43	Since you are using Microsoft Windows, you will need the 'nmake' utility
	44	before installation. It's available at:
	45
	46	http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/nmake15.exe
	47	ftp://ftp.microsoft.com/Softlib/MSLFILES/nmake15.exe
	48
	49	Please download the file manually, save it to a directory in %PATH (e.g.
	50	C:\WINDOWS\COMMAND), then launch the MS-DOS command line shell, "cd" to
	51	that directory, and run "nmake15.exe" from there; that will create the
	52	'nmake.exe' file needed by this module.
	53
	54	You may then resume the installation process described in README.
	55
	56	-------------------------------------------------------------------------------
	57	.
	58	}
	59	}
	60
	61	1;
	62
	63	__END__
	64

+157

-0

inc/Module/Install.pm less more

	0	#line 1 "inc/Module/Install.pm - /opt/perl-5.8.0/lib/site_perl/Module/Install.pm"
	1	# $File: //depot/cpan/Module-Install/lib/Module/Install.pm $ $Author: autrijus $
	2	# $Revision: #58 $ $Change: 1709 $ $DateTime: 2003/09/01 03:13:10 $ vim: expandtab shiftwidth=4
	3
	4	package Module::Install;
	5	$VERSION = '0.24';
	6
	7	die <<END unless defined $INC{'inc/Module/Install.pm'};
	8	Please invoke Module::Install with:
	9
	10	use inc::Module::Install;
	11
	12	not:
	13
	14	use Module::Install;
	15
	16	END
	17
	18	use strict 'vars';
	19	use File::Find;
	20	use File::Path;
	21
	22	@inc::Module::Install::ISA = 'Module::Install';
	23
	24	#line 127
	25
	26	sub import {
	27	my $class = $_[0];
	28	my $self = $class->new(@_[1..$#_]);
	29
	30	if (not -f $self->{file}) {
	31	require "$self->{path}/$self->{dispatch}.pm";
	32	mkpath "$self->{prefix}/$self->{author}";
	33	$self->{admin} =
	34	"$self->{name}::$self->{dispatch}"->new(_top => $self);
	35	$self->{admin}->init;
	36	@_ = ($class, _self => $self);
	37	goto &{"$self->{name}::import"};
	38	}
	39
	40	*{caller(0) . "::AUTOLOAD"} = $self->autoload;
	41	}
	42
	43	#line 150
	44
	45	sub autoload {
	46	my $self = shift;
	47	my $caller = caller;
	48	sub {
	49	${"$caller\::AUTOLOAD"} =~ /([^:]+)$/ or die "Cannot autoload $caller";
	50	unshift @_, ($self, $1);
	51	goto &{$self->can('call')} unless uc($1) eq $1;
	52	};
	53	}
	54
	55	#line 167
	56
	57	sub new {
	58	my ($class, %args) = @_;
	59
	60	return $args{_self} if $args{_self};
	61
	62	$args{dispatch} \|\|= 'Admin';
	63	$args{prefix} \|\|= 'inc';
	64	$args{author} \|\|= '.author';
	65	$args{bundle} \|\|= '_bundle';
	66
	67	$class =~ s/^\Q$args{prefix}\E:://;
	68	$args{name} \|\|= $class;
	69	$args{version} \|\|= $class->VERSION;
	70	unless ($args{path}) {
	71	$args{path} = $args{name};
	72	$args{path} =~ s!::!/!g;
	73	}
	74	$args{file} \|\|= "$args{prefix}/$args{path}.pm";
	75
	76	bless(\%args, $class);
	77	}
	78
	79	#line 195
	80
	81	sub call {
	82	my $self = shift;
	83	my $method = shift;
	84	my $obj = $self->load($method) or return;
	85
	86	unshift @_, $obj;
	87	goto &{$obj->can($method)};
	88	}
	89
	90	#line 210
	91
	92	sub load {
	93	my ($self, $method) = @_;
	94
	95	$self->load_extensions(
	96	"$self->{prefix}/$self->{path}", $self
	97	) unless $self->{extensions};
	98
	99	foreach my $obj (@{$self->{extensions}}) {
	100	return $obj if $obj->can($method);
	101	}
	102
	103	my $admin = $self->{admin} or die << "END";
	104	The '$method' method does not exist in the '$self->{prefix}' path!
	105	Please remove the '$self->{prefix}' directory and run $0 again to load it.
	106	END
	107
	108	my $obj = $admin->load($method, 1);
	109	push @{$self->{extensions}}, $obj;
	110
	111	$obj;
	112	}
	113
	114	#line 240
	115
	116	sub load_extensions {
	117	my ($self, $path, $top_obj) = @_;
	118
	119	unshift @INC, $self->{prefix}
	120	unless grep { $_ eq $self->{prefix} } @INC;
	121
	122	local @INC = ($path, @INC);
	123	foreach my $rv ($self->find_extensions($path)) {
	124	my ($file, $pkg) = @{$rv};
	125	next if $self->{pathnames}{$pkg};
	126
	127	eval { require $file; 1 } or (warn($@), next);
	128	$self->{pathnames}{$pkg} = $INC{$file};
	129	push @{$self->{extensions}}, $pkg->new( _top => $top_obj );
	130	}
	131	}
	132
	133	#line 264
	134
	135	sub find_extensions {
	136	my ($self, $path) = @_;
	137	my @found;
	138
	139	find(sub {
	140	my $file = $File::Find::name;
	141	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
	142	return if $1 eq $self->{dispatch};
	143
	144	$file = "$self->{path}/$1.pm";
	145	my $pkg = "$self->{name}::$1"; $pkg =~ s!/!::!g;
	146	push @found, [$file, $pkg];
	147	}, $path) if -d $path;
	148
	149	@found;
	150	}
	151
	152	1;
	153
	154	__END__
	155
	156	#line 556

+867

-0

inc/Test/Builder.pm less more

	0	#line 1 "inc/Test/Builder.pm - /opt/perl-5.8.0/lib/perl/Test/Builder.pm"
	1	package Test::Builder;
	2
	3	use 5.004;
	4
	5	# $^C was only introduced in 5.005-ish. We do this to prevent
	6	# use of uninitialized value warnings in older perls.
	7	$^C \|\|= 0;
	8
	9	use strict;
	10	use vars qw($VERSION $CLASS);
	11	$VERSION = '0.17';
	12	$CLASS = __PACKAGE__;
	13
	14	my $IsVMS = $^O eq 'VMS';
	15
	16	# Make Test::Builder thread-safe for ithreads.
	17	BEGIN {
	18	use Config;
	19	if( $] >= 5.008 && $Config{useithreads} ) {
	20	require threads;
	21	require threads::shared;
	22	threads::shared->import;
	23	}
	24	else {
	25	*share = sub { 0 };
	26	*lock = sub { 0 };
	27	}
	28	}
	29
	30	use vars qw($Level);
	31	my($Test_Died) = 0;
	32	my($Have_Plan) = 0;
	33	my $Original_Pid = $$;
	34	my $Curr_Test = 0; share($Curr_Test);
	35	my @Test_Results = (); share(@Test_Results);
	36	my @Test_Details = (); share(@Test_Details);
	37
	38
	39	#line 94
	40
	41	my $Test;
	42	sub new {
	43	my($class) = shift;
	44	$Test \|\|= bless ['Move along, nothing to see here'], $class;
	45	return $Test;
	46	}
	47
	48	#line 120
	49
	50	my $Exported_To;
	51	sub exported_to {
	52	my($self, $pack) = @_;
	53
	54	if( defined $pack ) {
	55	$Exported_To = $pack;
	56	}
	57	return $Exported_To;
	58	}
	59
	60	#line 143
	61
	62	sub plan {
	63	my($self, $cmd, $arg) = @_;
	64
	65	return unless $cmd;
	66
	67	if( $Have_Plan ) {
	68	die sprintf "You tried to plan twice! Second plan at %s line %d\n",
	69	($self->caller)[1,2];
	70	}
	71
	72	if( $cmd eq 'no_plan' ) {
	73	$self->no_plan;
	74	}
	75	elsif( $cmd eq 'skip_all' ) {
	76	return $self->skip_all($arg);
	77	}
	78	elsif( $cmd eq 'tests' ) {
	79	if( $arg ) {
	80	return $self->expected_tests($arg);
	81	}
	82	elsif( !defined $arg ) {
	83	die "Got an undefined number of tests. Looks like you tried to ".
	84	"say how many tests you plan to run but made a mistake.\n";
	85	}
	86	elsif( !$arg ) {
	87	die "You said to run 0 tests! You've got to run something.\n";
	88	}
	89	}
	90	else {
	91	require Carp;
	92	my @args = grep { defined } ($cmd, $arg);
	93	Carp::croak("plan() doesn't understand @args");
	94	}
	95
	96	return 1;
	97	}
	98
	99	#line 190
	100
	101	my $Expected_Tests = 0;
	102	sub expected_tests {
	103	my($self, $max) = @_;
	104
	105	if( defined $max ) {
	106	$Expected_Tests = $max;
	107	$Have_Plan = 1;
	108
	109	$self->_print("1..$max\n") unless $self->no_header;
	110	}
	111	return $Expected_Tests;
	112	}
	113
	114
	115	#line 212
	116
	117	my($No_Plan) = 0;
	118	sub no_plan {
	119	$No_Plan = 1;
	120	$Have_Plan = 1;
	121	}
	122
	123	#line 226
	124
	125	sub has_plan {
	126	return($Expected_Tests) if $Expected_Tests;
	127	return('no_plan') if $No_Plan;
	128	return(undef);
	129	};
	130
	131
	132	#line 242
	133
	134	my $Skip_All = 0;
	135	sub skip_all {
	136	my($self, $reason) = @_;
	137
	138	my $out = "1..0";
	139	$out .= " # Skip $reason" if $reason;
	140	$out .= "\n";
	141
	142	$Skip_All = 1;
	143
	144	$self->_print($out) unless $self->no_header;
	145	exit(0);
	146	}
	147
	148	#line 276
	149
	150	sub ok {
	151	my($self, $test, $name) = @_;
	152
	153	# $test might contain an object which we don't want to accidentally
	154	# store, so we turn it into a boolean.
	155	$test = $test ? 1 : 0;
	156
	157	unless( $Have_Plan ) {
	158	require Carp;
	159	Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
	160	}
	161
	162	lock $Curr_Test;
	163	$Curr_Test++;
	164
	165	$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
	166	You named your test '$name'. You shouldn't use numbers for your test names.
	167	Very confusing.
	168	ERR
	169
	170	my($pack, $file, $line) = $self->caller;
	171
	172	my $todo = $self->todo($pack);
	173
	174	my $out;
	175	my $result = {};
	176	share($result);
	177
	178	unless( $test ) {
	179	$out .= "not ";
	180	@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
	181	}
	182	else {
	183	@$result{ 'ok', 'actual_ok' } = ( 1, $test );
	184	}
	185
	186	$out .= "ok";
	187	$out .= " $Curr_Test" if $self->use_numbers;
	188
	189	if( defined $name ) {
	190	$name =~ s\|#\|\\#\|g; # # in a name can confuse Test::Harness.
	191	$out .= " - $name";
	192	$result->{name} = $name;
	193	}
	194	else {
	195	$result->{name} = '';
	196	}
	197
	198	if( $todo ) {
	199	my $what_todo = $todo;
	200	$out .= " # TODO $what_todo";
	201	$result->{reason} = $what_todo;
	202	$result->{type} = 'todo';
	203	}
	204	else {
	205	$result->{reason} = '';
	206	$result->{type} = '';
	207	}
	208
	209	$Test_Results[$Curr_Test-1] = $result;
	210	$out .= "\n";
	211
	212	$self->_print($out);
	213
	214	unless( $test ) {
	215	my $msg = $todo ? "Failed (TODO)" : "Failed";
	216	$self->diag(" $msg test ($file at line $line)\n");
	217	}
	218
	219	return $test ? 1 : 0;
	220	}
	221
	222	#line 364
	223
	224	sub is_eq {
	225	my($self, $got, $expect, $name) = @_;
	226	local $Level = $Level + 1;
	227
	228	if( !defined $got \|\| !defined $expect ) {
	229	# undef only matches undef and nothing else
	230	my $test = !defined $got && !defined $expect;
	231
	232	$self->ok($test, $name);
	233	$self->_is_diag($got, 'eq', $expect) unless $test;
	234	return $test;
	235	}
	236
	237	return $self->cmp_ok($got, 'eq', $expect, $name);
	238	}
	239
	240	sub is_num {
	241	my($self, $got, $expect, $name) = @_;
	242	local $Level = $Level + 1;
	243
	244	if( !defined $got \|\| !defined $expect ) {
	245	# undef only matches undef and nothing else
	246	my $test = !defined $got && !defined $expect;
	247
	248	$self->ok($test, $name);
	249	$self->_is_diag($got, '==', $expect) unless $test;
	250	return $test;
	251	}
	252
	253	return $self->cmp_ok($got, '==', $expect, $name);
	254	}
	255
	256	sub _is_diag {
	257	my($self, $got, $type, $expect) = @_;
	258
	259	foreach my $val (\$got, \$expect) {
	260	if( defined $$val ) {
	261	if( $type eq 'eq' ) {
	262	# quote and force string context
	263	$$val = "'$$val'"
	264	}
	265	else {
	266	# force numeric context
	267	$$val = $$val+0;
	268	}
	269	}
	270	else {
	271	$$val = 'undef';
	272	}
	273	}
	274
	275	return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
	276	got: %s
	277	expected: %s
	278	DIAGNOSTIC
	279
	280	}
	281
	282	#line 438
	283
	284	sub isnt_eq {
	285	my($self, $got, $dont_expect, $name) = @_;
	286	local $Level = $Level + 1;
	287
	288	if( !defined $got \|\| !defined $dont_expect ) {
	289	# undef only matches undef and nothing else
	290	my $test = defined $got \|\| defined $dont_expect;
	291
	292	$self->ok($test, $name);
	293	$self->_cmp_diag('ne', $got, $dont_expect) unless $test;
	294	return $test;
	295	}
	296
	297	return $self->cmp_ok($got, 'ne', $dont_expect, $name);
	298	}
	299
	300	sub isnt_num {
	301	my($self, $got, $dont_expect, $name) = @_;
	302	local $Level = $Level + 1;
	303
	304	if( !defined $got \|\| !defined $dont_expect ) {
	305	# undef only matches undef and nothing else
	306	my $test = defined $got \|\| defined $dont_expect;
	307
	308	$self->ok($test, $name);
	309	$self->_cmp_diag('!=', $got, $dont_expect) unless $test;
	310	return $test;
	311	}
	312
	313	return $self->cmp_ok($got, '!=', $dont_expect, $name);
	314	}
	315
	316
	317	#line 490
	318
	319	sub like {
	320	my($self, $this, $regex, $name) = @_;
	321
	322	local $Level = $Level + 1;
	323	$self->_regex_ok($this, $regex, '=~', $name);
	324	}
	325
	326	sub unlike {
	327	my($self, $this, $regex, $name) = @_;
	328
	329	local $Level = $Level + 1;
	330	$self->_regex_ok($this, $regex, '!~', $name);
	331	}
	332
	333	#line 531
	334
	335
	336	sub maybe_regex {
	337	my ($self, $regex) = @_;
	338	my $usable_regex = undef;
	339	if( ref $regex eq 'Regexp' ) {
	340	$usable_regex = $regex;
	341	}
	342	# Check if it looks like '/foo/'
	343	elsif( my($re, $opts) = $regex =~ m{^ /(.)/ (\w) $ }sx ) {
	344	$usable_regex = length $opts ? "(?$opts)$re" : $re;
	345	};
	346	return($usable_regex)
	347	};
	348
	349	sub _regex_ok {
	350	my($self, $this, $regex, $cmp, $name) = @_;
	351
	352	local $Level = $Level + 1;
	353
	354	my $ok = 0;
	355	my $usable_regex = $self->maybe_regex($regex);
	356	unless (defined $usable_regex) {
	357	$ok = $self->ok( 0, $name );
	358	$self->diag(" '$regex' doesn't look much like a regex to me.");
	359	return $ok;
	360	}
	361
	362	{
	363	local $^W = 0;
	364	my $test = $this =~ /$usable_regex/ ? 1 : 0;
	365	$test = !$test if $cmp eq '!~';
	366	$ok = $self->ok( $test, $name );
	367	}
	368
	369	unless( $ok ) {
	370	$this = defined $this ? "'$this'" : 'undef';
	371	my $match = $cmp eq '=~' ? "doesn't match" : "matches";
	372	$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
	373	%s
	374	%13s '%s'
	375	DIAGNOSTIC
	376
	377	}
	378
	379	return $ok;
	380	}
	381
	382	#line 588
	383
	384	sub cmp_ok {
	385	my($self, $got, $type, $expect, $name) = @_;
	386
	387	my $test;
	388	{
	389	local $^W = 0;
	390	local($@,$!); # don't interfere with $@
	391	# eval() sometimes resets $!
	392	$test = eval "\$got $type \$expect";
	393	}
	394	local $Level = $Level + 1;
	395	my $ok = $self->ok($test, $name);
	396
	397	unless( $ok ) {
	398	if( $type =~ /^(eq\|==)$/ ) {
	399	$self->_is_diag($got, $type, $expect);
	400	}
	401	else {
	402	$self->_cmp_diag($got, $type, $expect);
	403	}
	404	}
	405	return $ok;
	406	}
	407
	408	sub _cmp_diag {
	409	my($self, $got, $type, $expect) = @_;
	410
	411	$got = defined $got ? "'$got'" : 'undef';
	412	$expect = defined $expect ? "'$expect'" : 'undef';
	413	return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
	414	%s
	415	%s
	416	%s
	417	DIAGNOSTIC
	418	}
	419
	420	#line 636
	421
	422	sub BAILOUT {
	423	my($self, $reason) = @_;
	424
	425	$self->_print("Bail out! $reason");
	426	exit 255;
	427	}
	428
	429	#line 652
	430
	431	sub skip {
	432	my($self, $why) = @_;
	433	$why \|\|= '';
	434
	435	unless( $Have_Plan ) {
	436	require Carp;
	437	Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
	438	}
	439
	440	lock($Curr_Test);
	441	$Curr_Test++;
	442
	443	my %result;
	444	share(%result);
	445	%result = (
	446	'ok' => 1,
	447	actual_ok => 1,
	448	name => '',
	449	type => 'skip',
	450	reason => $why,
	451	);
	452	$Test_Results[$Curr_Test-1] = \%result;
	453
	454	my $out = "ok";
	455	$out .= " $Curr_Test" if $self->use_numbers;
	456	$out .= " # skip $why\n";
	457
	458	$Test->_print($out);
	459
	460	return 1;
	461	}
	462
	463
	464	#line 697
	465
	466	sub todo_skip {
	467	my($self, $why) = @_;
	468	$why \|\|= '';
	469
	470	unless( $Have_Plan ) {
	471	require Carp;
	472	Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
	473	}
	474
	475	lock($Curr_Test);
	476	$Curr_Test++;
	477
	478	my %result;
	479	share(%result);
	480	%result = (
	481	'ok' => 1,
	482	actual_ok => 0,
	483	name => '',
	484	type => 'todo_skip',
	485	reason => $why,
	486	);
	487
	488	$Test_Results[$Curr_Test-1] = \%result;
	489
	490	my $out = "not ok";
	491	$out .= " $Curr_Test" if $self->use_numbers;
	492	$out .= " # TODO & SKIP $why\n";
	493
	494	$Test->_print($out);
	495
	496	return 1;
	497	}
	498
	499
	500	#line 772
	501
	502	sub level {
	503	my($self, $level) = @_;
	504
	505	if( defined $level ) {
	506	$Level = $level;
	507	}
	508	return $Level;
	509	}
	510
	511	$CLASS->level(1);
	512
	513
	514	#line 809
	515
	516	my $Use_Nums = 1;
	517	sub use_numbers {
	518	my($self, $use_nums) = @_;
	519
	520	if( defined $use_nums ) {
	521	$Use_Nums = $use_nums;
	522	}
	523	return $Use_Nums;
	524	}
	525
	526	#line 836
	527
	528	my($No_Header, $No_Ending) = (0,0);
	529	sub no_header {
	530	my($self, $no_header) = @_;
	531
	532	if( defined $no_header ) {
	533	$No_Header = $no_header;
	534	}
	535	return $No_Header;
	536	}
	537
	538	sub no_ending {
	539	my($self, $no_ending) = @_;
	540
	541	if( defined $no_ending ) {
	542	$No_Ending = $no_ending;
	543	}
	544	return $No_Ending;
	545	}
	546
	547
	548	#line 891
	549
	550	sub diag {
	551	my($self, @msgs) = @_;
	552	return unless @msgs;
	553
	554	# Prevent printing headers when compiling (i.e. -c)
	555	return if $^C;
	556
	557	# Escape each line with a #.
	558	foreach (@msgs) {
	559	$_ = 'undef' unless defined;
	560	s/^/# /gms;
	561	}
	562
	563	push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
	564
	565	local $Level = $Level + 1;
	566	my $fh = $self->todo ? $self->todo_output : $self->failure_output;
	567	local($\, $", $,) = (undef, ' ', '');
	568	print $fh @msgs;
	569
	570	return 0;
	571	}
	572
	573	#line 926
	574
	575	sub _print {
	576	my($self, @msgs) = @_;
	577
	578	# Prevent printing headers when only compiling. Mostly for when
	579	# tests are deparsed with B::Deparse
	580	return if $^C;
	581
	582	local($\, $", $,) = (undef, ' ', '');
	583	my $fh = $self->output;
	584
	585	# Escape each line after the first with a # so we don't
	586	# confuse Test::Harness.
	587	foreach (@msgs) {
	588	s/\n(.)/\n# $1/sg;
	589	}
	590
	591	push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
	592
	593	print $fh @msgs;
	594	}
	595
	596
	597	#line 977
	598
	599	my($Out_FH, $Fail_FH, $Todo_FH);
	600	sub output {
	601	my($self, $fh) = @_;
	602
	603	if( defined $fh ) {
	604	$Out_FH = _new_fh($fh);
	605	}
	606	return $Out_FH;
	607	}
	608
	609	sub failure_output {
	610	my($self, $fh) = @_;
	611
	612	if( defined $fh ) {
	613	$Fail_FH = _new_fh($fh);
	614	}
	615	return $Fail_FH;
	616	}
	617
	618	sub todo_output {
	619	my($self, $fh) = @_;
	620
	621	if( defined $fh ) {
	622	$Todo_FH = _new_fh($fh);
	623	}
	624	return $Todo_FH;
	625	}
	626
	627	sub _new_fh {
	628	my($file_or_fh) = shift;
	629
	630	my $fh;
	631	unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
	632	$fh = do { local *FH };
	633	open $fh, ">$file_or_fh" or
	634	die "Can't open test output log $file_or_fh: $!";
	635	}
	636	else {
	637	$fh = $file_or_fh;
	638	}
	639
	640	return $fh;
	641	}
	642
	643	unless( $^C ) {
	644	# We dup STDOUT and STDERR so people can change them in their
	645	# test suites while still getting normal test output.
	646	open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
	647	open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
	648
	649	# Set everything to unbuffered else plain prints to STDOUT will
	650	# come out in the wrong order from our own prints.
	651	_autoflush(\*TESTOUT);
	652	_autoflush(\*STDOUT);
	653	_autoflush(\*TESTERR);
	654	_autoflush(\*STDERR);
	655
	656	$CLASS->output(\*TESTOUT);
	657	$CLASS->failure_output(\*TESTERR);
	658	$CLASS->todo_output(\*TESTOUT);
	659	}
	660
	661	sub _autoflush {
	662	my($fh) = shift;
	663	my $old_fh = select $fh;
	664	$\| = 1;
	665	select $old_fh;
	666	}
	667
	668
	669	#line 1065
	670
	671	sub current_test {
	672	my($self, $num) = @_;
	673
	674	lock($Curr_Test);
	675	if( defined $num ) {
	676	unless( $Have_Plan ) {
	677	require Carp;
	678	Carp::croak("Can't change the current test number without a plan!");
	679	}
	680
	681	$Curr_Test = $num;
	682	if( $num > @Test_Results ) {
	683	my $start = @Test_Results ? $#Test_Results + 1 : 0;
	684	for ($start..$num-1) {
	685	my %result;
	686	share(%result);
	687	%result = ( ok => 1,
	688	actual_ok => undef,
	689	reason => 'incrementing test number',
	690	type => 'unknown',
	691	name => undef
	692	);
	693	$Test_Results[$_] = \%result;
	694	}
	695	}
	696	}
	697	return $Curr_Test;
	698	}
	699
	700
	701	#line 1106
	702
	703	sub summary {
	704	my($self) = shift;
	705
	706	return map { $_->{'ok'} } @Test_Results;
	707	}
	708
	709	#line 1161
	710
	711	sub details {
	712	return @Test_Results;
	713	}
	714
	715	#line 1185
	716
	717	sub todo {
	718	my($self, $pack) = @_;
	719
	720	$pack = $pack \|\| $self->exported_to \|\| $self->caller(1);
	721
	722	no strict 'refs';
	723	return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
	724	: 0;
	725	}
	726
	727	#line 1205
	728
	729	sub caller {
	730	my($self, $height) = @_;
	731	$height \|\|= 0;
	732
	733	my @caller = CORE::caller($self->level + $height + 1);
	734	return wantarray ? @caller : $caller[0];
	735	}
	736
	737	#line 1217
	738
	739	#line 1231
	740
	741	#'#
	742	sub _sanity_check {
	743	_whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
	744	_whoa(!$Have_Plan and $Curr_Test,
	745	'Somehow your tests ran without a plan!');
	746	_whoa($Curr_Test != @Test_Results,
	747	'Somehow you got a different number of results than tests ran!');
	748	}
	749
	750	#line 1250
	751
	752	sub _whoa {
	753	my($check, $desc) = @_;
	754	if( $check ) {
	755	die <<WHOA;
	756	WHOA! $desc
	757	This should never happen! Please contact the author immediately!
	758	WHOA
	759	}
	760	}
	761
	762	#line 1271
	763
	764	sub _my_exit {
	765	$? = $_[0];
	766
	767	return 1;
	768	}
	769
	770
	771	#line 1284
	772
	773	$SIG{__DIE__} = sub {
	774	# We don't want to muck with death in an eval, but $^S isn't
	775	# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
	776	# with it. Instead, we use caller. This also means it runs under
	777	# 5.004!
	778	my $in_eval = 0;
	779	for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
	780	$in_eval = 1 if $sub =~ /^$eval$/;
	781	}
	782	$Test_Died = 1 unless $in_eval;
	783	};
	784
	785	sub _ending {
	786	my $self = shift;
	787
	788	_sanity_check();
	789
	790	# Don't bother with an ending if this is a forked copy. Only the parent
	791	# should do the ending.
	792	do{ _my_exit($?) && return } if $Original_Pid != $$;
	793
	794	# Bailout if plan() was never called. This is so
	795	# "require Test::Simple" doesn't puke.
	796	do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
	797
	798	# Figure out if we passed or failed and print helpful messages.
	799	if( @Test_Results ) {
	800	# The plan? We have no plan.
	801	if( $No_Plan ) {
	802	$self->_print("1..$Curr_Test\n") unless $self->no_header;
	803	$Expected_Tests = $Curr_Test;
	804	}
	805
	806	# 5.8.0 threads bug. Shared arrays will not be auto-extended
	807	# by a slice. Worse, we have to fill in every entry else
	808	# we'll get an "Invalid value for shared scalar" error
	809	for my $idx ($#Test_Results..$Expected_Tests-1) {
	810	my %empty_result = ();
	811	share(%empty_result);
	812	$Test_Results[$idx] = \%empty_result
	813	unless defined $Test_Results[$idx];
	814	}
	815
	816	my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
	817	$num_failed += abs($Expected_Tests - @Test_Results);
	818
	819	if( $Curr_Test < $Expected_Tests ) {
	820	$self->diag(<<"FAIL");
	821	Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
	822	FAIL
	823	}
	824	elsif( $Curr_Test > $Expected_Tests ) {
	825	my $num_extra = $Curr_Test - $Expected_Tests;
	826	$self->diag(<<"FAIL");
	827	Looks like you planned $Expected_Tests tests but ran $num_extra extra.
	828	FAIL
	829	}
	830	elsif ( $num_failed ) {
	831	$self->diag(<<"FAIL");
	832	Looks like you failed $num_failed tests of $Expected_Tests.
	833	FAIL
	834	}
	835
	836	if( $Test_Died ) {
	837	$self->diag(<<"FAIL");
	838	Looks like your test died just after $Curr_Test.
	839	FAIL
	840
	841	_my_exit( 255 ) && return;
	842	}
	843
	844	_my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
	845	}
	846	elsif ( $Skip_All ) {
	847	_my_exit( 0 ) && return;
	848	}
	849	elsif ( $Test_Died ) {
	850	$self->diag(<<'FAIL');
	851	Looks like your test died before it could output anything.
	852	FAIL
	853	}
	854	else {
	855	$self->diag("No tests run!\n");
	856	_my_exit( 255 ) && return;
	857	}
	858	}
	859
	860	END {
	861	$Test->_ending if defined $Test and !$Test->no_ending;
	862	}
	863
	864	#line 1407
	865
	866	1;

-0

inc/Test/Inline.pm less more

	0	#line 1 "inc/Test/Inline.pm - /opt/perl-5.8.0/lib/site_perl/Test/Inline.pm"
	1	package Test::Inline;
	2
	3	$VERSION = '0.15';
	4
	5
	6	#line 175
	7
	8	1;

+500

-0

inc/Test/More.pm less more

	0	#line 1 "inc/Test/More.pm - /opt/perl-5.8.0/lib/perl/Test/More.pm"
	1	package Test::More;
	2
	3	use 5.004;
	4
	5	use strict;
	6	use Test::Builder;
	7
	8
	9	# Can't use Carp because it might cause use_ok() to accidentally succeed
	10	# even though the module being used forgot to use Carp. Yes, this
	11	# actually happened.
	12	sub _carp {
	13	my($file, $line) = (caller(1))[1,2];
	14	warn @_, " at $file line $line\n";
	15	}
	16
	17
	18
	19	require Exporter;
	20	use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
	21	$VERSION = '0.47';
	22	@ISA = qw(Exporter);
	23	@EXPORT = qw(ok use_ok require_ok
	24	is isnt like unlike is_deeply
	25	cmp_ok
	26	skip todo todo_skip
	27	pass fail
	28	eq_array eq_hash eq_set
	29	$TODO
	30	plan
	31	can_ok isa_ok
	32	diag
	33	);
	34
	35	my $Test = Test::Builder->new;
	36
	37
	38	# 5.004's Exporter doesn't have export_to_level.
	39	sub _export_to_level
	40	{
	41	my $pkg = shift;
	42	my $level = shift;
	43	(undef) = shift; # redundant arg
	44	my $callpkg = caller($level);
	45	$pkg->export($callpkg, @_);
	46	}
	47
	48
	49	#line 172
	50
	51	sub plan {
	52	my(@plan) = @_;
	53
	54	my $caller = caller;
	55
	56	$Test->exported_to($caller);
	57
	58	my @imports = ();
	59	foreach my $idx (0..$#plan) {
	60	if( $plan[$idx] eq 'import' ) {
	61	my($tag, $imports) = splice @plan, $idx, 2;
	62	@imports = @$imports;
	63	last;
	64	}
	65	}
	66
	67	$Test->plan(@plan);
	68
	69	__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
	70	}
	71
	72	sub import {
	73	my($class) = shift;
	74	goto &plan;
	75	}
	76
	77
	78	#line 266
	79
	80	sub ok ($;$) {
	81	my($test, $name) = @_;
	82	$Test->ok($test, $name);
	83	}
	84
	85	#line 330
	86
	87	sub is ($$;$) {
	88	$Test->is_eq(@_);
	89	}
	90
	91	sub isnt ($$;$) {
	92	$Test->isnt_eq(@_);
	93	}
	94
	95	*isn't = \&isnt;
	96
	97
	98	#line 371
	99
	100	sub like ($$;$) {
	101	$Test->like(@_);
	102	}
	103
	104
	105	#line 385
	106
	107	sub unlike {
	108	$Test->unlike(@_);
	109	}
	110
	111
	112	#line 423
	113
	114	sub cmp_ok($$$;$) {
	115	$Test->cmp_ok(@_);
	116	}
	117
	118
	119	#line 457
	120
	121	sub can_ok ($@) {
	122	my($proto, @methods) = @_;
	123	my $class = ref $proto \|\| $proto;
	124
	125	unless( @methods ) {
	126	my $ok = $Test->ok( 0, "$class->can(...)" );
	127	$Test->diag(' can_ok() called with no methods');
	128	return $ok;
	129	}
	130
	131	my @nok = ();
	132	foreach my $method (@methods) {
	133	local($!, $@); # don't interfere with caller's $@
	134	# eval sometimes resets $!
	135	eval { $proto->can($method) } \|\| push @nok, $method;
	136	}
	137
	138	my $name;
	139	$name = @methods == 1 ? "$class->can('$methods[0]')"
	140	: "$class->can(...)";
	141
	142	my $ok = $Test->ok( !@nok, $name );
	143
	144	$Test->diag(map " $class->can('$_') failed\n", @nok);
	145
	146	return $ok;
	147	}
	148
	149	#line 514
	150
	151	sub isa_ok ($$;$) {
	152	my($object, $class, $obj_name) = @_;
	153
	154	my $diag;
	155	$obj_name = 'The object' unless defined $obj_name;
	156	my $name = "$obj_name isa $class";
	157	if( !defined $object ) {
	158	$diag = "$obj_name isn't defined";
	159	}
	160	elsif( !ref $object ) {
	161	$diag = "$obj_name isn't a reference";
	162	}
	163	else {
	164	# We can't use UNIVERSAL::isa because we want to honor isa() overrides
	165	local($@, $!); # eval sometimes resets $!
	166	my $rslt = eval { $object->isa($class) };
	167	if( $@ ) {
	168	if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
	169	if( !UNIVERSAL::isa($object, $class) ) {
	170	my $ref = ref $object;
	171	$diag = "$obj_name isn't a '$class' it's a '$ref'";
	172	}
	173	} else {
	174	die <<WHOA;
	175	WHOA! I tried to call ->isa on your object and got some weird error.
	176	This should never happen. Please contact the author immediately.
	177	Here's the error.
	178	$@
	179	WHOA
	180	}
	181	}
	182	elsif( !$rslt ) {
	183	my $ref = ref $object;
	184	$diag = "$obj_name isn't a '$class' it's a '$ref'";
	185	}
	186	}
	187
	188
	189
	190	my $ok;
	191	if( $diag ) {
	192	$ok = $Test->ok( 0, $name );
	193	$Test->diag(" $diag\n");
	194	}
	195	else {
	196	$ok = $Test->ok( 1, $name );
	197	}
	198
	199	return $ok;
	200	}
	201
	202
	203	#line 583
	204
	205	sub pass (;$) {
	206	$Test->ok(1, @_);
	207	}
	208
	209	sub fail (;$) {
	210	$Test->ok(0, @_);
	211	}
	212
	213	#line 627
	214
	215	sub diag {
	216	$Test->diag(@_);
	217	}
	218
	219
	220	#line 677
	221
	222	sub use_ok ($;@) {
	223	my($module, @imports) = @_;
	224	@imports = () unless @imports;
	225
	226	my $pack = caller;
	227
	228	local($@,$!); # eval sometimes interferes with $!
	229	eval <<USE;
	230	package $pack;
	231	require $module;
	232	'$module'->import(\@imports);
	233	USE
	234
	235	my $ok = $Test->ok( !$@, "use $module;" );
	236
	237	unless( $ok ) {
	238	chomp $@;
	239	$Test->diag(<<DIAGNOSTIC);
	240	Tried to use '$module'.
	241	Error: $@
	242	DIAGNOSTIC
	243
	244	}
	245
	246	return $ok;
	247	}
	248
	249	#line 712
	250
	251	sub require_ok ($) {
	252	my($module) = shift;
	253
	254	my $pack = caller;
	255
	256	local($!, $@); # eval sometimes interferes with $!
	257	eval <<REQUIRE;
	258	package $pack;
	259	require $module;
	260	REQUIRE
	261
	262	my $ok = $Test->ok( !$@, "require $module;" );
	263
	264	unless( $ok ) {
	265	chomp $@;
	266	$Test->diag(<<DIAGNOSTIC);
	267	Tried to require '$module'.
	268	Error: $@
	269	DIAGNOSTIC
	270
	271	}
	272
	273	return $ok;
	274	}
	275
	276	#line 796
	277
	278	#'#
	279	sub skip {
	280	my($why, $how_many) = @_;
	281
	282	unless( defined $how_many ) {
	283	# $how_many can only be avoided when no_plan is in use.
	284	_carp "skip() needs to know \$how_many tests are in the block"
	285	unless $Test::Builder::No_Plan;
	286	$how_many = 1;
	287	}
	288
	289	for( 1..$how_many ) {
	290	$Test->skip($why);
	291	}
	292
	293	local $^W = 0;
	294	last SKIP;
	295	}
	296
	297
	298	#line 874
	299
	300	sub todo_skip {
	301	my($why, $how_many) = @_;
	302
	303	unless( defined $how_many ) {
	304	# $how_many can only be avoided when no_plan is in use.
	305	_carp "todo_skip() needs to know \$how_many tests are in the block"
	306	unless $Test::Builder::No_Plan;
	307	$how_many = 1;
	308	}
	309
	310	for( 1..$how_many ) {
	311	$Test->todo_skip($why);
	312	}
	313
	314	local $^W = 0;
	315	last TODO;
	316	}
	317
	318	#line 933
	319
	320	use vars qw(@Data_Stack);
	321	my $DNE = bless [], 'Does::Not::Exist';
	322	sub is_deeply {
	323	my($this, $that, $name) = @_;
	324
	325	my $ok;
	326	if( !ref $this \|\| !ref $that ) {
	327	$ok = $Test->is_eq($this, $that, $name);
	328	}
	329	else {
	330	local @Data_Stack = ();
	331	if( _deep_check($this, $that) ) {
	332	$ok = $Test->ok(1, $name);
	333	}
	334	else {
	335	$ok = $Test->ok(0, $name);
	336	$ok = $Test->diag(_format_stack(@Data_Stack));
	337	}
	338	}
	339
	340	return $ok;
	341	}
	342
	343	sub _format_stack {
	344	my(@Stack) = @_;
	345
	346	my $var = '$FOO';
	347	my $did_arrow = 0;
	348	foreach my $entry (@Stack) {
	349	my $type = $entry->{type} \|\| '';
	350	my $idx = $entry->{'idx'};
	351	if( $type eq 'HASH' ) {
	352	$var .= "->" unless $did_arrow++;
	353	$var .= "{$idx}";
	354	}
	355	elsif( $type eq 'ARRAY' ) {
	356	$var .= "->" unless $did_arrow++;
	357	$var .= "[$idx]";
	358	}
	359	elsif( $type eq 'REF' ) {
	360	$var = "\${$var}";
	361	}
	362	}
	363
	364	my @vals = @{$Stack[-1]{vals}}[0,1];
	365	my @vars = ();
	366	($vars[0] = $var) =~ s/\$FOO/ \$got/;
	367	($vars[1] = $var) =~ s/\$FOO/\$expected/;
	368
	369	my $out = "Structures begin differing at:\n";
	370	foreach my $idx (0..$#vals) {
	371	my $val = $vals[$idx];
	372	$vals[$idx] = !defined $val ? 'undef' :
	373	$val eq $DNE ? "Does not exist"
	374	: "'$val'";
	375	}
	376
	377	$out .= "$vars[0] = $vals[0]\n";
	378	$out .= "$vars[1] = $vals[1]\n";
	379
	380	$out =~ s/^/ /msg;
	381	return $out;
	382	}
	383
	384
	385	#line 1007
	386
	387	#'#
	388	sub eq_array {
	389	my($a1, $a2) = @_;
	390	return 1 if $a1 eq $a2;
	391
	392	my $ok = 1;
	393	my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
	394	for (0..$max) {
	395	my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
	396	my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
	397
	398	push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
	399	$ok = _deep_check($e1,$e2);
	400	pop @Data_Stack if $ok;
	401
	402	last unless $ok;
	403	}
	404	return $ok;
	405	}
	406
	407	sub _deep_check {
	408	my($e1, $e2) = @_;
	409	my $ok = 0;
	410
	411	my $eq;
	412	{
	413	# Quiet uninitialized value warnings when comparing undefs.
	414	local $^W = 0;
	415
	416	if( $e1 eq $e2 ) {
	417	$ok = 1;
	418	}
	419	else {
	420	if( UNIVERSAL::isa($e1, 'ARRAY') and
	421	UNIVERSAL::isa($e2, 'ARRAY') )
	422	{
	423	$ok = eq_array($e1, $e2);
	424	}
	425	elsif( UNIVERSAL::isa($e1, 'HASH') and
	426	UNIVERSAL::isa($e2, 'HASH') )
	427	{
	428	$ok = eq_hash($e1, $e2);
	429	}
	430	elsif( UNIVERSAL::isa($e1, 'REF') and
	431	UNIVERSAL::isa($e2, 'REF') )
	432	{
	433	push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
	434	$ok = _deep_check($$e1, $$e2);
	435	pop @Data_Stack if $ok;
	436	}
	437	elsif( UNIVERSAL::isa($e1, 'SCALAR') and
	438	UNIVERSAL::isa($e2, 'SCALAR') )
	439	{
	440	push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
	441	$ok = _deep_check($$e1, $$e2);
	442	}
	443	else {
	444	push @Data_Stack, { vals => [$e1, $e2] };
	445	$ok = 0;
	446	}
	447	}
	448	}
	449
	450	return $ok;
	451	}
	452
	453
	454	#line 1083
	455
	456	sub eq_hash {
	457	my($a1, $a2) = @_;
	458	return 1 if $a1 eq $a2;
	459
	460	my $ok = 1;
	461	my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
	462	foreach my $k (keys %$bigger) {
	463	my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
	464	my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
	465
	466	push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
	467	$ok = _deep_check($e1, $e2);
	468	pop @Data_Stack if $ok;
	469
	470	last unless $ok;
	471	}
	472
	473	return $ok;
	474	}
	475
	476	#line 1116
	477
	478	# We must make sure that references are treated neutrally. It really
	479	# doesn't matter how we sort them, as long as both arrays are sorted
	480	# with the same algorithm.
	481	sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
	482
	483	sub eq_set {
	484	my($a1, $a2) = @_;
	485	return 0 unless @$a1 == @$a2;
	486
	487	# There's faster ways to do this, but this is easiest.
	488	return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
	489	}
	490
	491	#line 1154
	492
	493	sub builder {
	494	return Test::Builder->new;
	495	}
	496
	497	#line 1247
	498
	499	1;

+429

-0

lib/Class/ReturnValue.pm less more

	0	use warnings;
	1	use strict;
	2
	3	package Class::ReturnValue;
	4
	5	# {{{ POD Overview
	6
	7	=head1 NAME
	8
	9	Class::ReturnValue - A return-value object that lets you treat it
	10	as as a boolean, array or object
	11
	12	=head1 DESCRIPTION
	13
	14	Class::ReturnValue is a "clever" return value object that can allow
	15	code calling your routine to expect:
	16	a boolean value (did it fail)
	17	or a list (what are the return values)
	18
	19	=head1 EXAMPLE
	20
	21	sub demo {
	22	my $value = shift;
	23	my $ret = Class::ReturnValue->new();
	24	$ret->as_array('0', 'No results found');
	25
	26	unless($value) {
	27	$ret->as_error(errno => '1',
	28	message => "You didn't supply a parameter.",
	29	do_backtrace => 1);
	30	}
	31
	32	return($ret->return_value);
	33	}
	34
	35	if (demo('foo')){
	36	print "the routine succeeded with one parameter";
	37	}
	38	if (demo()) {
	39	print "The routine succeeded with 0 paramters. shouldn't happen";
	40	} else {
	41	print "The routine failed with 0 parameters (as it should).";
	42	}
	43
	44
	45	my $return = demo();
	46	if ($return) {
	47	print "The routine succeeded with 0 paramters. shouldn't happen";
	48	} else {
	49	print "The routine failed with 0 parameters (as it should). ".
	50	"Stack trace:\n".
	51	$return->backtrace;
	52	}
	53
	54	my @return3 = demo('foo');
	55	print "The routine got ".join(',',@return3).
	56	"when asking for demo's results as an array";
	57
	58
	59	my $return2 = demo('foo');
	60
	61	unless ($return2) {
	62	print "The routine failed with a parameter. shouldn't happen.".
	63	"Stack trace:\n".
	64	$return2->backtrace;
	65	}
	66
	67	my @return2_array = @{$return2}; # TODO: does this work
	68	my @return2_array2 = $return2->as_array;
	69
	70
	71
	72	=for testing
	73	use Class::ReturnValue;
	74	use Test::More;
	75
	76	=cut
	77
	78	# }}}
	79
	80	use Exporter;
	81
	82	use vars qw/$VERSION @EXPORT @ISA/;
	83
	84	@ISA = qw/Exporter/;
	85	@EXPORT = qw /&return_value/;
	86	use Carp;
	87	use Devel::StackTrace;
	88	use Data::Dumper;
	89
	90
	91	$VERSION = '0.53';
	92
	93
	94	use overload 'bool' => \&error_condition;
	95	use overload '""' => \&error_condition;
	96	use overload 'eq' => \&my_eq;
	97	use overload '@{}' => \&as_array;
	98	use overload 'fallback' => \&as_array;
	99
	100
	101	=head1 METHODS
	102
	103	=item new
	104
	105	Instantiate a new Class::ReturnValue object
	106
	107	=cut
	108
	109	sub new {
	110	my $self = {};
	111	bless($self);
	112	return($self);
	113	}
	114
	115	sub my_eq {
	116	my $self = shift;
	117	if (wantarray()) {
	118	return($self->as_array);
	119	}
	120	else {
	121	return($self);
	122	}
	123	}
	124
	125	=item as_array
	126
	127	Return the 'as_array' attribute of this object as an array.
	128
	129	=begin testing
	130
	131	sub foo {
	132	my $r = Class::ReturnValue->new();
	133	$r->as_array('one', 'two', 'three');
	134	return $r->return_value();
	135
	136
	137
	138	}
	139
	140	my @array;
	141	ok(@array = foo());
	142	is($array[0] , 'one','dereferencing to an array is ok');
	143	is($array[1] , 'two','dereferencing to an array is ok');
	144	is($array[2] , 'three','dereferencing to an array is ok');
	145	is($array[3] , undef ,'dereferencing to an array is ok');
	146
	147	ok(my $ref = foo());
	148	ok(my @array2 = $ref->as_array());
	149	is($array2[0] , 'one','dereferencing to an arrayref is ok');
	150
	151	is($array2[1] , 'two','dereferencing to an arrayref is ok');
	152	is($array2[2] , 'three','dereferencing to an arrayref is ok');
	153	is($array2[3] , undef ,'dereferencing to an arrayref is ok');
	154	ok(foo(),"Foo returns true in a boolean context");
	155
	156	my ($a, $b, $c) = foo();
	157	is ($a , 'one', "first element is 1");
	158	is ($b, 'two' , "Second element is two");
	159	is ($c , 'three', "Third element is three");
	160
	161	my ($a2, $b2, $c2) = foo();
	162	is ($a2 , 'one', "first element is 1");
	163	is ($b2, 'two' , "Second element is two");
	164	is ($c2 , 'three', "Third element is three");
	165
	166	=end testing
	167
	168	=cut
	169
	170
	171	=item as_array [ARRAY]
	172
	173	If $self is called in an array context, returns the array specified in ARRAY
	174
	175	=begin testing
	176
	177	sub bing {
	178	my $ret = Class::ReturnValue->new();
	179	return $ret->return_value;
	180	return("Dead");
	181	}
	182
	183	ok(bing());
	184	ok(bing() ne 'Dead');
	185
	186	=end testing
	187
	188	=cut
	189
	190	sub as_array {
	191
	192	my $self = shift;
	193	if (@_) {
	194	@{$self->{'as_array'}} = (@_);
	195	}
	196	return(@{$self->{'as_array'}});
	197	}
	198
	199
	200	=item as_error HASH
	201
	202	Turns this return-value object into an error return object. TAkes three parameters:
	203
	204	message
	205	do_backtrace
	206	errno
	207
	208	'message' is a human readable error message explaining what's going on
	209
	210	'do_backtrace' is a boolean. If it's true, a carp-style backtrace will be
	211	stored in $self->{'backtrace'}. It defaults to true
	212
	213	errno and message default to undef. errno _must_ be specified.
	214	It's a numeric error number. Any true integer value will cause the
	215	object to evaluate to false in a scalar context. At first, this may look a
	216	bit counterintuitive, but it means that you can have error codes and still
	217	allow simple use of your functions in a style like this:
	218
	219
	220	if ($obj->do_something) {
	221	print "Yay! it worked";
	222	} else {
	223	print "Sorry. there's been an error.";
	224	}
	225
	226
	227	as well as more complex use like this:
	228
	229	my $retval = $obj->do_something;
	230
	231	if ($retval) {
	232	print "Yay. we did something\n";
	233	my ($foo, $bar, $baz) = @{$retval};
	234	my $human_readable_return = $retval;
	235	} else {
	236	if ($retval->errno == 20) {
	237	die "Failed with error 20 (Not enough monkeys).";
	238	} else {
	239	die $retval->backtrace; # Die and print out a backtrace
	240	}
	241	}
	242
	243
	244	=cut
	245
	246	sub as_error {
	247	my $self = shift;
	248	my %args = ( errno => undef,
	249	message => undef,
	250	do_backtrace => 1,
	251	@_);
	252
	253	unless($args{'errno'}) {
	254	carp "$self -> as_error called without an 'errno' parameter";
	255	return (undef);
	256	}
	257
	258	$self->{'errno'} = $args{'errno'};
	259	$self->{'error_message'} = $args{'message'};
	260	if ($args{'do_backtrace'}) {
	261	# Use carp's internal backtrace methods, rather than duplicating them ourselves
	262	my $trace = Devel::StackTrace->new(ignore_package => 'Class::ReturnValue');
	263
	264	$self->{'backtrace'} = $trace->as_string; # like carp
	265	}
	266
	267	return(1);
	268	}
	269
	270
	271	=item errno
	272
	273	Returns the errno if there's been an error. Otherwise, return undef
	274
	275	=cut
	276
	277	sub errno {
	278	my $self = shift;
	279	if ($self->{'errno'}) {
	280	return ($self->{'errno'});
	281	}
	282	else {
	283	return(undef);
	284	}
	285	}
	286
	287
	288	=item error_message
	289
	290	If there's been an error return the error message.
	291
	292	=cut
	293
	294	sub error_message {
	295	my $self = shift;
	296	if ($self->{'error_message'}) {
	297	return($self->{'error_message'});
	298	}
	299	else {
	300	return(undef);
	301	}
	302	}
	303
	304
	305	=item backtrace
	306
	307	If there's been an error and we asked for a backtrace, return the backtrace.
	308	Otherwise, return undef.
	309
	310	=cut
	311
	312	sub backtrace {
	313	my $self = shift;
	314	if ($self->{'backtrace'}) {
	315	return($self->{'backtrace'});
	316	}
	317	else {
	318	return(undef);
	319	}
	320	}
	321
	322	=begin testing
	323
	324
	325	sub bar {
	326	my $retval3 = Class::ReturnValue->new();
	327	$retval3->as_array(1,'asq');
	328	return_value $retval3;
	329	}
	330	ok(bar());
	331	sub baz {
	332	my $retval = Class::ReturnValue->new();
	333	$retval->as_error(errno=> 1);
	334	return_value $retval;
	335	}
	336
	337	if(baz()){
	338	ok (0,"returning an error evals as true");
	339	} else {
	340	ok (1,"returning an error evals as false");
	341
	342	}
	343
	344	ok(my $retval = Class::ReturnValue->new());
	345	ok($retval->as_error( errno => 20,
	346	message => "You've been eited",
	347	do_backtrace => 1));
	348	ok($retval->backtrace ne undef);
	349	is($retval->error_message,"You've been eited");
	350
	351
	352	ok(my $retval2 = Class::ReturnValue->new());
	353	ok($retval2->as_error( errno => 1,
	354	message => "You've been eited",
	355	do_backtrace => 0 ));
	356	ok($retval2->backtrace eq undef);
	357	is($retval2->errno, 1, "Got the errno");
	358	isnt($retval2->errno,20, "Errno knows that 20 != 1");
	359
	360	=end testing
	361
	362	=cut
	363
	364	=item error_condition
	365
	366	If there's been an error, return undef. Otherwise return 1
	367
	368	=cut
	369
	370	sub error_condition {
	371	my $self = shift;
	372	if ($self->{'errno'}) {
	373	return (undef);
	374	}
	375	elsif (wantarray()) {
	376	return(@{$self->{'as_array'}});
	377	}
	378	else {
	379	return(1);
	380	}
	381	}
	382
	383	sub return_value {
	384	my $self = shift;
	385	if (wantarray) {
	386	return ($self->as_array);
	387	}
	388	else {
	389	return ($self);
	390	}
	391	}
	392
	393
	394	=head1 AUTHOR
	395
	396	Jesse Vincent <jesse@bestpractical.com>
	397
	398	=head1 BUGS
	399
	400	This module has, as yet, not been used in production code. I thing
	401	it should work, but have never benchmarked it. I have not yet used
	402	it extensively, though I do plan to in the not-too-distant future.
	403	If you have questions or comments, please write me.
	404
	405	If you need to report a bug, please send mail to
	406	<bug-class-returnvalue@rt.cpan.org> or report your error on the web
	407	at http://rt.cpan.org/
	408
	409	=head1 COPYRIGHT
	410
	411	Copyright (c) 2002,2003,2005 Jesse Vincent <jesse@bestpractical.com>
	412	You may use, modify, fold, spindle or mutilate this module under
	413	the same terms as perl itself.
	414
	415	=head1 SEE ALSO
	416
	417	Class::ReturnValue isn't an exception handler. If it doesn't
	418	do what you want, you might want look at one of the exception handlers
	419	below
	420
	421	Error, Exception, Exceptions, Exceptions::Class
	422
	423	You might also want to look at Contextual::Return, another implementation
	424	of the same concept as this module.
	425
	426	=cut
	427
	428	1;

+153

-0

t/embedded-Class-ReturnValue.t less more

	0	#!perl -w
	1
	2	use Test::More 'no_plan';
	3
	4	package Catch;
	5
	6	sub TIEHANDLE {
	7	my($class, $var) = @_;
	8	return bless { var => $var }, $class;
	9	}
	10
	11	sub PRINT {
	12	my($self) = shift;
	13	${'main::'.$self->{var}} .= join '', @_;
	14	}
	15
	16	sub OPEN {} # XXX Hackery in case the user redirects
	17	sub CLOSE {} # XXX STDERR/STDOUT. This is not the behavior we want.
	18
	19	sub READ {}
	20	sub READLINE {}
	21	sub GETC {}
	22
	23	my $Original_File = 'lib/Class/ReturnValue.pm';
	24
	25	package main;
	26
	27	# pre-5.8.0's warns aren't caught by a tied STDERR.
	28	$SIG{__WARN__} = sub { $main::_STDERR_ .= join '', @_; };
	29	tie *STDOUT, 'Catch', '_STDOUT_' or die $!;
	30	tie *STDERR, 'Catch', '_STDERR_' or die $!;
	31
	32	{
	33	undef $main::_STDOUT_;
	34	undef $main::_STDERR_;
	35	#line 73 lib/Class/ReturnValue.pm
	36	use Class::ReturnValue;
	37	use Test::More;
	38
	39	undef $main::_STDOUT_;
	40	undef $main::_STDERR_;
	41	}
	42
	43	{
	44	undef $main::_STDOUT_;
	45	undef $main::_STDERR_;
	46	#line 130 lib/Class/ReturnValue.pm
	47
	48	sub foo {
	49	my $r = Class::ReturnValue->new();
	50	$r->as_array('one', 'two', 'three');
	51	return $r->return_value();
	52
	53
	54
	55	}
	56
	57	my @array;
	58	ok(@array = foo());
	59	is($array[0] , 'one','dereferencing to an array is ok');
	60	is($array[1] , 'two','dereferencing to an array is ok');
	61	is($array[2] , 'three','dereferencing to an array is ok');
	62	is($array[3] , undef ,'dereferencing to an array is ok');
	63
	64	ok(my $ref = foo());
	65	ok(my @array2 = $ref->as_array());
	66	is($array2[0] , 'one','dereferencing to an arrayref is ok');
	67
	68	is($array2[1] , 'two','dereferencing to an arrayref is ok');
	69	is($array2[2] , 'three','dereferencing to an arrayref is ok');
	70	is($array2[3] , undef ,'dereferencing to an arrayref is ok');
	71	ok(foo(),"Foo returns true in a boolean context");
	72
	73	my ($a, $b, $c) = foo();
	74	is ($a , 'one', "first element is 1");
	75	is ($b, 'two' , "Second element is two");
	76	is ($c , 'three', "Third element is three");
	77
	78	my ($a2, $b2, $c2) = foo();
	79	is ($a2 , 'one', "first element is 1");
	80	is ($b2, 'two' , "Second element is two");
	81	is ($c2 , 'three', "Third element is three");
	82
	83
	84	undef $main::_STDOUT_;
	85	undef $main::_STDERR_;
	86	}
	87
	88	{
	89	undef $main::_STDOUT_;
	90	undef $main::_STDERR_;
	91	#line 176 lib/Class/ReturnValue.pm
	92
	93	sub bing {
	94	my $ret = Class::ReturnValue->new();
	95	return $ret->return_value;
	96	return("Dead");
	97	}
	98
	99	ok(bing());
	100	ok(bing() ne 'Dead');
	101
	102
	103	undef $main::_STDOUT_;
	104	undef $main::_STDERR_;
	105	}
	106
	107	{
	108	undef $main::_STDOUT_;
	109	undef $main::_STDERR_;
	110	#line 323 lib/Class/ReturnValue.pm
	111
	112
	113	sub bar {
	114	my $retval3 = Class::ReturnValue->new();
	115	$retval3->as_array(1,'asq');
	116	return_value $retval3;
	117	}
	118	ok(bar());
	119	sub baz {
	120	my $retval = Class::ReturnValue->new();
	121	$retval->as_error(errno=> 1);
	122	return_value $retval;
	123	}
	124
	125	if(baz()){
	126	ok (0,"returning an error evals as true");
	127	} else {
	128	ok (1,"returning an error evals as false");
	129
	130	}
	131
	132	ok(my $retval = Class::ReturnValue->new());
	133	ok($retval->as_error( errno => 20,
	134	message => "You've been eited",
	135	do_backtrace => 1));
	136	ok($retval->backtrace ne undef);
	137	is($retval->error_message,"You've been eited");
	138
	139
	140	ok(my $retval2 = Class::ReturnValue->new());
	141	ok($retval2->as_error( errno => 1,
	142	message => "You've been eited",
	143	do_backtrace => 0 ));
	144	ok($retval2->backtrace eq undef);
	145	is($retval2->errno, 1, "Got the errno");
	146	isnt($retval2->errno,20, "Errno knows that 20 != 1");
	147
	148
	149	undef $main::_STDOUT_;
	150	undef $main::_STDERR_;
	151	}
	152

+20

-0

t/test.pl less more

	0	# Before `make install' is performed this script should be runnable with
	1	# `make test'. After `make install' it should work as `perl test.pl'
	2
	3	######################### We start with some black magic to print on failure.
	4
	5	# Change 1..1 below to 1..last_test_to_print .
	6	# (It may become useful if the test is moved to ./t subdirectory.)
	7
	8	BEGIN { $\| = 1; print "1..1\n"; }
	9	END {print "not ok 1\n" unless $loaded;}
	10	use Class::ReturnValue;
	11	$loaded = 1;
	12	print "ok 1\n";
	13
	14	######################### End of black magic.
	15
	16	# Insert your test code below (better if it prints "ok 13"
	17	# (correspondingly "not ok 13") depending on the success of chunk 13
	18	# of the test code):
	19