Commit 3edd91f1f43aa2505a2eeaa7efc5463644f2e19f - libconvert-pem-perl

New upstream release Jose Luis Rivas Contreras 13 years ago

39 changed file(s) with 6677 addition(s) and 1399 deletion(s). Raw diff Collapse all Expand all

+10

-2

Changes less more

0		$Id: Changes 1832 2005-05-25 22:39:55Z btrott $
	0	Revision history for Convert::PEM
1	1
2		Revision history for Convert::PEM
	2	0.08 2010.12.06
	3	- Altered explode() to canonicalize line endings to \n, handling
	4	DOS (\r\n) and older mac (\r) line breaks cleanly. Thanks to Matt
	5	Gramlich for the patch.
	6	- Removed sign() and auto_install() from Makefile.PL.
	7	- Removed magic svn keywords.
	8	- Converted test suite to Test::More.
	9	- Added author tests (xt/) and modified SYNOPSIS for all modules to
	10	make them pass the compilation test.
3	11
4	12	0.07 2005.05.25
5	13	- Allow passing in Name and Macro parameters on encode and decode,

+15

-3

MANIFEST less more

0	0	Changes
1		inc/ExtUtils/AutoInstall.pm
2	1	inc/Module/Install.pm
3		inc/Module/Install/AutoInstall.pm
	2	inc/Module/Install/AuthorTests.pm
4	3	inc/Module/Install/Base.pm
5	4	inc/Module/Install/Can.pm
6	5	inc/Module/Install/Fetch.pm
7	6	inc/Module/Install/Include.pm
8	7	inc/Module/Install/Makefile.pm
9	8	inc/Module/Install/Metadata.pm
	9	inc/Module/Install/ReadmeFromPod.pm
	10	inc/Module/Install/Repository.pm
	11	inc/Module/Install/TestBase.pm
10	12	inc/Module/Install/Win32.pm
11	13	inc/Module/Install/WriteAll.pm
	14	inc/Spiffy.pm
	15	inc/Sub/Uplevel.pm
	16	inc/Test/Base.pm
	17	inc/Test/Base/Filter.pm
	18	inc/Test/Builder.pm
	19	inc/Test/Builder/Module.pm
	20	inc/Test/Exception.pm
	21	inc/Test/More.pm
12	22	lib/Convert/PEM.pm
13	23	lib/Convert/PEM/CBC.pm
14	24	Makefile.PL

19	29	t/01-readwrite.t
20	30	t/02-encode.t
21	31	t/03-ede3.t
22		ToDo
	32	t/04-explode.t
	33	xt/pod.t
	34	xt/synopsis.t

+28

-13

META.yml less more

	0	---
	1	abstract: 'Read/write encrypted ASN.1 PEM files'
	2	author:
	3	- '& COPYRIGHTS'
	4	build_requires:
	5	ExtUtils::MakeMaker: 6.42
	6	configure_requires:
	7	ExtUtils::MakeMaker: 6.42
	8	distribution_type: module
	9	generated_by: 'Module::Install version 1.00'
	10	license: perl
	11	meta-spec:
	12	url: http://module-build.sourceforge.net/META-spec-v1.4.html
	13	version: 1.4
0	14	name: Convert-PEM
1		version: 0.07
2		abstract: Read/write encrypted ASN.1 PEM files
3		author: Benjamin Trott <ben+cpan@stupidfool.org>
4		license: perl
5		distribution_type: module
	15	no_index:
	16	directory:
	17	- inc
	18	- t
	19	- xt
6	20	requires:
7	21	Class::ErrorHandler: 0
	22	Convert::ASN1: 0.10
	23	Crypt::DES_EDE3: 0
	24	Digest::MD5: 0
	25	Filter::Util::Call: 0
8	26	MIME::Base64: 0
9		Convert::ASN1: 0.10
10		Digest::MD5: 0
11		Crypt::DES_EDE3: 0
12		no_index:
13		directory:
14		- t
15		- inc
16		generated_by: Module::Install version 0.36
	27	perl: 5.8.1
	28	resources:
	29	license: http://dev.perl.org/licenses/
	30	repository: git://github.com/btrott/Convert-PEM.git
	31	version: 0.08

+16

-21

Makefile.PL less more

0		# $Id: Makefile.PL 1829 2005-05-25 21:51:40Z btrott $
	0	use inc::Module::Install;
	1	name 'Convert-PEM';
	2	all_from 'lib/Convert/PEM.pm';
	3	readme_from 'lib/Convert/PEM.pm';
1	4
2		use inc::Module::Install;
	5	requires 'Class::ErrorHandler';
	6	requires 'MIME::Base64';
	7	requires 'Convert::ASN1' => '0.10';
	8	requires 'Digest::MD5';
	9	requires 'Crypt::DES_EDE3';
3	10
4		name('Convert-PEM');
5		abstract('Read/write encrypted ASN.1 PEM files');
6		author('Benjamin Trott <ben+cpan@stupidfool.org>');
7		version_from('lib/Convert/PEM.pm');
8		license('perl');
9		no_index(directory => 't');
10		sign(1);
	11	test_requires 'Test::More';
	12	test_requires 'Test::Exception';
11	13
12		include('ExtUtils::AutoInstall');
13
14		requires('Class::ErrorHandler');
15		requires('MIME::Base64');
16		requires('Convert::ASN1' => '0.10');
17		requires('Digest::MD5');
18		requires('Crypt::DES_EDE3');
19
20		auto_include();
21		auto_install();
22
23		&WriteAll;
	14	use_test_base;
	15	auto_include_deps;
	16	author_tests('xt');
	17	auto_set_repository;
	18	WriteAll;

+231

-35

README less more

0		$Id: README 1829 2005-05-25 21:51:40Z btrott $
1
2		This is Convert::PEM, a module implementing read/write access
3		to ASN.1-encoded PEM files (with optional encryption).
4
5		PREREQUISITES
6
7		* Crypt::ErrorHandler
8		* MIME::Base64
9		* Convert::ASN1 (0.10 or greater)
10		* Digest::MD5
11		* Crypt::DES_EDE3
12
13		INSTALLATION
14
15		Convert::PEM installation is straightforward. If your cpan shell
16		is set up, you should just be able to do
17
18		% perl -MCPAN -e 'install Convert::PEM'
19
20		If you don't like that, you can download the distribution; the
21		latest version on CPAN can be found in
22
23		ftp://ftp.cpan.org/pub/CPAN/authors/id/B/BT/BTROTT/
24
25		Download it, unpack it, then build it as per the usual:
26
27		% perl Makefile.PL
28		% make && make test
29
30		Then install it:
31
32		% make install
33
34		Benjamin Trott / ben@rhumba.pair.com
	0	NAME
	1	Convert::PEM - Read/write encrypted ASN.1 PEM files
	2
	3	SYNOPSIS
	4	use Convert::PEM;
	5	my $pem = Convert::PEM->new(
	6	Name => "DSA PRIVATE KEY",
	7	ASN => qq(
	8	DSAPrivateKey SEQUENCE {
	9	version INTEGER,
	10	p INTEGER,
	11	q INTEGER,
	12	g INTEGER,
	13	pub_key INTEGER,
	14	priv_key INTEGER
	15	}
	16	));
	17
	18	my $keyfile = 'private-key.pem';
	19	my $pwd = 'foobar';
	20
	21	my $pkey = $pem->read(
	22	Filename => $keyfile,
	23	Password => $pwd
	24	);
	25
	26	$pem->write(
	27	Content => $pkey,
	28	Password => $pwd,
	29	Filename => $keyfile
	30	);
	31
	32	DESCRIPTION
	33	Convert::PEM reads and writes PEM files containing ASN.1-encoded
	34	objects. The files can optionally be encrypted using a symmetric cipher
	35	algorithm, such as 3DES. An unencrypted PEM file might look something
	36	like this:
	37
	38	-----BEGIN DH PARAMETERS-----
	39	MB4CGQDUoLoCULb9LsYm5+/WN992xxbiLQlEuIsCAQM=
	40	-----END DH PARAMETERS-----
	41
	42	The string beginning "MB4C..." is the Base64-encoded, ASN.1-encoded
	43	"object."
	44
	45	An encrypted file would have headers describing the type of encryption
	46	used, and the initialization vector:
	47
	48	-----BEGIN DH PARAMETERS-----
	49	Proc-Type: 4,ENCRYPTED
	50	DEK-Info: DES-EDE3-CBC,C814158661DC1449
	51
	52	AFAZFbnQNrGjZJ/ZemdVSoZa3HWujxZuvBHzHNoesxeyqqidFvnydA==
	53	-----END DH PARAMETERS-----
	54
	55	The two headers ("Proc-Type" and "DEK-Info") indicate information about
	56	the type of encryption used, and the string starting with "AFAZ..." is
	57	the Base64-encoded, encrypted, ASN.1-encoded contents of this "object."
	58
	59	The initialization vector ("C814158661DC1449") is chosen randomly.
	60
	61	USAGE
	62	$pem = Convert::PEM->new( %arg )
	63	Constructs a new Convert::PEM object designed to read/write an object
	64	of a specific type (given in %arg, see below). Returns the new object
	65	on success, "undef" on failure (see ERROR HANDLING for details).
	66
	67	%arg can contain:
	68
	69	* Name
	70
	71	The name of the object; when decoding a PEM-encoded stream, the name
	72	in the encoding will be checked against the value of Name.
	73	Similarly, when encoding an object, the value of Name will be used
	74	as the name of the object in the PEM-encoded content. For example,
	75	given the string "FOO BAR", the output from encode will start with
	76	a header like:
	77
	78	-----BEGIN FOO BAR-----
	79
	80	Name is a required argument.
	81
	82	* ASN
	83
	84	An ASN.1 description of the content to be either encoded or decoded.
	85
	86	ASN is a required argument.
	87
	88	* Macro
	89
	90	If your ASN.1 description (in the ASN parameter) includes more
	91	than one ASN.1 macro definition, you will want to use the Macro
	92	parameter to specify which definition to use when encoding/decoding
	93	objects. For example, if your ASN.1 description looks like this:
	94
	95	Foo ::= SEQUENCE {
	96	x INTEGER,
	97	bar Bar
	98	}
	99
	100	Bar ::= INTEGER
	101
	102	If you want to encode/decode a "Foo" object, you will need to tell
	103	Convert::PEM to use the "Foo" macro definition by using the
	104	Macro parameter and setting the value to "Foo".
	105
	106	Macro is an optional argument.
	107
	108	$obj = $pem->decode(%args)
	109	Decodes, and, optionally, decrypts a PEM file, returning the object as
	110	decoded by Convert::ASN1. The difference between this method and
	111	read is that read reads the contents of a PEM file on disk; this
	112	method expects you to pass the PEM contents as an argument.
	113
	114	If an error occurs while reading the file or decrypting/decoding the
	115	contents, the function returns undef, and you should check the error
	116	message using the errstr method (below).
	117
	118	%args can contain:
	119
	120	* Content
	121
	122	The PEM contents.
	123
	124	* Password
	125
	126	The password with which the file contents were encrypted.
	127
	128	If the file is encrypted, this is a mandatory argument (well, it's
	129	not strictly mandatory, but decryption isn't going to work without
	130	it). Otherwise it's not necessary.
	131
	132	$blob = $pem->encode(%args)
	133	Constructs the contents for the PEM file from an object: ASN.1-encodes
	134	the object, optionally encrypts those contents.
	135
	136	Returns undef on failure (encryption failure, file-writing failure,
	137	etc.); in this case you should check the error message using the
	138	errstr method (below). On success returns the constructed PEM string.
	139
	140	%args can contain:
	141
	142	* Content
	143
	144	A hash reference that will be passed to Convert::ASN1::encode, and
	145	which should correspond to the ASN.1 description you gave to the
	146	new method. The hash reference should have the exact same format
	147	as that returned from the read method.
	148
	149	This argument is mandatory.
	150
	151	* Password
	152
	153	A password used to encrypt the contents of the PEM file. This is an
	154	optional argument; if not provided the contents will be unencrypted.
	155
	156	$obj = $pem->read(%args)
	157	Reads, decodes, and, optionally, decrypts a PEM file, returning the
	158	object as decoded by Convert::ASN1. This is implemented as a wrapper
	159	around decode, with the bonus of reading the PEM file from disk for
	160	you.
	161
	162	If an error occurs while reading the file or decrypting/decoding the
	163	contents, the function returns undef, and you should check the error
	164	message using the errstr method (below).
	165
	166	In addition to the arguments that can be passed to the decode method
	167	(minus the Content method), %args can contain:
	168
	169	* Filename
	170
	171	The location of the PEM file that you wish to read.
	172
	173	$pem->write(%args)
	174	Constructs the contents for the PEM file from an object: ASN.1-encodes
	175	the object, optionally encrypts those contents; then writes the file to
	176	disk. This is implemented as a wrapper around encode, with the bonus
	177	of writing the file to disk for you.
	178
	179	Returns undef on failure (encryption failure, file-writing failure,
	180	etc.); in this case you should check the error message using the
	181	errstr method (below). On success returns the constructed PEM string.
	182
	183	In addition to the arguments for encode, %args can contain:
	184
	185	* Filename
	186
	187	The location on disk where you'd like the PEM file written.
	188
	189	$pem->errstr
	190	Returns the value of the last error that occurred. This should only be
	191	considered meaningful when you've received undef from one of the
	192	functions above; in all other cases its relevance is undefined.
	193
	194	$pem->asn
	195	Returns the Convert::ASN1 object used internally to decode and encode
	196	ASN.1 representations. This is useful when you wish to interact directly
	197	with that object; for example, if you need to call configure on that
	198	object to set the type of big-integer class to be used when
	199	decoding/encoding big integers:
	200
	201	$pem->asn->configure( decode => { bigint => 'Math::Pari' },
	202	encode => { bigint => 'Math::Pari' } );
	203
	204	ERROR HANDLING
	205	If an error occurs in any of the above methods, the method will return
	206	"undef". You should then call the method errstr to determine the
	207	source of the error:
	208
	209	$pem->errstr
	210
	211	In the case that you do not yet have a Convert::PEM object (that is,
	212	if an error occurs while creating a Convert::PEM object), the error
	213	can be obtained as a class method:
	214
	215	Convert::PEM->errstr
	216
	217	For example, if you try to decode an encrypted object, and you do not
	218	give a passphrase to decrypt the object:
	219
	220	my $obj = $pem->read( Filename => "encrypted.pem" )
	221	or die "Decryption failed: ", $pem->errstr;
	222
	223	LICENSE
	224	Convert::PEM is free software; you may redistribute it and/or modify it
	225	under the same terms as Perl itself.
	226
	227	AUTHOR & COPYRIGHTS
	228	Except where otherwise noted, Convert::PEM is Copyright Benjamin Trott,
	229	cpan@stupidfool.org. All rights reserved.
	230

-1

~~ToDo~~ less more

$Id: ToDo 87 2001-04-22 07:31:42Z btrott $

-2

debian/changelog less more

0		libconvert-pem-perl (0.07-3) UNRELEASED; urgency=low
	0	libconvert-pem-perl (0.08-1) UNRELEASED; urgency=low
1	1
2	2	[ gregor herrmann ]
3	3	* debian/control: Changed: Switched Vcs-Browser field to ViewSVN

9	9	[ gregor herrmann ]
10	10	* Change my email address.
11	11
12		-- gregor herrmann <gregoa@debian.org> Sun, 16 Nov 2008 20:40:56 +0100
	12	[ Jose Luis Rivas ]
	13	* New upstream release
	14
	15	-- Jose Luis Rivas <ghostbar@debian.org> Sat, 25 Dec 2010 13:00:46 -0430
13	16
14	17	libconvert-pem-perl (0.07-2) unstable; urgency=low
15	18

-631

~~inc/ExtUtils/AutoInstall.pm~~ less more

0		#line 1 "inc/ExtUtils/AutoInstall.pm - /Library/Perl/5.8.1/ExtUtils/AutoInstall.pm"
1		# $File: //member/autrijus/ExtUtils-AutoInstall/lib/ExtUtils/AutoInstall.pm $
2		# $Revision: #9 $ $Change: 9532 $ $DateTime: 2004/01/01 06:47:30 $ vim: expandtab shiftwidth=4
3
4		package ExtUtils::AutoInstall;
5		$ExtUtils::AutoInstall::VERSION = '0.56';
6
7		use strict;
8		use Cwd ();
9		use ExtUtils::MakeMaker ();
10
11		#line 282
12
13		# special map on pre-defined feature sets
14		my %FeatureMap = (
15		'' => 'Core Features', # XXX: deprecated
16		'-core' => 'Core Features',
17		);
18
19		# various lexical flags
20		my (@Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS);
21		my ($Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly);
22		my ($PostambleActions, $PostambleUsed);
23
24		$AcceptDefault = 1 unless -t STDIN; # non-interactive session
25		_init();
26
27		sub missing_modules {
28		return @Missing;
29		}
30
31		sub do_install {
32		__PACKAGE__->install(
33		[ UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config}],
34		@Missing,
35		);
36		}
37
38		# initialize various flags, and/or perform install
39		sub _init {
40		foreach my $arg (@ARGV, split(/[\s\t]+/, $ENV{PERL_EXTUTILS_AUTOINSTALL} \|\| '')) {
41		if ($arg =~ /^--config=(.*)$/) {
42		$Config = [ split(',', $1) ];
43		}
44		elsif ($arg =~ /^--installdeps=(.*)$/) {
45		__PACKAGE__->install($Config, @Missing = split(/,/, $1));
46		exit 0;
47		}
48		elsif ($arg =~ /^--default(?:deps)?$/) {
49		$AcceptDefault = 1;
50		}
51		elsif ($arg =~ /^--check(?:deps)?$/) {
52		$CheckOnly = 1;
53		}
54		elsif ($arg =~ /^--skip(?:deps)?$/) {
55		$SkipInstall = 1;
56		}
57		elsif ($arg =~ /^--test(?:only)?$/) {
58		$TestOnly = 1;
59		}
60		}
61		}
62
63		# overrides MakeMaker's prompt() to automatically accept the default choice
64		sub _prompt {
65		goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
66
67		my ($prompt, $default) = @_;
68		my $y = ($default =~ /^[Yy]/);
69
70		print $prompt, ' [', ($y ? 'Y' : 'y'), '/', ($y ? 'n' : 'N'), '] ';
71		print "$default\n";
72		return $default;
73		}
74
75		# the workhorse
76		sub import {
77		my $class = shift;
78		my @args = @_ or return;
79		my $core_all;
80
81		print "*** $class version ".$class->VERSION."\n";
82		print "*** Checking for dependencies...\n";
83
84		my $cwd = Cwd::cwd();
85
86		$Config = [];
87
88		my $maxlen = length((sort { length($b) <=> length($a) }
89		grep { /^[^\-]/ }
90		map { ref($_) ? keys %{ref($_) eq 'HASH' ? $_ : +{@{$_}}} : '' }
91		map { +{@args}->{$_} }
92		grep { /^[^\-]/ or /^-core$/i } keys %{+{@args}})[0]);
93
94		while (my ($feature, $modules) = splice(@args, 0, 2)) {
95		my (@required, @tests, @skiptests);
96		my $default = 1;
97		my $conflict = 0;
98
99		if ($feature =~ m/^-(\w+)$/) {
100		my $option = lc($1);
101
102		# check for a newer version of myself
103		_update_to($modules, @_) and return if $option eq 'version';
104
105		# sets CPAN configuration options
106		$Config = $modules if $option eq 'config';
107
108		# promote every features to core status
109		$core_all = ($modules =~ /^all$/i) and next
110		if $option eq 'core';
111
112		next unless $option eq 'core';
113		}
114
115		print "[".($FeatureMap{lc($feature)} \|\| $feature)."]\n";
116
117		$modules = [ %{$modules} ] if UNIVERSAL::isa($modules, 'HASH');
118
119		unshift @$modules, -default => &{shift(@$modules)}
120		if (ref($modules->[0]) eq 'CODE'); # XXX: bugward combatability
121
122		while (my ($mod, $arg) = splice(@$modules, 0, 2)) {
123		if ($mod =~ m/^-(\w+)$/) {
124		my $option = lc($1);
125
126		$default = $arg if ($option eq 'default');
127		$conflict = $arg if ($option eq 'conflict');
128		@tests = @{$arg} if ($option eq 'tests');
129		@skiptests = @{$arg} if ($option eq 'skiptests');
130
131		next;
132		}
133
134		printf("- %-${maxlen}s ...", $mod);
135
136		# XXX: check for conflicts and uninstalls(!) them.
137		if (defined(my $cur = _version_check(_load($mod), $arg \|\|= 0))) {
138		print "loaded. ($cur".($arg ? " >= $arg" : '').")\n";
139		push @Existing, $mod => $arg;
140		$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
141		}
142		else {
143		print "missing." . ($arg ? " (would need $arg)" : '') . "\n";
144		push @required, $mod => $arg;
145		}
146		}
147
148		next unless @required;
149
150		my $mandatory = ($feature eq '-core' or $core_all);
151
152		if (!$SkipInstall and ($CheckOnly or _prompt(
153		qq{==> Auto-install the }. (@required / 2).
154		($mandatory ? ' mandatory' : ' optional').
155		qq{ module(s) from CPAN?}, $default ? 'y' : 'n',
156		) =~ /^[Yy]/)) {
157		push (@Missing, @required);
158		$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
159		}
160
161		elsif (!$SkipInstall and $default and $mandatory and _prompt(
162		qq{==> The module(s) are mandatory! Really skip?}, 'n',
163		) =~ /^[Nn]/) {
164		push (@Missing, @required);
165		$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
166		}
167
168		else {
169		$DisabledTests{$_} = 1 for map { glob($_) } @tests;
170		}
171		}
172
173		_check_lock(); # check for $UnderCPAN
174
175		if (@Missing and not ($CheckOnly or $UnderCPAN)) {
176		require Config;
177		print "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
178		# make an educated guess of whether we'll need root permission.
179		print " (You may need to do that as the 'root' user.)\n" if eval '$>';
180		}
181		print "*** $class configuration finished.\n";
182
183		chdir $cwd;
184
185		# import to main::
186		no strict 'refs';
187		*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
188		}
189
190		# CPAN.pm is non-reentrant, so check if we're under it and have no CPANPLUS
191		sub _check_lock {
192		return unless @Missing;
193		return if _has_cpanplus();
194
195		require CPAN; CPAN::Config->load;
196		my $lock = MM->catfile($CPAN::Config->{cpan_home}, ".lock");
197
198		if (-f $lock and open(LOCK, $lock)
199		and ($^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid())
200		and ($CPAN::Config->{prerequisites_policy} \|\| '') ne 'ignore'
201		) {
202		print << '.';
203
204		*** Since we're running under CPAN, I'll just let it take care
205		of the dependency's installation later.
206		.
207		$UnderCPAN = 1;
208		}
209
210		close LOCK;
211		}
212
213		sub install {
214		my $class = shift;
215
216		my $i; # used below to strip leading '-' from config keys
217		my @config = (map { s/^-// if ++$i; $_ } @{+shift});
218
219		my (@modules, @installed);
220		while (my ($pkg, $ver) = splice(@_, 0, 2)) {
221		# grep out those already installed
222		if (defined(_version_check(_load($pkg), $ver))) {
223		push @installed, $pkg;
224		}
225		else {
226		push @modules, $pkg, $ver;
227		}
228		}
229
230		return @installed unless @modules; # nothing to do
231
232		print "*** Installing dependencies...\n";
233
234		return unless _connected_to('cpan.org');
235
236		my %args = @config;
237		my %failed;
238		local *FAILED;
239		if ($args{do_once} and open(FAILED, '.#autoinstall.failed')) {
240		while (<FAILED>) { chomp; $failed{$_}++ }
241		close FAILED;
242
243		my @newmod;
244		while (my ($k, $v) = splice(@modules, 0, 2)) {
245		push @newmod, ($k => $v) unless $failed{$k};
246		}
247		@modules = @newmod;
248		}
249
250		if (_has_cpanplus()) {
251		_install_cpanplus(\@modules, \@config);
252		}
253		else {
254		_install_cpan(\@modules, \@config);
255		}
256
257		print "*** $class installation finished.\n";
258
259		# see if we have successfully installed them
260		while (my ($pkg, $ver) = splice(@modules, 0, 2)) {
261		if (defined(_version_check(_load($pkg), $ver))) {
262		push @installed, $pkg;
263		}
264		elsif ($args{do_once} and open(FAILED, '>> .#autoinstall.failed')) {
265		print FAILED "$pkg\n";
266		}
267		}
268
269		close FAILED if $args{do_once};
270
271		return @installed;
272		}
273
274		sub _install_cpanplus {
275		my @modules = @{+shift};
276		my @config = @{+shift};
277		my $installed = 0;
278
279		require CPANPLUS::Backend;
280		my $cp = CPANPLUS::Backend->new;
281		my $conf = $cp->configure_object;
282
283		return unless _can_write($conf->_get_build('base'));
284
285		# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
286		my $makeflags = $conf->get_conf('makeflags') \|\| '';
287		if (UNIVERSAL::isa($makeflags, 'HASH')) {
288		# 0.03+ uses a hashref here
289		$makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
290		}
291		else {
292		# 0.02 and below uses a scalar
293		$makeflags = join(' ', split(' ', $makeflags), 'UNINST=1')
294		if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' });
295		}
296		$conf->set_conf(makeflags => $makeflags);
297
298		while (my ($key, $val) = splice(@config, 0, 2)) {
299		eval { $conf->set_conf($key, $val) };
300		}
301
302		my $modtree = $cp->module_tree;
303		while (my ($pkg, $ver) = splice(@modules, 0, 2)) {
304		print "*** Installing $pkg...\n";
305
306		MY::preinstall($pkg, $ver) or next if defined &MY::preinstall;
307
308		my $success;
309		my $obj = $modtree->{$pkg};
310
311		if ($obj and defined(_version_check($obj->{version}, $ver))) {
312		my $pathname = $pkg; $pathname =~ s/::/\\W/;
313
314		foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) {
315		delete $INC{$inc};
316		}
317
318		my $rv = $cp->install( modules => [ $obj->{module} ]);
319
320		if ($rv and ($rv->{$obj->{module}} or $rv->{ok})) {
321		print "*** $pkg successfully installed.\n";
322		$success = 1;
323		}
324		else {
325		print "*** $pkg installation cancelled.\n";
326		$success = 0;
327		}
328
329		$installed += $success;
330		}
331		else {
332		print << ".";
333		*** Could not find a version $ver or above for $pkg; skipping.
334		.
335		}
336
337		MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall;
338		}
339
340		return $installed;
341		}
342
343		sub _install_cpan {
344		my @modules = @{+shift};
345		my @config = @{+shift};
346		my $installed = 0;
347		my %args;
348
349		require CPAN; CPAN::Config->load;
350
351		return unless _can_write(MM->catfile($CPAN::Config->{cpan_home}, 'sources'));
352
353		# if we're root, set UNINST=1 to avoid trouble unless user asked for it.
354		my $makeflags = $CPAN::Config->{make_install_arg} \|\| '';
355		$CPAN::Config->{make_install_arg} = join(' ', split(' ', $makeflags), 'UNINST=1')
356		if ($makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' });
357
358		# don't show start-up info
359		$CPAN::Config->{inhibit_startup_message} = 1;
360
361		# set additional options
362		while (my ($opt, $arg) = splice(@config, 0, 2)) {
363		($args{$opt} = $arg, next)
364		if $opt =~ /^force$/; # pseudo-option
365		$CPAN::Config->{$opt} = $arg;
366		}
367
368		while (my ($pkg, $ver) = splice(@modules, 0, 2)) {
369		MY::preinstall($pkg, $ver) or next if defined &MY::preinstall;
370
371		print "*** Installing $pkg...\n";
372
373		my $obj = CPAN::Shell->expand(Module => $pkg);
374		my $success = 0;
375
376		if ($obj and defined(_version_check($obj->cpan_version, $ver))) {
377		my $pathname = $pkg; $pathname =~ s/::/\\W/;
378
379		foreach my $inc (grep { m/$pathname.pm/i } keys(%INC)) {
380		delete $INC{$inc};
381		}
382
383		$obj->force('install') if $args{force};
384
385		if ($obj->install eq 'YES') {
386		print "*** $pkg successfully installed.\n";
387		$success = 1;
388		}
389		else {
390		print "*** $pkg installation failed.\n";
391		$success = 0;
392		}
393
394		$installed += $success;
395		}
396		else {
397		print << ".";
398		*** Could not find a version $ver or above for $pkg; skipping.
399		.
400		}
401
402		MY::postinstall($pkg, $ver, $success) if defined &MY::postinstall;
403		}
404
405		return $installed;
406		}
407
408		sub _has_cpanplus {
409		return (
410		$HasCPANPLUS = (
411		$INC{'CPANPLUS/Config.pm'} or
412		_load('CPANPLUS::Shell::Default')
413		)
414		);
415		}
416
417		# make guesses on whether we're under the CPAN installation directory
418		sub _under_cpan {
419		require Cwd;
420		require File::Spec;
421
422		my $cwd = File::Spec->canonpath(Cwd::cwd());
423		my $cpan = File::Spec->canonpath($CPAN::Config->{cpan_home});
424
425		return (index($cwd, $cpan) > -1);
426		}
427
428		sub _update_to {
429		my $class = __PACKAGE__;
430		my $ver = shift;
431
432		return if defined(_version_check(_load($class), $ver)); # no need to upgrade
433
434		if (_prompt(
435		"==> A newer version of $class ($ver) is required. Install?", 'y'
436		) =~ /^[Nn]/) {
437		die "*** Please install $class $ver manually.\n";
438		}
439
440		print << ".";
441		*** Trying to fetch it from CPAN...
442		.
443
444		# install ourselves
445		_load($class) and return $class->import(@_)
446		if $class->install([], $class, $ver);
447
448		print << '.'; exit 1;
449
450		*** Cannot bootstrap myself. :-( Installation terminated.
451		.
452		}
453
454		# check if we're connected to some host, using inet_aton
455		sub _connected_to {
456		my $site = shift;
457
458		return (
459		( _load('Socket') and Socket::inet_aton($site) ) or _prompt(qq(
460		*** Your host cannot resolve the domain name '$site', which
461		probably means the Internet connections are unavailable.
462		==> Should we try to install the required module(s) anyway?), 'n'
463		) =~ /^[Yy]/
464		);
465		}
466
467		# check if a directory is writable; may create it on demand
468		sub _can_write {
469		my $path = shift;
470		mkdir ($path, 0755) unless -e $path;
471
472		require Config;
473		return 1 if -w $path and -w $Config::Config{sitelib};
474
475		print << ".";
476		*** You are not allowed to write to the directory '$path';
477		the installation may fail due to insufficient permissions.
478		.
479
480		if (eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(qq(
481		==> Should we try to re-execute the autoinstall process with 'sudo'?), 'y'
482		) =~ /^[Yy]/) {
483		# try to bootstrap ourselves from sudo
484		print << ".";
485		*** Trying to re-execute the autoinstall process with 'sudo'...
486		.
487		my $missing = join(',', @Missing);
488		my $config = join(',',
489		UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config}
490		) if $Config;
491
492		return unless system('sudo', $^X, $0, "--config=$config", "--installdeps=$missing");
493
494		print << ".";
495		*** The 'sudo' command exited with error! Resuming...
496		.
497		}
498
499		return _prompt(qq(
500		==> Should we try to install the required module(s) anyway?), 'n'
501		) =~ /^[Yy]/
502		}
503
504		# load a module and return the version it reports
505		sub _load {
506		my $mod = pop; # class/instance doesn't matter
507		my $file = $mod;
508
509		$file =~ s\|::\|/\|g;
510		$file .= '.pm';
511
512		local $@;
513		return eval { require $file; $mod->VERSION } \|\| ($@ ? undef : 0);
514		}
515
516		# compare two versions, either use Sort::Versions or plain comparison
517		sub _version_check {
518		my ($cur, $min) = @_;
519		return unless defined $cur;
520
521		$cur =~ s/\s+$//;
522
523		# check for version numbers that are not in decimal format
524		if (ref($cur) or ref($min) or $cur =~ /v\|\..\./ or $min =~ /v\|\..\./) {
525		if ($version::VERSION or defined(_load('version'))) {
526		# use version.pm if it is installed.
527		return ((version->new($cur) >= version->new($min)) ? $cur : undef);
528		}
529		elsif ($Sort::Versions::VERSION or defined(_load('Sort::Versions'))) {
530		# use Sort::Versions as the sorting algorithm for a.b.c versions
531		return ((Sort::Versions::versioncmp($cur, $min) != -1) ? $cur : undef);
532		}
533
534		warn "Cannot reliably compare non-decimal formatted versions.\n".
535		"Please install version.pm or Sort::Versions.\n";
536		}
537
538		# plain comparison
539		local $^W = 0; # shuts off 'not numeric' bugs
540		return ($cur >= $min ? $cur : undef);
541		}
542
543		# nothing; this usage is deprecated.
544		sub main::PREREQ_PM { return {}; }
545
546		sub _make_args {
547		my %args = @_;
548
549		$args{PREREQ_PM} = { %{$args{PREREQ_PM} \|\| {} }, @Existing, @Missing }
550		if $UnderCPAN or $TestOnly;
551
552		if ($args{EXE_FILES}) {
553		require ExtUtils::Manifest;
554		my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
555
556		$args{EXE_FILES} = [
557		grep { exists $manifest->{$_} } @{$args{EXE_FILES}}
558		];
559		}
560
561		$args{test}{TESTS} \|\|= 't/*.t';
562		$args{test}{TESTS} = join(' ', grep {
563		!exists($DisabledTests{$_})
564		} map { glob($_) } split(/\s+/, $args{test}{TESTS}));
565
566		my $missing = join(',', @Missing);
567		my $config = join(',',
568		UNIVERSAL::isa($Config, 'HASH') ? %{$Config} : @{$Config}
569		) if $Config;
570
571		$PostambleActions = (
572		$missing ? "\$(PERL) $0 --config=$config --installdeps=$missing"
573		: "\@\$(NOOP)"
574		);
575
576		return %args;
577		}
578
579		# a wrapper to ExtUtils::MakeMaker::WriteMakefile
580		sub Write {
581		require Carp;
582		Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
583
584		if ($CheckOnly) {
585		print << ".";
586		*** Makefile not written in check-only mode.
587		.
588		return;
589		}
590
591		my %args = _make_args(@_);
592
593		no strict 'refs';
594
595		$PostambleUsed = 0;
596		local *MY::postamble = \&postamble unless defined &MY::postamble;
597		ExtUtils::MakeMaker::WriteMakefile(%args);
598
599		print << "." unless $PostambleUsed;
600		*** WARNING: Makefile written with customized MY::postamble() without
601		including contents from ExtUtils::AutoInstall::postamble() --
602		auto installation features disabled. Please contact the author.
603		.
604
605		return 1;
606		}
607
608		sub postamble {
609		$PostambleUsed = 1;
610
611		return << ".";
612
613		config :: installdeps
614		\t\@\$(NOOP)
615
616		checkdeps ::
617		\t\$(PERL) $0 --checkdeps
618
619		installdeps ::
620		\t$PostambleActions
621
622		.
623
624		}
625
626		1;
627
628		__END__
629
630		#line 929

+59

-0

inc/Module/Install/AuthorTests.pm less more

	0	#line 1
	1	package Module::Install::AuthorTests;
	2
	3	use 5.005;
	4	use strict;
	5	use Module::Install::Base;
	6	use Carp ();
	7
	8	#line 16
	9
	10	use vars qw{$VERSION $ISCORE @ISA};
	11	BEGIN {
	12	$VERSION = '0.002';
	13	$ISCORE = 1;
	14	@ISA = qw{Module::Install::Base};
	15	}
	16
	17	#line 42
	18
	19	sub author_tests {
	20	my ($self, @dirs) = @_;
	21	_add_author_tests($self, \@dirs, 0);
	22	}
	23
	24	#line 56
	25
	26	sub recursive_author_tests {
	27	my ($self, @dirs) = @_;
	28	_add_author_tests($self, \@dirs, 1);
	29	}
	30
	31	sub _wanted {
	32	my $href = shift;
	33	sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
	34	}
	35
	36	sub _add_author_tests {
	37	my ($self, $dirs, $recurse) = @_;
	38	return unless $Module::Install::AUTHOR;
	39
	40	my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
	41
	42	# XXX: pick a default, later -- rjbs, 2008-02-24
	43	my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
	44	@dirs = grep { -d } @dirs;
	45
	46	if ($recurse) {
	47	require File::Find;
	48	my %test_dir;
	49	File::Find::find(_wanted(\%test_dir), @dirs);
	50	$self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
	51	} else {
	52	$self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
	53	}
	54	}
	55
	56	#line 107
	57
	58	1;

-62

~~inc/Module/Install/AutoInstall.pm~~ less more

0		#line 1 "inc/Module/Install/AutoInstall.pm - /Library/Perl/5.8.1/Module/Install/AutoInstall.pm"
1		package Module::Install::AutoInstall;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3
4		sub AutoInstall { $_[0] }
5
6		sub run {
7		my $self = shift;
8		$self->auto_install_now(@_);
9		}
10
11		sub write {
12		my $self = shift;
13		$self->auto_install(@_);
14		}
15
16		sub auto_install {
17		my $self = shift;
18		return if $self->{done}++;
19
20		# ExtUtils::AutoInstall Bootstrap Code, version 7.
21		AUTO:{my$p='ExtUtils::AutoInstall';my$v=0.49;$p->VERSION\|\|0>=$v
22		or+eval"use $p $v;1"or+do{my$e=$ENV{PERL_EXTUTILS_AUTOINSTALL};
23		(!defined($e)\|\|$e!~m/--(?:default\|skip\|testonly)/and-t STDIN or
24		eval"use ExtUtils::MakeMaker;WriteMakefile(PREREQ_PM=>{'$p',$v}
25		);1"and exit)and print"==> $p $v required. Install it from CP".
26		"AN? [Y/n] "and<STDIN>!~/^n/i and print"*** Installing $p\n"and
27		do{if (eval '$>' and lc(`sudo -V`) =~ /version/){system('sudo',
28		$^X,"-MCPANPLUS","-e","CPANPLUS::install $p");eval"use $p $v;1"
29		\|\|system('sudo', $^X, "-MCPAN", "-e", "CPAN::install $p")}eval{
30		require CPANPLUS;CPANPLUS::install$p};eval"use $p $v;1"or eval{
31		require CPAN;CPAN::install$p};eval"use $p $v;1"\|\|die"*** Please
32		manually install $p $v from cpan.org first...\n"}}}
33
34		# Flatten array of arrays into a single array
35		my @core = map @$_, map @$_, grep ref,
36		$self->build_requires, $self->requires;
37
38		while ( @core and @_ > 1 and $_[0] =~ /^-\w+$/ ) {
39		push @core, splice(@_, 0, 2);
40		}
41
42		ExtUtils::AutoInstall->import(
43		(@core ? (-core => \@core) : ()), @_, $self->features
44		);
45
46		$self->makemaker_args( ExtUtils::AutoInstall::_make_args() );
47
48		my $class = ref($self);
49		$self->postamble(
50		"# --- $class section:\n" .
51		ExtUtils::AutoInstall::postamble()
52		);
53		}
54
55		sub auto_install_now {
56		my $self = shift;
57		$self->auto_install;
58		ExtUtils::AutoInstall::do_install();
59		}
60
61		1;

+55

-26

inc/Module/Install/Base.pm less more

0		#line 1 "inc/Module/Install/Base.pm - /Library/Perl/5.8.1/Module/Install/Base.pm"
	0	#line 1
1	1	package Module::Install::Base;
2	2
3		#line 28
	3	use strict 'vars';
	4	use vars qw{$VERSION};
	5	BEGIN {
	6	$VERSION = '1.00';
	7	}
	8
	9	# Suspend handler for "redefined" warnings
	10	BEGIN {
	11	my $w = $SIG{__WARN__};
	12	$SIG{__WARN__} = sub { $w };
	13	}
	14
	15	#line 42
4	16
5	17	sub new {
6		my ($class, %args) = @_;
7
8		foreach my $method (qw(call load)) {
9		*{"$class\::$method"} = sub {
10		+shift->_top->$method(@_);
11		} unless defined &{"$class\::$method"};
12		}
13
14		bless(\%args, $class);
	18	my $class = shift;
	19	unless ( defined &{"${class}::call"} ) {
	20	*{"${class}::call"} = sub { shift->_top->call(@_) };
	21	}
	22	unless ( defined &{"${class}::load"} ) {
	23	*{"${class}::load"} = sub { shift->_top->load(@_) };
	24	}
	25	bless { @_ }, $class;
15	26	}
16	27
17		#line 46
	28	#line 61
18	29
19	30	sub AUTOLOAD {
20		my $self = shift;
21		goto &{$self->_top->autoload};
	31	local $@;
	32	my $func = eval { shift->_top->autoload } or return;
	33	goto &$func;
22	34	}
23	35
24		#line 57
	36	#line 75
25	37
26		sub _top { $_[0]->{_top} }
	38	sub _top {
	39	$_[0]->{_top};
	40	}
27	41
28		#line 68
	42	#line 90
29	43
30	44	sub admin {
31		my $self = shift;
32		$self->_top->{admin} or Module::Install::Base::FakeAdmin->new;
	45	$_[0]->_top->{admin}
	46	or
	47	Module::Install::Base::FakeAdmin->new;
33	48	}
34	49
	50	#line 106
	51
35	52	sub is_admin {
36		my $self = shift;
37		$self->admin->VERSION;
	53	! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
38	54	}
39	55
40	56	sub DESTROY {}
41	57
42	58	package Module::Install::Base::FakeAdmin;
43	59
44		my $Fake;
45		sub new { $Fake \|\|= bless(\@_, $_[0]) }
	60	use vars qw{$VERSION};
	61	BEGIN {
	62	$VERSION = $Module::Install::Base::VERSION;
	63	}
	64
	65	my $fake;
	66
	67	sub new {
	68	$fake \|\|= bless(\@_, $_[0]);
	69	}
	70
46	71	sub AUTOLOAD {}
	72
47	73	sub DESTROY {}
	74
	75	# Restore warning handler
	76	BEGIN {
	77	$SIG{__WARN__} = $SIG{__WARN__}->();
	78	}
48	79
49	80	1;
50	81
51		__END__
52
53		#line 112
	82	#line 159

+64

-21

inc/Module/Install/Can.pm less more

0		#line 1 "inc/Module/Install/Can.pm - /Library/Perl/5.8.1/Module/Install/Can.pm"
	0	#line 1
1	1	package Module::Install::Can;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3		$VERSION = '0.01';
4	2
5	3	use strict;
6		use Config ();
7		use File::Spec ();
8		use ExtUtils::MakeMaker ();
	4	use Config ();
	5	use File::Spec ();
	6	use ExtUtils::MakeMaker ();
	7	use Module::Install::Base ();
	8
	9	use vars qw{$VERSION @ISA $ISCORE};
	10	BEGIN {
	11	$VERSION = '1.00';
	12	@ISA = 'Module::Install::Base';
	13	$ISCORE = 1;
	14	}
	15
	16	# check if we can load some module
	17	### Upgrade this to not have to load the module if possible
	18	sub can_use {
	19	my ($self, $mod, $ver) = @_;
	20	$mod =~ s{::\|\\}{/}g;
	21	$mod .= '.pm' unless $mod =~ /\.pm$/i;
	22
	23	my $pkg = $mod;
	24	$pkg =~ s{/}{::}g;
	25	$pkg =~ s{\.pm$}{}i;
	26
	27	local $@;
	28	eval { require $mod; $pkg->VERSION($ver \|\| 0); 1 };
	29	}
9	30
10	31	# check if we can run some command
11	32	sub can_run {
12		my ($self, $cmd) = @_;
	33	my ($self, $cmd) = @_;
13	34
14		my $_cmd = $cmd;
15		return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
	35	my $_cmd = $cmd;
	36	return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
16	37
17		for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
18		my $abs = File::Spec->catfile($dir, $_[1]);
19		return $abs if (-x $abs or $abs = MM->maybe_command($abs));
20		}
	38	for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
	39	next if $dir eq '';
	40	my $abs = File::Spec->catfile($dir, $_[1]);
	41	return $abs if (-x $abs or $abs = MM->maybe_command($abs));
	42	}
21	43
22		return;
	44	return;
23	45	}
24	46
	47	# can we locate a (the) C compiler
25	48	sub can_cc {
26		my $self = shift;
27		my @chunks = split(/ /, $Config::Config{cc}) or return;
	49	my $self = shift;
	50	my @chunks = split(/ /, $Config::Config{cc}) or return;
28	51
29		# $Config{cc} may contain args; try to find out the program part
30		while (@chunks) {
31		return $self->can_run("@chunks") \|\| (pop(@chunks), next);
32		}
	52	# $Config{cc} may contain args; try to find out the program part
	53	while (@chunks) {
	54	return $self->can_run("@chunks") \|\| (pop(@chunks), next);
	55	}
33	56
34		return;
	57	return;
	58	}
	59
	60	# Fix Cygwin bug on maybe_command();
	61	if ( $^O eq 'cygwin' ) {
	62	require ExtUtils::MM_Cygwin;
	63	require ExtUtils::MM_Win32;
	64	if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
	65	*ExtUtils::MM_Cygwin::maybe_command = sub {
	66	my ($self, $file) = @_;
	67	if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
	68	ExtUtils::MM_Win32->maybe_command($file);
	69	} else {
	70	ExtUtils::MM_Unix->maybe_command($file);
	71	}
	72	}
	73	}
35	74	}
36	75
37	76	1;
	77
	78	__END__
	79
	80	#line 156

+15

-8

inc/Module/Install/Fetch.pm less more

0		#line 1 "inc/Module/Install/Fetch.pm - /Library/Perl/5.8.1/Module/Install/Fetch.pm"
	0	#line 1
1	1	package Module::Install::Fetch;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3	2
4		$VERSION = '0.01';
	3	use strict;
	4	use Module::Install::Base ();
	5
	6	use vars qw{$VERSION @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	11	}
5	12
6	13	sub get_file {
7	14	my ($self, %args) = @_;
8		my ($scheme, $host, $path, $file) =
	15	my ($scheme, $host, $path, $file) =
9	16	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
10	17
11		if ($scheme eq 'http' and !eval { require LWP::Simple; 1 }) {
	18	if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
12	19	$args{url} = $args{ftp_url}
13	20	or (warn("LWP support unavailable!\n"), return);
14		($scheme, $host, $path, $file) =
	21	($scheme, $host, $path, $file) =
15	22	$args{url} =~ m\|^(\w+)://([^/]+)(.+)/(.+)\| or return;
16	23	}
17	24

52	59	chdir $dir; return;
53	60	}
54	61
55		my @dialog = split(/\n/, << ".");
	62	my @dialog = split(/\n/, <<"END_FTP");
56	63	open $host
57	64	user anonymous anonymous\@example.com
58	65	cd $path
59	66	binary
60	67	get $file $file
61	68	quit
62		.
	69	END_FTP
63	70	foreach (@dialog) { $fh->print("$_\n") }
64	71	$fh->close;
65	72	} }

+30

-6

inc/Module/Install/Include.pm less more

0		#line 1 "inc/Module/Install/Include.pm - /Library/Perl/5.8.1/Module/Install/Include.pm"
	0	#line 1
1	1	package Module::Install::Include;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3	2
4		sub include { +shift->admin->include(@_) };
5		sub include_deps { +shift->admin->include_deps(@_) };
6		sub auto_include { +shift->admin->auto_include(@_) };
7		sub auto_include_deps { +shift->admin->auto_include_deps(@_) };
	3	use strict;
	4	use Module::Install::Base ();
	5
	6	use vars qw{$VERSION @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	11	}
	12
	13	sub include {
	14	shift()->admin->include(@_);
	15	}
	16
	17	sub include_deps {
	18	shift()->admin->include_deps(@_);
	19	}
	20
	21	sub auto_include {
	22	shift()->admin->auto_include(@_);
	23	}
	24
	25	sub auto_include_deps {
	26	shift()->admin->auto_include_deps(@_);
	27	}
	28
	29	sub auto_include_dependent_dists {
	30	shift()->admin->auto_include_dependent_dists(@_);
	31	}
8	32
9	33	1;

+385

-113

inc/Module/Install/Makefile.pm less more

0		#line 1 "inc/Module/Install/Makefile.pm - /Library/Perl/5.8.1/Module/Install/Makefile.pm"
	0	#line 1
1	1	package Module::Install::Makefile;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3
4		$VERSION = '0.01';
5	2
6	3	use strict 'vars';
7		use vars '$VERSION';
8
9		use ExtUtils::MakeMaker ();
	4	use ExtUtils::MakeMaker ();
	5	use Module::Install::Base ();
	6	use Fcntl qw/:flock :seek/;
	7
	8	use vars qw{$VERSION @ISA $ISCORE};
	9	BEGIN {
	10	$VERSION = '1.00';
	11	@ISA = 'Module::Install::Base';
	12	$ISCORE = 1;
	13	}
10	14
11	15	sub Makefile { $_[0] }
12	16
13		sub prompt {
14		shift;
15		goto &ExtUtils::MakeMaker::prompt;
16		}
	17	my %seen = ();
	18
	19	sub prompt {
	20	shift;
	21
	22	# Infinite loop protection
	23	my @c = caller();
	24	if ( ++$seen{"$c[1]\|$c[2]\|$_[0]"} > 3 ) {
	25	die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])";
	26	}
	27
	28	# In automated testing or non-interactive session, always use defaults
	29	if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
	30	local $ENV{PERL_MM_USE_DEFAULT} = 1;
	31	goto &ExtUtils::MakeMaker::prompt;
	32	} else {
	33	goto &ExtUtils::MakeMaker::prompt;
	34	}
	35	}
	36
	37	# Store a cleaned up version of the MakeMaker version,
	38	# since we need to behave differently in a variety of
	39	# ways based on the MM version.
	40	my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
	41
	42	# If we are passed a param, do a "newer than" comparison.
	43	# Otherwise, just return the MakeMaker version.
	44	sub makemaker {
	45	( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
	46	}
	47
	48	# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
	49	# as we only need to know here whether the attribute is an array
	50	# or a hash or something else (which may or may not be appendable).
	51	my %makemaker_argtype = (
	52	C => 'ARRAY',
	53	CONFIG => 'ARRAY',
	54	# CONFIGURE => 'CODE', # ignore
	55	DIR => 'ARRAY',
	56	DL_FUNCS => 'HASH',
	57	DL_VARS => 'ARRAY',
	58	EXCLUDE_EXT => 'ARRAY',
	59	EXE_FILES => 'ARRAY',
	60	FUNCLIST => 'ARRAY',
	61	H => 'ARRAY',
	62	IMPORTS => 'HASH',
	63	INCLUDE_EXT => 'ARRAY',
	64	LIBS => 'ARRAY', # ignore ''
	65	MAN1PODS => 'HASH',
	66	MAN3PODS => 'HASH',
	67	META_ADD => 'HASH',
	68	META_MERGE => 'HASH',
	69	PL_FILES => 'HASH',
	70	PM => 'HASH',
	71	PMLIBDIRS => 'ARRAY',
	72	PMLIBPARENTDIRS => 'ARRAY',
	73	PREREQ_PM => 'HASH',
	74	CONFIGURE_REQUIRES => 'HASH',
	75	SKIP => 'ARRAY',
	76	TYPEMAPS => 'ARRAY',
	77	XS => 'HASH',
	78	# VERSION => ['version',''], # ignore
	79	# _KEEP_AFTER_FLUSH => '',
	80
	81	clean => 'HASH',
	82	depend => 'HASH',
	83	dist => 'HASH',
	84	dynamic_lib=> 'HASH',
	85	linkext => 'HASH',
	86	macro => 'HASH',
	87	postamble => 'HASH',
	88	realclean => 'HASH',
	89	test => 'HASH',
	90	tool_autosplit => 'HASH',
	91
	92	# special cases where you can use makemaker_append
	93	CCFLAGS => 'APPENDABLE',
	94	DEFINE => 'APPENDABLE',
	95	INC => 'APPENDABLE',
	96	LDDLFLAGS => 'APPENDABLE',
	97	LDFROM => 'APPENDABLE',
	98	);
17	99
18	100	sub makemaker_args {
19		my $self = shift;
20		my $args = ($self->{makemaker_args} \|\|= {});
21		%$args = ( %$args, @_ ) if @_;
22		$args;
	101	my ($self, %new_args) = @_;
	102	my $args = ( $self->{makemaker_args} \|\|= {} );
	103	foreach my $key (keys %new_args) {
	104	if ($makemaker_argtype{$key}) {
	105	if ($makemaker_argtype{$key} eq 'ARRAY') {
	106	$args->{$key} = [] unless defined $args->{$key};
	107	unless (ref $args->{$key} eq 'ARRAY') {
	108	$args->{$key} = [$args->{$key}]
	109	}
	110	push @{$args->{$key}},
	111	ref $new_args{$key} eq 'ARRAY'
	112	? @{$new_args{$key}}
	113	: $new_args{$key};
	114	}
	115	elsif ($makemaker_argtype{$key} eq 'HASH') {
	116	$args->{$key} = {} unless defined $args->{$key};
	117	foreach my $skey (keys %{ $new_args{$key} }) {
	118	$args->{$key}{$skey} = $new_args{$key}{$skey};
	119	}
	120	}
	121	elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
	122	$self->makemaker_append($key => $new_args{$key});
	123	}
	124	}
	125	else {
	126	if (defined $args->{$key}) {
	127	warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
	128	}
	129	$args->{$key} = $new_args{$key};
	130	}
	131	}
	132	return $args;
	133	}
	134
	135	# For mm args that take multiple space-seperated args,
	136	# append an argument to the current list.
	137	sub makemaker_append {
	138	my $self = shift;
	139	my $name = shift;
	140	my $args = $self->makemaker_args;
	141	$args->{$name} = defined $args->{$name}
	142	? join( ' ', $args->{$name}, @_ )
	143	: join( ' ', @_ );
	144	}
	145
	146	sub build_subdirs {
	147	my $self = shift;
	148	my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
	149	for my $subdir (@_) {
	150	push @$subdirs, $subdir;
	151	}
23	152	}
24	153
25	154	sub clean_files {
26		my $self = shift;
27		my $clean = $self->makemaker_args->{clean} \|\|= {};
28		%$clean = (
29		%$clean,
30		FILES => join(" ", grep length, $clean->{FILES}, @_),
	155	my $self = shift;
	156	my $clean = $self->makemaker_args->{clean} \|\|= {};
	157	%$clean = (
	158	%$clean,
	159	FILES => join ' ', grep { length $_ } ($clean->{FILES} \|\| (), @_),
	160	);
	161	}
	162
	163	sub realclean_files {
	164	my $self = shift;
	165	my $realclean = $self->makemaker_args->{realclean} \|\|= {};
	166	%$realclean = (
	167	%$realclean,
	168	FILES => join ' ', grep { length $_ } ($realclean->{FILES} \|\| (), @_),
	169	);
	170	}
	171
	172	sub libs {
	173	my $self = shift;
	174	my $libs = ref $_[0] ? shift : [ shift ];
	175	$self->makemaker_args( LIBS => $libs );
	176	}
	177
	178	sub inc {
	179	my $self = shift;
	180	$self->makemaker_args( INC => shift );
	181	}
	182
	183	sub _wanted_t {
	184	}
	185
	186	sub tests_recursive {
	187	my $self = shift;
	188	my $dir = shift \|\| 't';
	189	unless ( -d $dir ) {
	190	die "tests_recursive dir '$dir' does not exist";
	191	}
	192	my %tests = map { $_ => 1 } split / /, ($self->tests \|\| '');
	193	require File::Find;
	194	File::Find::find(
	195	sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
	196	$dir
31	197	);
32		}
33
34		sub libs {
35		my $self = shift;
36		my $libs = ref $_[0] ? shift : [shift];
37		$self->makemaker_args( LIBS => $libs );
38		}
39
40		sub inc {
41		my $self = shift;
42		$self->makemaker_args( INC => shift );
	198	$self->tests( join ' ', sort keys %tests );
43	199	}
44	200
45	201	sub write {
46		my $self = shift;
47		die "&Makefile->write() takes no arguments\n" if @_;
48
49		my $args = $self->makemaker_args;
50
51		$args->{DISTNAME} = $self->name;
52		$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);
53		$args->{VERSION} = $self->version \|\| $self->determine_VERSION($args);
54		$args->{NAME} =~ s/-/::/g;
55
56		if ($] >= 5.005) {
57		$args->{ABSTRACT} = $self->abstract;
58		$args->{AUTHOR} = $self->author;
59		}
60		if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
61		$args->{NO_META} = 1;
62		}
63		if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 ) {
64		$args->{SIGN} = 1 if $self->sign;
65		}
66		delete $args->{SIGN} unless $self->is_admin;
67
68		# merge both kinds of requires into prereq_pm
69		my $prereq = ($args->{PREREQ_PM} \|\|= {});
70		%$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
71		($self->build_requires, $self->requires) );
72
73		# merge both kinds of requires into prereq_pm
74		my $dir = ($args->{DIR} \|\|= []);
75		if ($self->bundles) {
76		push @$dir, map "$_->[1]", @{$self->bundles};
77		delete $prereq->{$_->[0]} for @{$self->bundles};
78		}
79
80		if (my $perl_version = $self->perl_version) {
81		eval "use $perl_version; 1"
82		or die "ERROR: perl: Version $] is installed, ".
83		"but we need version >= $perl_version";
84		}
85
86		my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args;
87
88		if ($self->admin->preop) {
89		$args{dist} = $self->admin->preop;
90		}
91
92		ExtUtils::MakeMaker::WriteMakefile(%args);
93
94		$self->fix_up_makefile();
	202	my $self = shift;
	203	die "&Makefile->write() takes no arguments\n" if @_;
	204
	205	# Check the current Perl version
	206	my $perl_version = $self->perl_version;
	207	if ( $perl_version ) {
	208	eval "use $perl_version; 1"
	209	or die "ERROR: perl: Version $] is installed, "
	210	. "but we need version >= $perl_version";
	211	}
	212
	213	# Make sure we have a new enough MakeMaker
	214	require ExtUtils::MakeMaker;
	215
	216	if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
	217	# MakeMaker can complain about module versions that include
	218	# an underscore, even though its own version may contain one!
	219	# Hence the funny regexp to get rid of it. See RT #35800
	220	# for details.
	221	my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
	222	$self->build_requires( 'ExtUtils::MakeMaker' => $v );
	223	$self->configure_requires( 'ExtUtils::MakeMaker' => $v );
	224	} else {
	225	# Allow legacy-compatibility with 5.005 by depending on the
	226	# most recent EU:MM that supported 5.005.
	227	$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
	228	$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
	229	}
	230
	231	# Generate the MakeMaker params
	232	my $args = $self->makemaker_args;
	233	$args->{DISTNAME} = $self->name;
	234	$args->{NAME} = $self->module_name \|\| $self->name;
	235	$args->{NAME} =~ s/-/::/g;
	236	$args->{VERSION} = $self->version or die <<'EOT';
	237	ERROR: Can't determine distribution version. Please specify it
	238	explicitly via 'version' in Makefile.PL, or set a valid $VERSION
	239	in a module, and provide its file path via 'version_from' (or
	240	'all_from' if you prefer) in Makefile.PL.
	241	EOT
	242
	243	$DB::single = 1;
	244	if ( $self->tests ) {
	245	my @tests = split ' ', $self->tests;
	246	my %seen;
	247	$args->{test} = {
	248	TESTS => (join ' ', grep {!$seen{$_}++} @tests),
	249	};
	250	} elsif ( $Module::Install::ExtraTests::use_extratests ) {
	251	# Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
	252	# So, just ignore our xt tests here.
	253	} elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
	254	$args->{test} = {
	255	TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
	256	};
	257	}
	258	if ( $] >= 5.005 ) {
	259	$args->{ABSTRACT} = $self->abstract;
	260	$args->{AUTHOR} = join ', ', @{$self->author \|\| []};
	261	}
	262	if ( $self->makemaker(6.10) ) {
	263	$args->{NO_META} = 1;
	264	#$args->{NO_MYMETA} = 1;
	265	}
	266	if ( $self->makemaker(6.17) and $self->sign ) {
	267	$args->{SIGN} = 1;
	268	}
	269	unless ( $self->is_admin ) {
	270	delete $args->{SIGN};
	271	}
	272	if ( $self->makemaker(6.31) and $self->license ) {
	273	$args->{LICENSE} = $self->license;
	274	}
	275
	276	my $prereq = ($args->{PREREQ_PM} \|\|= {});
	277	%$prereq = ( %$prereq,
	278	map { @$_ } # flatten [module => version]
	279	map { @$_ }
	280	grep $_,
	281	($self->requires)
	282	);
	283
	284	# Remove any reference to perl, PREREQ_PM doesn't support it
	285	delete $args->{PREREQ_PM}->{perl};
	286
	287	# Merge both kinds of requires into BUILD_REQUIRES
	288	my $build_prereq = ($args->{BUILD_REQUIRES} \|\|= {});
	289	%$build_prereq = ( %$build_prereq,
	290	map { @$_ } # flatten [module => version]
	291	map { @$_ }
	292	grep $_,
	293	($self->configure_requires, $self->build_requires)
	294	);
	295
	296	# Remove any reference to perl, BUILD_REQUIRES doesn't support it
	297	delete $args->{BUILD_REQUIRES}->{perl};
	298
	299	# Delete bundled dists from prereq_pm, add it to Makefile DIR
	300	my $subdirs = ($args->{DIR} \|\| []);
	301	if ($self->bundles) {
	302	my %processed;
	303	foreach my $bundle (@{ $self->bundles }) {
	304	my ($mod_name, $dist_dir) = @$bundle;
	305	delete $prereq->{$mod_name};
	306	$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
	307	if (not exists $processed{$dist_dir}) {
	308	if (-d $dist_dir) {
	309	# List as sub-directory to be processed by make
	310	push @$subdirs, $dist_dir;
	311	}
	312	# Else do nothing: the module is already present on the system
	313	$processed{$dist_dir} = undef;
	314	}
	315	}
	316	}
	317
	318	unless ( $self->makemaker('6.55_03') ) {
	319	%$prereq = (%$prereq,%$build_prereq);
	320	delete $args->{BUILD_REQUIRES};
	321	}
	322
	323	if ( my $perl_version = $self->perl_version ) {
	324	eval "use $perl_version; 1"
	325	or die "ERROR: perl: Version $] is installed, "
	326	. "but we need version >= $perl_version";
	327
	328	if ( $self->makemaker(6.48) ) {
	329	$args->{MIN_PERL_VERSION} = $perl_version;
	330	}
	331	}
	332
	333	if ($self->installdirs) {
	334	warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
	335	$args->{INSTALLDIRS} = $self->installdirs;
	336	}
	337
	338	my %args = map {
	339	( $_ => $args->{$_} ) } grep {defined($args->{$_} )
	340	} keys %$args;
	341
	342	my $user_preop = delete $args{dist}->{PREOP};
	343	if ( my $preop = $self->admin->preop($user_preop) ) {
	344	foreach my $key ( keys %$preop ) {
	345	$args{dist}->{$key} = $preop->{$key};
	346	}
	347	}
	348
	349	my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
	350	$self->fix_up_makefile($mm->{FIRST_MAKEFILE} \|\| 'Makefile');
95	351	}
96	352
97	353	sub fix_up_makefile {
98		my $self = shift;
99		my $top_class = ref($self->_top) \|\| '';
100		my $top_version = $self->_top->VERSION \|\| '';
101
102		my $preamble = $self->preamble
103		? "# Preamble by $top_class $top_version\n" . $self->preamble
104		: '';
105		my $postamble = "# Postamble by $top_class $top_version\n" .
106		($self->postamble \|\| '');
107
108		open MAKEFILE, '< Makefile' or die $!;
109		my $makefile = do { local $/; <MAKEFILE> };
110		close MAKEFILE;
111
112		$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
113		$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
114		$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
115
116		$makefile =~ s/^(FULLPERL = .*)/$1 -Iinc/m;
117		$makefile =~ s/^(PERL = .*)/$1 -Iinc/m;
118
119		open MAKEFILE, '> Makefile' or die $!;
120		print MAKEFILE "$preamble$makefile$postamble";
121		close MAKEFILE;
	354	my $self = shift;
	355	my $makefile_name = shift;
	356	my $top_class = ref($self->_top) \|\| '';
	357	my $top_version = $self->_top->VERSION \|\| '';
	358
	359	my $preamble = $self->preamble
	360	? "# Preamble by $top_class $top_version\n"
	361	. $self->preamble
	362	: '';
	363	my $postamble = "# Postamble by $top_class $top_version\n"
	364	. ($self->postamble \|\| '');
	365
	366	local *MAKEFILE;
	367	open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	368	eval { flock MAKEFILE, LOCK_EX };
	369	my $makefile = do { local $/; <MAKEFILE> };
	370
	371	$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
	372	$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
	373	$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
	374	$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
	375	$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
	376
	377	# Module::Install will never be used to build the Core Perl
	378	# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
	379	# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
	380	$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
	381	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
	382
	383	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
	384	$makefile =~ s/(\"?)-I\$$PERL_LIB$\1//g;
	385
	386	# XXX - This is currently unused; not sure if it breaks other MM-users
	387	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
	388
	389	seek MAKEFILE, 0, SEEK_SET;
	390	truncate MAKEFILE, 0;
	391	print MAKEFILE "$preamble$makefile$postamble" or die $!;
	392	close MAKEFILE or die $!;
	393
	394	1;
122	395	}
123	396
124	397	sub preamble {
125		my ($self, $text) = @_;
126		$self->{preamble} = $text . $self->{preamble} if defined $text;
127		$self->{preamble};
	398	my ($self, $text) = @_;
	399	$self->{preamble} = $text . $self->{preamble} if defined $text;
	400	$self->{preamble};
128	401	}
129	402
130	403	sub postamble {
131		my ($self, $text) = @_;
132
133		$self->{postamble} \|\|= $self->admin->postamble;
134		$self->{postamble} .= $text if defined $text;
135		$self->{postamble}
	404	my ($self, $text) = @_;
	405	$self->{postamble} \|\|= $self->admin->postamble;
	406	$self->{postamble} .= $text if defined $text;
	407	$self->{postamble}
136	408	}
137	409
138	410	1;
139	411
140	412	__END__
141	413
142		#line 273
	414	#line 541

+706

-178

inc/Module/Install/Metadata.pm less more

0		#line 1 "inc/Module/Install/Metadata.pm - /Library/Perl/5.8.1/Module/Install/Metadata.pm"
	0	#line 1
1	1	package Module::Install::Metadata;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3
4		$VERSION = '0.04';
5	2
6	3	use strict 'vars';
7		use vars qw($VERSION);
8
9		sub Meta { shift }
10
11		my @scalar_keys = qw(
12		name module_name version abstract author license
13		distribution_type sign perl_version
	4	use Module::Install::Base ();
	5
	6	use vars qw{$VERSION @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	11	}
	12
	13	my @boolean_keys = qw{
	14	sign
	15	};
	16
	17	my @scalar_keys = qw{
	18	name
	19	module_name
	20	abstract
	21	version
	22	distribution_type
	23	tests
	24	installdirs
	25	};
	26
	27	my @tuple_keys = qw{
	28	configure_requires
	29	build_requires
	30	requires
	31	recommends
	32	bundles
	33	resources
	34	};
	35
	36	my @resource_keys = qw{
	37	homepage
	38	bugtracker
	39	repository
	40	};
	41
	42	my @array_keys = qw{
	43	keywords
	44	author
	45	};
	46
	47	*authors = \&author;
	48
	49	sub Meta { shift }
	50	sub Meta_BooleanKeys { @boolean_keys }
	51	sub Meta_ScalarKeys { @scalar_keys }
	52	sub Meta_TupleKeys { @tuple_keys }
	53	sub Meta_ResourceKeys { @resource_keys }
	54	sub Meta_ArrayKeys { @array_keys }
	55
	56	foreach my $key ( @boolean_keys ) {
	57	*$key = sub {
	58	my $self = shift;
	59	if ( defined wantarray and not @_ ) {
	60	return $self->{values}->{$key};
	61	}
	62	$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
	63	return $self;
	64	};
	65	}
	66
	67	foreach my $key ( @scalar_keys ) {
	68	*$key = sub {
	69	my $self = shift;
	70	return $self->{values}->{$key} if defined wantarray and !@_;
	71	$self->{values}->{$key} = shift;
	72	return $self;
	73	};
	74	}
	75
	76	foreach my $key ( @array_keys ) {
	77	*$key = sub {
	78	my $self = shift;
	79	return $self->{values}->{$key} if defined wantarray and !@_;
	80	$self->{values}->{$key} \|\|= [];
	81	push @{$self->{values}->{$key}}, @_;
	82	return $self;
	83	};
	84	}
	85
	86	foreach my $key ( @resource_keys ) {
	87	*$key = sub {
	88	my $self = shift;
	89	unless ( @_ ) {
	90	return () unless $self->{values}->{resources};
	91	return map { $_->[1] }
	92	grep { $_->[0] eq $key }
	93	@{ $self->{values}->{resources} };
	94	}
	95	return $self->{values}->{resources}->{$key} unless @_;
	96	my $uri = shift or die(
	97	"Did not provide a value to $key()"
	98	);
	99	$self->resources( $key => $uri );
	100	return 1;
	101	};
	102	}
	103
	104	foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
	105	*$key = sub {
	106	my $self = shift;
	107	return $self->{values}->{$key} unless @_;
	108	my @added;
	109	while ( @_ ) {
	110	my $module = shift or last;
	111	my $version = shift \|\| 0;
	112	push @added, [ $module, $version ];
	113	}
	114	push @{ $self->{values}->{$key} }, @added;
	115	return map {@$_} @added;
	116	};
	117	}
	118
	119	# Resource handling
	120	my %lc_resource = map { $_ => 1 } qw{
	121	homepage
	122	license
	123	bugtracker
	124	repository
	125	};
	126
	127	sub resources {
	128	my $self = shift;
	129	while ( @_ ) {
	130	my $name = shift or last;
	131	my $value = shift or next;
	132	if ( $name eq lc $name and ! $lc_resource{$name} ) {
	133	die("Unsupported reserved lowercase resource '$name'");
	134	}
	135	$self->{values}->{resources} \|\|= [];
	136	push @{ $self->{values}->{resources} }, [ $name, $value ];
	137	}
	138	$self->{values}->{resources};
	139	}
	140
	141	# Aliases for build_requires that will have alternative
	142	# meanings in some future version of META.yml.
	143	sub test_requires { shift->build_requires(@_) }
	144	sub install_requires { shift->build_requires(@_) }
	145
	146	# Aliases for installdirs options
	147	sub install_as_core { $_[0]->installdirs('perl') }
	148	sub install_as_cpan { $_[0]->installdirs('site') }
	149	sub install_as_site { $_[0]->installdirs('site') }
	150	sub install_as_vendor { $_[0]->installdirs('vendor') }
	151
	152	sub dynamic_config {
	153	my $self = shift;
	154	unless ( @_ ) {
	155	warn "You MUST provide an explicit true/false value to dynamic_config\n";
	156	return $self;
	157	}
	158	$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
	159	return 1;
	160	}
	161
	162	sub perl_version {
	163	my $self = shift;
	164	return $self->{values}->{perl_version} unless @_;
	165	my $version = shift or die(
	166	"Did not provide a value to perl_version()"
	167	);
	168
	169	# Normalize the version
	170	$version = $self->_perl_version($version);
	171
	172	# We don't support the reall old versions
	173	unless ( $version >= 5.005 ) {
	174	die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
	175	}
	176
	177	$self->{values}->{perl_version} = $version;
	178	}
	179
	180	sub all_from {
	181	my ( $self, $file ) = @_;
	182
	183	unless ( defined($file) ) {
	184	my $name = $self->name or die(
	185	"all_from called with no args without setting name() first"
	186	);
	187	$file = join('/', 'lib', split(/-/, $name)) . '.pm';
	188	$file =~ s{.*/}{} unless -e $file;
	189	unless ( -e $file ) {
	190	die("all_from cannot find $file from $name");
	191	}
	192	}
	193	unless ( -f $file ) {
	194	die("The path '$file' does not exist, or is not a file");
	195	}
	196
	197	$self->{values}{all_from} = $file;
	198
	199	# Some methods pull from POD instead of code.
	200	# If there is a matching .pod, use that instead
	201	my $pod = $file;
	202	$pod =~ s/\.pm$/.pod/i;
	203	$pod = $file unless -e $pod;
	204
	205	# Pull the different values
	206	$self->name_from($file) unless $self->name;
	207	$self->version_from($file) unless $self->version;
	208	$self->perl_version_from($file) unless $self->perl_version;
	209	$self->author_from($pod) unless @{$self->author \|\| []};
	210	$self->license_from($pod) unless $self->license;
	211	$self->abstract_from($pod) unless $self->abstract;
	212
	213	return 1;
	214	}
	215
	216	sub provides {
	217	my $self = shift;
	218	my $provides = ( $self->{values}->{provides} \|\|= {} );
	219	%$provides = (%$provides, @_) if @_;
	220	return $provides;
	221	}
	222
	223	sub auto_provides {
	224	my $self = shift;
	225	return $self unless $self->is_admin;
	226	unless (-e 'MANIFEST') {
	227	warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
	228	return $self;
	229	}
	230	# Avoid spurious warnings as we are not checking manifest here.
	231	local $SIG{__WARN__} = sub {1};
	232	require ExtUtils::Manifest;
	233	local *ExtUtils::Manifest::manicheck = sub { return };
	234
	235	require Module::Build;
	236	my $build = Module::Build->new(
	237	dist_name => $self->name,
	238	dist_version => $self->version,
	239	license => $self->license,
	240	);
	241	$self->provides( %{ $build->find_dist_packages \|\| {} } );
	242	}
	243
	244	sub feature {
	245	my $self = shift;
	246	my $name = shift;
	247	my $features = ( $self->{values}->{features} \|\|= [] );
	248	my $mods;
	249
	250	if ( @_ == 1 and ref( $_[0] ) ) {
	251	# The user used ->feature like ->features by passing in the second
	252	# argument as a reference. Accomodate for that.
	253	$mods = $_[0];
	254	} else {
	255	$mods = \@_;
	256	}
	257
	258	my $count = 0;
	259	push @$features, (
	260	$name => [
	261	map {
	262	ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
	263	} @$mods
	264	]
	265	);
	266
	267	return @$features;
	268	}
	269
	270	sub features {
	271	my $self = shift;
	272	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
	273	$self->feature( $name, @$mods );
	274	}
	275	return $self->{values}->{features}
	276	? @{ $self->{values}->{features} }
	277	: ();
	278	}
	279
	280	sub no_index {
	281	my $self = shift;
	282	my $type = shift;
	283	push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
	284	return $self->{values}->{no_index};
	285	}
	286
	287	sub read {
	288	my $self = shift;
	289	$self->include_deps( 'YAML::Tiny', 0 );
	290
	291	require YAML::Tiny;
	292	my $data = YAML::Tiny::LoadFile('META.yml');
	293
	294	# Call methods explicitly in case user has already set some values.
	295	while ( my ( $key, $value ) = each %$data ) {
	296	next unless $self->can($key);
	297	if ( ref $value eq 'HASH' ) {
	298	while ( my ( $module, $version ) = each %$value ) {
	299	$self->can($key)->($self, $module => $version );
	300	}
	301	} else {
	302	$self->can($key)->($self, $value);
	303	}
	304	}
	305	return $self;
	306	}
	307
	308	sub write {
	309	my $self = shift;
	310	return $self unless $self->is_admin;
	311	$self->admin->write_meta;
	312	return $self;
	313	}
	314
	315	sub version_from {
	316	require ExtUtils::MM_Unix;
	317	my ( $self, $file ) = @_;
	318	$self->version( ExtUtils::MM_Unix->parse_version($file) );
	319
	320	# for version integrity check
	321	$self->makemaker_args( VERSION_FROM => $file );
	322	}
	323
	324	sub abstract_from {
	325	require ExtUtils::MM_Unix;
	326	my ( $self, $file ) = @_;
	327	$self->abstract(
	328	bless(
	329	{ DISTNAME => $self->name },
	330	'ExtUtils::MM_Unix'
	331	)->parse_abstract($file)
	332	);
	333	}
	334
	335	# Add both distribution and module name
	336	sub name_from {
	337	my ($self, $file) = @_;
	338	if (
	339	Module::Install::_read($file) =~ m/
	340	^ \s*
	341	package \s*
	342	([\w:]+)
	343	\s* ;
	344	/ixms
	345	) {
	346	my ($name, $module_name) = ($1, $1);
	347	$name =~ s{::}{-}g;
	348	$self->name($name);
	349	unless ( $self->module_name ) {
	350	$self->module_name($module_name);
	351	}
	352	} else {
	353	die("Cannot determine name from $file\n");
	354	}
	355	}
	356
	357	sub _extract_perl_version {
	358	if (
	359	$_[0] =~ m/
	360	^\s*
	361	(?:use\|require) \s*
	362	v?
	363	([\d_\.]+)
	364	\s* ;
	365	/ixms
	366	) {
	367	my $perl_version = $1;
	368	$perl_version =~ s{_}{}g;
	369	return $perl_version;
	370	} else {
	371	return;
	372	}
	373	}
	374
	375	sub perl_version_from {
	376	my $self = shift;
	377	my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
	378	if ($perl_version) {
	379	$self->perl_version($perl_version);
	380	} else {
	381	warn "Cannot determine perl version info from $_[0]\n";
	382	return;
	383	}
	384	}
	385
	386	sub author_from {
	387	my $self = shift;
	388	my $content = Module::Install::_read($_[0]);
	389	if ($content =~ m/
	390	=head \d \s+ (?:authors?)\b \s*
	391	([^\n]*)
	392	\|
	393	=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
	394	.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
	395	([^\n]*)
	396	/ixms) {
	397	my $author = $1 \|\| $2;
	398
	399	# XXX: ugly but should work anyway...
	400	if (eval "require Pod::Escapes; 1") {
	401	# Pod::Escapes has a mapping table.
	402	# It's in core of perl >= 5.9.3, and should be installed
	403	# as one of the Pod::Simple's prereqs, which is a prereq
	404	# of Pod::Text 3.x (see also below).
	405	$author =~ s{ E<( (\d+) \| ([A-Za-z]+) )> }
	406	{
	407	defined $2
	408	? chr($2)
	409	: defined $Pod::Escapes::Name2character_number{$1}
	410	? chr($Pod::Escapes::Name2character_number{$1})
	411	: do {
	412	warn "Unknown escape: E<$1>";
	413	"E<$1>";
	414	};
	415	}gex;
	416	}
	417	elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
	418	# Pod::Text < 3.0 has yet another mapping table,
	419	# though the table name of 2.x and 1.x are different.
	420	# (1.x is in core of Perl < 5.6, 2.x is in core of
	421	# Perl < 5.9.3)
	422	my $mapping = ($Pod::Text::VERSION < 2)
	423	? \%Pod::Text::HTML_Escapes
	424	: \%Pod::Text::ESCAPES;
	425	$author =~ s{ E<( (\d+) \| ([A-Za-z]+) )> }
	426	{
	427	defined $2
	428	? chr($2)
	429	: defined $mapping->{$1}
	430	? $mapping->{$1}
	431	: do {
	432	warn "Unknown escape: E<$1>";
	433	"E<$1>";
	434	};
	435	}gex;
	436	}
	437	else {
	438	$author =~ s{E<lt>}{<}g;
	439	$author =~ s{E<gt>}{>}g;
	440	}
	441	$self->author($author);
	442	} else {
	443	warn "Cannot determine author info from $_[0]\n";
	444	}
	445	}
	446
	447	#Stolen from M::B
	448	my %license_urls = (
	449	perl => 'http://dev.perl.org/licenses/',
	450	apache => 'http://apache.org/licenses/LICENSE-2.0',
	451	apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
	452	artistic => 'http://opensource.org/licenses/artistic-license.php',
	453	artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
	454	lgpl => 'http://opensource.org/licenses/lgpl-license.php',
	455	lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
	456	lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
	457	bsd => 'http://opensource.org/licenses/bsd-license.php',
	458	gpl => 'http://opensource.org/licenses/gpl-license.php',
	459	gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
	460	gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
	461	mit => 'http://opensource.org/licenses/mit-license.php',
	462	mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
	463	open_source => undef,
	464	unrestricted => undef,
	465	restrictive => undef,
	466	unknown => undef,
14	467	);
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		if ($module eq 'perl') {
35		$version =~ s{^(\d+)\.(\d+)\.(\d+)}
36		{$1 + $2/1_000 + $3/1_000_000}e;
37		$self->perl_version($version);
38		next;
39		}
40		my $rv = [$module, $version];
41		push @{$self->{'values'}{$key}}, $rv;
42		push @rv, $rv;
43		}
44		return @rv;
45		};
46		}
47
48		sub features {
	468
	469	sub license {
	470	my $self = shift;
	471	return $self->{values}->{license} unless @_;
	472	my $license = shift or die(
	473	'Did not provide a value to license()'
	474	);
	475	$license = __extract_license($license) \|\| lc $license;
	476	$self->{values}->{license} = $license;
	477
	478	# Automatically fill in license URLs
	479	if ( $license_urls{$license} ) {
	480	$self->resources( license => $license_urls{$license} );
	481	}
	482
	483	return 1;
	484	}
	485
	486	sub _extract_license {
	487	my $pod = shift;
	488	my $matched;
	489	return __extract_license(
	490	($matched) = $pod =~ m/
	491	(=head \d \s+ L(?i:ICEN[CS]E\|ICENSING)\b.*?)
	492	(=head \d.\|=cut.\|)\z
	493	/xms
	494	) \|\| __extract_license(
	495	($matched) = $pod =~ m/
	496	(=head \d \s+ (?:C(?i:OPYRIGHTS?)\|L(?i:EGAL))\b.*?)
	497	(=head \d.\|=cut.\|)\z
	498	/xms
	499	);
	500	}
	501
	502	sub __extract_license {
	503	my $license_text = shift or return;
	504	my @phrases = (
	505	'(?:under )?the same (?:terms\|license) as (?:perl\|the perl (?:\d )?programming language)' => 'perl', 1,
	506	'(?:under )?the terms of (?:perl\|the perl programming language) itself' => 'perl', 1,
	507	'Artistic and GPL' => 'perl', 1,
	508	'GNU general public license' => 'gpl', 1,
	509	'GNU public license' => 'gpl', 1,
	510	'GNU lesser general public license' => 'lgpl', 1,
	511	'GNU lesser public license' => 'lgpl', 1,
	512	'GNU library general public license' => 'lgpl', 1,
	513	'GNU library public license' => 'lgpl', 1,
	514	'GNU Free Documentation license' => 'unrestricted', 1,
	515	'GNU Affero General Public License' => 'open_source', 1,
	516	'(?:Free)?BSD license' => 'bsd', 1,
	517	'Artistic license' => 'artistic', 1,
	518	'Apache (?:Software )?license' => 'apache', 1,
	519	'GPL' => 'gpl', 1,
	520	'LGPL' => 'lgpl', 1,
	521	'BSD' => 'bsd', 1,
	522	'Artistic' => 'artistic', 1,
	523	'MIT' => 'mit', 1,
	524	'Mozilla Public License' => 'mozilla', 1,
	525	'Q Public License' => 'open_source', 1,
	526	'OpenSSL License' => 'unrestricted', 1,
	527	'SSLeay License' => 'unrestricted', 1,
	528	'zlib License' => 'open_source', 1,
	529	'proprietary' => 'proprietary', 0,
	530	);
	531	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
	532	$pattern =~ s#\s+#\\s+#gs;
	533	if ( $license_text =~ /\b$pattern\b/i ) {
	534	return $license;
	535	}
	536	}
	537	return '';
	538	}
	539
	540	sub license_from {
	541	my $self = shift;
	542	if (my $license=_extract_license(Module::Install::_read($_[0]))) {
	543	$self->license($license);
	544	} else {
	545	warn "Cannot determine license info from $_[0]\n";
	546	return 'unknown';
	547	}
	548	}
	549
	550	sub _extract_bugtracker {
	551	my @links = $_[0] =~ m#L<(
	552	\Qhttp://rt.cpan.org/\E[^>]+\|
	553	\Qhttp://github.com/\E[\w_]+/[\w_]+/issues\|
	554	\Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
	555	)>#gx;
	556	my %links;
	557	@links{@links}=();
	558	@links=keys %links;
	559	return @links;
	560	}
	561
	562	sub bugtracker_from {
	563	my $self = shift;
	564	my $content = Module::Install::_read($_[0]);
	565	my @links = _extract_bugtracker($content);
	566	unless ( @links ) {
	567	warn "Cannot determine bugtracker info from $_[0]\n";
	568	return 0;
	569	}
	570	if ( @links > 1 ) {
	571	warn "Found more than one bugtracker link in $_[0]\n";
	572	return 0;
	573	}
	574
	575	# Set the bugtracker
	576	bugtracker( $links[0] );
	577	return 1;
	578	}
	579
	580	sub requires_from {
	581	my $self = shift;
	582	my $content = Module::Install::_readperl($_[0]);
	583	my @requires = $content =~ m/^use\s+([^\W\d]\w(?:::\w+))\s+([\d\.]+)/mg;
	584	while ( @requires ) {
	585	my $module = shift @requires;
	586	my $version = shift @requires;
	587	$self->requires( $module => $version );
	588	}
	589	}
	590
	591	sub test_requires_from {
	592	my $self = shift;
	593	my $content = Module::Install::_readperl($_[0]);
	594	my @requires = $content =~ m/^use\s+([^\W\d]\w(?:::\w+))\s+([\d\.]+)/mg;
	595	while ( @requires ) {
	596	my $module = shift @requires;
	597	my $version = shift @requires;
	598	$self->test_requires( $module => $version );
	599	}
	600	}
	601
	602	# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
	603	# numbers (eg, 5.006001 or 5.008009).
	604	# Also, convert double-part versions (eg, 5.8)
	605	sub _perl_version {
	606	my $v = $_[-1];
	607	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
	608	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0\|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 \|\| 0)/e;
	609	$v =~ s/(\.\d\d\d)000$/$1/;
	610	$v =~ s/_.+$//;
	611	if ( ref($v) ) {
	612	# Numify
	613	$v = $v + 0;
	614	}
	615	return $v;
	616	}
	617
	618	sub add_metadata {
49	619	my $self = shift;
50		while (my ($name, $mods) = splice(@_, 0, 2)) {
51		my $count = 0;
52		push @{$self->{'values'}{'features'}}, ($name => [
53		map { (++$count % 2 and ref($_) and ($count += $#$_)) ? @$_ : $_ } @$mods
54		] );
	620	my %hash = @_;
	621	for my $key (keys %hash) {
	622	warn "add_metadata: $key is not prefixed with 'x_'.\n" .
	623	"Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
	624	$self->{values}->{$key} = $hash{$key};
55	625	}
56		return @{$self->{'values'}{'features'}};
57		}
58
59		sub no_index {
60		my $self = shift;
61		my $type = shift;
62		push @{$self->{'values'}{'no_index'}{$type}}, @_ if $type;
63		return $self->{'values'}{'no_index'};
64		}
65
66		sub _dump {
67		my $self = shift;
68		my $package = ref($self->_top);
69		my $version = $self->_top->VERSION;
70		my %values = %{$self->{'values'}};
71
72		delete $values{sign};
73		if (my $perl_version = delete $values{perl_version}) {
74		# Always canonical to three-dot version
75		$perl_version =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2), int($3))}e
76		if $perl_version >= 5.006;
77		$values{requires} = [
78		[perl => $perl_version],
79		@{$values{requires}\|\|[]},
80		];
81		}
82
83		warn "No license specified, setting license = 'unknown'\n"
84		unless $values{license};
85
86		$values{license} \|\|= 'unknown';
87		$values{distribution_type} \|\|= 'module';
88		$values{name} \|\|= do {
89		my $name = $values{module_name};
90		$name =~ s/::/-/g;
91		$name;
92		} if $values{module_name};
93
94		if ($values{name} =~ /::/) {
95		my $name = $values{name};
96		$name =~ s/::/-/g;
97		die "Error in name(): '$values{name}' should be '$name'!\n";
98		}
99
100		my $dump = '';
101		foreach my $key (@scalar_keys) {
102		$dump .= "$key: $values{$key}\n" if exists $values{$key};
103		}
104		foreach my $key (@tuple_keys) {
105		next unless exists $values{$key};
106		$dump .= "$key:\n";
107		foreach (@{$values{$key}}) {
108		$dump .= " $_->[0]: $_->[1]\n";
109		}
110		}
111
112		if (my $no_index = $values{no_index}) {
113		push @{$no_index->{'directory'}}, 'inc';
114		require YAML;
115		local $YAML::UseHeader = 0;
116		$dump .= YAML::Dump({ no_index => $no_index});
117		}
118		else {
119		$dump .= << "META";
120		no_index:
121		directory:
122		- inc
123		META
124		}
125
126		$dump .= "generated_by: $package version $version\n";
127		return $dump;
128		}
129
130		sub read {
131		my $self = shift;
132		$self->include_deps( 'YAML', 0 );
133		require YAML;
134		my $data = YAML::LoadFile( 'META.yml' );
135		# Call methods explicitly in case user has already set some values.
136		while ( my ($key, $value) = each %$data ) {
137		next unless $self->can( $key );
138		if (ref $value eq 'HASH') {
139		while (my ($module, $version) = each %$value) {
140		$self->$key( $module => $version );
141		}
142		}
143		else {
144		$self->$key( $value );
145		}
146		}
147		return $self;
148		}
149
150		sub write {
151		my $self = shift;
152		return $self unless $self->is_admin;
153
154		META_NOT_OURS: {
155		local *FH;
156		if (open FH, "META.yml") {
157		while (<FH>) {
158		last META_NOT_OURS if /^generated_by: Module::Install\b/;
159		}
160		return $self if -s FH;
161		}
162		}
163
164		warn "Writing META.yml\n";
165		open META, "> META.yml" or warn "Cannot write to META.yml: $!";
166		print META $self->_dump;
167		close META;
168		return $self;
169		}
170
171		sub version_from {
172		my ($self, $version_from) = @_;
173		require ExtUtils::MM_Unix;
174		$self->version(ExtUtils::MM_Unix->parse_version($version_from));
175		}
176
177		sub abstract_from {
178		my ($self, $abstract_from) = @_;
179		require ExtUtils::MM_Unix;
180		$self->abstract(
181		bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix')
182		->parse_abstract($abstract_from)
183		);
	626	}
	627
	628
	629	######################################################################
	630	# MYMETA Support
	631
	632	sub WriteMyMeta {
	633	die "WriteMyMeta has been deprecated";
	634	}
	635
	636	sub write_mymeta_yaml {
	637	my $self = shift;
	638
	639	# We need YAML::Tiny to write the MYMETA.yml file
	640	unless ( eval { require YAML::Tiny; 1; } ) {
	641	return 1;
	642	}
	643
	644	# Generate the data
	645	my $meta = $self->_write_mymeta_data or return 1;
	646
	647	# Save as the MYMETA.yml file
	648	print "Writing MYMETA.yml\n";
	649	YAML::Tiny::DumpFile('MYMETA.yml', $meta);
	650	}
	651
	652	sub write_mymeta_json {
	653	my $self = shift;
	654
	655	# We need JSON to write the MYMETA.json file
	656	unless ( eval { require JSON; 1; } ) {
	657	return 1;
	658	}
	659
	660	# Generate the data
	661	my $meta = $self->_write_mymeta_data or return 1;
	662
	663	# Save as the MYMETA.yml file
	664	print "Writing MYMETA.json\n";
	665	Module::Install::_write(
	666	'MYMETA.json',
	667	JSON->new->pretty(1)->canonical->encode($meta),
	668	);
	669	}
	670
	671	sub _write_mymeta_data {
	672	my $self = shift;
	673
	674	# If there's no existing META.yml there is nothing we can do
	675	return undef unless -f 'META.yml';
	676
	677	# We need Parse::CPAN::Meta to load the file
	678	unless ( eval { require Parse::CPAN::Meta; 1; } ) {
	679	return undef;
	680	}
	681
	682	# Merge the perl version into the dependencies
	683	my $val = $self->Meta->{values};
	684	my $perl = delete $val->{perl_version};
	685	if ( $perl ) {
	686	$val->{requires} \|\|= [];
	687	my $requires = $val->{requires};
	688
	689	# Canonize to three-dot version after Perl 5.6
	690	if ( $perl >= 5.006 ) {
	691	$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2\|\|0), int($3\|\|0))}e
	692	}
	693	unshift @$requires, [ perl => $perl ];
	694	}
	695
	696	# Load the advisory META.yml file
	697	my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
	698	my $meta = $yaml[0];
	699
	700	# Overwrite the non-configure dependency hashs
	701	delete $meta->{requires};
	702	delete $meta->{build_requires};
	703	delete $meta->{recommends};
	704	if ( exists $val->{requires} ) {
	705	$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
	706	}
	707	if ( exists $val->{build_requires} ) {
	708	$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
	709	}
	710
	711	return $meta;
184	712	}
185	713
186	714	1;

+36

-0

inc/Module/Install/ReadmeFromPod.pm less more

	0	#line 1
	1	package Module::Install::ReadmeFromPod;
	2
	3	use strict;
	4	use warnings;
	5	use base qw(Module::Install::Base);
	6	use vars qw($VERSION);
	7
	8	$VERSION = '0.10';
	9
	10	sub readme_from {
	11	my $self = shift;
	12	return unless $Module::Install::AUTHOR;
	13	my $file = shift \|\| return;
	14	my $clean = shift;
	15	require Pod::Text;
	16	my $parser = Pod::Text->new();
	17	open README, '> README' or die "$!\n";
	18	$parser->output_fh( *README );
	19	$parser->parse_file( $file );
	20	return 1 unless $clean;
	21	$self->postamble(<<"END");
	22	distclean :: license_clean
	23
	24	license_clean:
	25	\t\$(RM_F) README
	26	END
	27	return 1;
	28	}
	29
	30	'Readme!';
	31
	32	__END__
	33
	34	#line 94
	35

+88

-0

inc/Module/Install/Repository.pm less more

	0	#line 1
	1	package Module::Install::Repository;
	2
	3	use strict;
	4	use 5.005;
	5	use vars qw($VERSION);
	6	$VERSION = '0.06';
	7
	8	use base qw(Module::Install::Base);
	9
	10	sub _execute {
	11	my ($command) = @_;
	12	`$command`;
	13	}
	14
	15	sub auto_set_repository {
	16	my $self = shift;
	17
	18	return unless $Module::Install::AUTHOR;
	19
	20	my $repo = _find_repo(\&_execute);
	21	if ($repo) {
	22	$self->repository($repo);
	23	} else {
	24	warn "Cannot determine repository URL\n";
	25	}
	26	}
	27
	28	sub _find_repo {
	29	my ($execute) = @_;
	30
	31	if (-e ".git") {
	32	# TODO support remote besides 'origin'?
	33	if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) {
	34	# XXX Make it public clone URL, but this only works with github
	35	my $git_url = $1;
	36	$git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
	37	return $git_url;
	38	} elsif ($execute->('git svn info') =~ /URL: (.*)$/m) {
	39	return $1;
	40	}
	41	} elsif (-e ".svn") {
	42	if (`svn info` =~ /URL: (.*)$/m) {
	43	return $1;
	44	}
	45	} elsif (-e "_darcs") {
	46	# defaultrepo is better, but that is more likely to be ssh, not http
	47	if (my $query_repo = `darcs query repo`) {
	48	if ($query_repo =~ m!Default Remote: (http://.+)!) {
	49	return $1;
	50	}
	51	}
	52
	53	open my $handle, '<', '_darcs/prefs/repos' or return;
	54	while (<$handle>) {
	55	chomp;
	56	return $_ if m!^http://!;
	57	}
	58	} elsif (-e ".hg") {
	59	if ($execute->('hg paths') =~ /default = (.*)$/m) {
	60	my $mercurial_url = $1;
	61	$mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!;
	62	return $mercurial_url;
	63	}
	64	} elsif (-e "$ENV{HOME}/.svk") {
	65	# Is there an explicit way to check if it's an svk checkout?
	66	my $svk_info = `svk info` or return;
	67	SVK_INFO: {
	68	if ($svk_info =~ /Mirrored From: (.*), Rev\./) {
	69	return $1;
	70	}
	71
	72	if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) {
	73	$svk_info = `svk info /$1` or return;
	74	redo SVK_INFO;
	75	}
	76	}
	77
	78	return;
	79	}
	80	}
	81
	82	1;
	83	__END__
	84
	85	=encoding utf-8
	86
	87	#line 128

+29

-0

inc/Module/Install/TestBase.pm less more

	0	#line 1
	1	package Module::Install::TestBase;
	2	use strict;
	3	use warnings;
	4
	5	use Module::Install::Base;
	6
	7	use vars qw($VERSION @ISA);
	8	BEGIN {
	9	$VERSION = '0.11';
	10	@ISA = 'Module::Install::Base';
	11	}
	12
	13	sub use_test_base {
	14	my $self = shift;
	15	$self->include('Test::Base');
	16	$self->include('Test::Base::Filter');
	17	$self->include('Spiffy');
	18	$self->include('Test::More');
	19	$self->include('Test::Builder');
	20	$self->include('Test::Builder::Module');
	21	$self->requires('Filter::Util::Call');
	22	}
	23
	24	1;
	25
	26	=encoding utf8
	27
	28	#line 70

+33

-32

inc/Module/Install/Win32.pm less more

0		#line 1 "inc/Module/Install/Win32.pm - /Library/Perl/5.8.1/Module/Install/Win32.pm"
	0	#line 1
1	1	package Module::Install::Win32;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
3
4		$VERSION = '0.02';
5	2
6	3	use strict;
	4	use Module::Install::Base ();
	5
	6	use vars qw{$VERSION @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = 'Module::Install::Base';
	10	$ISCORE = 1;
	11	}
7	12
8	13	# determine if the user needs nmake, and download it if needed
9	14	sub check_nmake {
10		my $self = shift;
11		$self->load('can_run');
12		$self->load('get_file');
	15	my $self = shift;
	16	$self->load('can_run');
	17	$self->load('get_file');
13	18
14		require Config;
15		return unless (
16		$Config::Config{make} and
17		$Config::Config{make} =~ /^nmake\b/i and
18		$^O eq 'MSWin32' and
19		!$self->can_run('nmake')
20		);
	19	require Config;
	20	return unless (
	21	$^O eq 'MSWin32' and
	22	$Config::Config{make} and
	23	$Config::Config{make} =~ /^nmake\b/i and
	24	! $self->can_run('nmake')
	25	);
21	26
22		print "The required 'nmake' executable not found, fetching it...\n";
	27	print "The required 'nmake' executable not found, fetching it...\n";
23	28
24		require File::Basename;
25		my $rv = $self->get_file(
26		url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
27		ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
28		local_dir => File::Basename::dirname($^X),
29		size => 51928,
30		run => 'Nmake15.exe /o > nul',
31		check_for => 'Nmake.exe',
32		remove => 1,
33		);
	29	require File::Basename;
	30	my $rv = $self->get_file(
	31	url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
	32	ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
	33	local_dir => File::Basename::dirname($^X),
	34	size => 51928,
	35	run => 'Nmake15.exe /o > nul',
	36	check_for => 'Nmake.exe',
	37	remove => 1,
	38	);
34	39
35		if (!$rv) {
36		die << '.';
	40	die <<'END_MESSAGE' unless $rv;
37	41
38	42	-------------------------------------------------------------------------------
39	43

52	56	You may then resume the installation process described in README.
53	57
54	58	-------------------------------------------------------------------------------
55		.
56		}
	59	END_MESSAGE
	60
57	61	}
58	62
59	63	1;
60
61		__END__
62

+53

-26

inc/Module/Install/WriteAll.pm less more

0		#line 1 "inc/Module/Install/WriteAll.pm - /Library/Perl/5.8.1/Module/Install/WriteAll.pm"
	0	#line 1
1	1	package Module::Install::WriteAll;
2		use Module::Install::Base; @ISA = qw(Module::Install::Base);
	2
	3	use strict;
	4	use Module::Install::Base ();
	5
	6	use vars qw{$VERSION @ISA $ISCORE};
	7	BEGIN {
	8	$VERSION = '1.00';
	9	@ISA = qw{Module::Install::Base};
	10	$ISCORE = 1;
	11	}
3	12
4	13	sub WriteAll {
5		my $self = shift;
6		my %args = (
7		meta => 1,
8		sign => 0,
9		inline => 0,
10		check_nmake => 1,
11		@_
12		);
	14	my $self = shift;
	15	my %args = (
	16	meta => 1,
	17	sign => 0,
	18	inline => 0,
	19	check_nmake => 1,
	20	@_,
	21	);
13	22
14		$self->sign(1) if $args{sign};
15		$self->Meta->write if $args{meta};
16		$self->admin->WriteAll(%args) if $self->is_admin;
	23	$self->sign(1) if $args{sign};
	24	$self->admin->WriteAll(%args) if $self->is_admin;
17	25
18		if ($0 =~ /Build.PL$/i) {
19		$self->Build->write;
20		}
21		else {
22	26	$self->check_nmake if $args{check_nmake};
23		$self->makemaker_args( PL_FILES => {} )
24		unless $self->makemaker_args->{'PL_FILES'};
	27	unless ( $self->makemaker_args->{PL_FILES} ) {
	28	# XXX: This still may be a bit over-defensive...
	29	unless ($self->makemaker(6.25)) {
	30	$self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
	31	}
	32	}
25	33
26		if ($args{inline}) {
27		$self->Inline->write;
28		}
29		else {
30		$self->Makefile->write;
31		}
32		}
	34	# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
	35	# we clean it up properly ourself.
	36	$self->realclean_files('MYMETA.yml');
	37
	38	if ( $args{inline} ) {
	39	$self->Inline->write;
	40	} else {
	41	$self->Makefile->write;
	42	}
	43
	44	# The Makefile write process adds a couple of dependencies,
	45	# so write the META.yml files after the Makefile.
	46	if ( $args{meta} ) {
	47	$self->Meta->write;
	48	}
	49
	50	# Experimental support for MYMETA
	51	if ( $ENV{X_MYMETA} ) {
	52	if ( $ENV{X_MYMETA} eq 'JSON' ) {
	53	$self->Meta->write_mymeta_json;
	54	} else {
	55	$self->Meta->write_mymeta_yaml;
	56	}
	57	}
	58
	59	return 1;
33	60	}
34	61
35	62	1;

+445

-144

inc/Module/Install.pm less more

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

+539

-0

inc/Spiffy.pm less more

	0	#line 1
	1	package Spiffy;
	2	use strict;
	3	use 5.006001;
	4	use warnings;
	5	use Carp;
	6	require Exporter;
	7	our $VERSION = '0.30';
	8	our @EXPORT = ();
	9	our @EXPORT_BASE = qw(field const stub super);
	10	our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
	11	our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
	12
	13	my $stack_frame = 0;
	14	my $dump = 'yaml';
	15	my $bases_map = {};
	16
	17	sub WWW; sub XXX; sub YYY; sub ZZZ;
	18
	19	# This line is here to convince "autouse" into believing we are autousable.
	20	sub can {
	21	($_[1] eq 'import' and caller()->isa('autouse'))
	22	? \&Exporter::import # pacify autouse's equality test
	23	: $_[0]->SUPER::can($_[1]) # normal case
	24	}
	25
	26	# TODO
	27	#
	28	# Exported functions like field and super should be hidden so as not to
	29	# be confused with methods that can be inherited.
	30	#
	31
	32	sub new {
	33	my $class = shift;
	34	$class = ref($class) \|\| $class;
	35	my $self = bless {}, $class;
	36	while (@_) {
	37	my $method = shift;
	38	$self->$method(shift);
	39	}
	40	return $self;
	41	}
	42
	43	my $filtered_files = {};
	44	my $filter_dump = 0;
	45	my $filter_save = 0;
	46	our $filter_result = '';
	47	sub import {
	48	no strict 'refs';
	49	no warnings;
	50	my $self_package = shift;
	51
	52	# XXX Using parse_arguments here might cause confusion, because the
	53	# subclass's boolean_arguments and paired_arguments can conflict, causing
	54	# difficult debugging. Consider using something truly local.
	55	my ($args, @export_list) = do {
	56	local *boolean_arguments = sub {
	57	qw(
	58	-base -Base -mixin -selfless
	59	-XXX -dumper -yaml
	60	-filter_dump -filter_save
	61	)
	62	};
	63	local *paired_arguments = sub { qw(-package) };
	64	$self_package->parse_arguments(@_);
	65	};
	66	return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
	67	if $args->{-mixin};
	68
	69	$filter_dump = 1 if $args->{-filter_dump};
	70	$filter_save = 1 if $args->{-filter_save};
	71	$dump = 'yaml' if $args->{-yaml};
	72	$dump = 'dumper' if $args->{-dumper};
	73
	74	local @EXPORT_BASE = @EXPORT_BASE;
	75
	76	if ($args->{-XXX}) {
	77	push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
	78	unless grep /^XXX$/, @EXPORT_BASE;
	79	}
	80
	81	spiffy_filter()
	82	if ($args->{-selfless} or $args->{-Base}) and
	83	not $filtered_files->{(caller($stack_frame))[1]}++;
	84
	85	my $caller_package = $args->{-package} \|\| caller($stack_frame);
	86	push @{"$caller_package\::ISA"}, $self_package
	87	if $args->{-Base} or $args->{-base};
	88
	89	for my $class (@{all_my_bases($self_package)}) {
	90	next unless $class->isa('Spiffy');
	91	my @export = grep {
	92	not defined &{"$caller_package\::$_"};
	93	} ( @{"$class\::EXPORT"},
	94	($args->{-Base} or $args->{-base})
	95	? @{"$class\::EXPORT_BASE"} : (),
	96	);
	97	my @export_ok = grep {
	98	not defined &{"$caller_package\::$_"};
	99	} @{"$class\::EXPORT_OK"};
	100
	101	# Avoid calling the expensive Exporter::export
	102	# if there is nothing to do (optimization)
	103	my %exportable = map { ($_, 1) } @export, @export_ok;
	104	next unless keys %exportable;
	105
	106	my @export_save = @{"$class\::EXPORT"};
	107	my @export_ok_save = @{"$class\::EXPORT_OK"};
	108	@{"$class\::EXPORT"} = @export;
	109	@{"$class\::EXPORT_OK"} = @export_ok;
	110	my @list = grep {
	111	(my $v = $_) =~ s/^[\!\:]//;
	112	$exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
	113	} @export_list;
	114	Exporter::export($class, $caller_package, @list);
	115	@{"$class\::EXPORT"} = @export_save;
	116	@{"$class\::EXPORT_OK"} = @export_ok_save;
	117	}
	118	}
	119
	120	sub spiffy_filter {
	121	require Filter::Util::Call;
	122	my $done = 0;
	123	Filter::Util::Call::filter_add(
	124	sub {
	125	return 0 if $done;
	126	my ($data, $end) = ('', '');
	127	while (my $status = Filter::Util::Call::filter_read()) {
	128	return $status if $status < 0;
	129	if (/^__(?:END\|DATA)__\r?$/) {
	130	$end = $_;
	131	last;
	132	}
	133	$data .= $_;
	134	$_ = '';
	135	}
	136	$_ = $data;
	137	my @my_subs;
	138	s[^(sub\s+\w+\s+\{)(.*\n)]
	139	[${1}my \$self = shift;$2]gm;
	140	s[^(sub\s+\w+)\s$\s$(\s+\{.*\n)]
	141	[${1}${2}]gm;
	142	s[^my\s+sub\s+(\w+)(\s+\{)(.)((?s:.?\n))\}\n]
	143	[push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
	144	my $preclare = '';
	145	if (@my_subs) {
	146	$preclare = join ',', map "\$$_", @my_subs;
	147	$preclare = "my($preclare);";
	148	}
	149	$_ = "use strict;use warnings;$preclare${_};1;\n$end";
	150	if ($filter_dump) { print; exit }
	151	if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
	152	$done = 1;
	153	}
	154	);
	155	}
	156
	157	sub base {
	158	push @_, -base;
	159	goto &import;
	160	}
	161
	162	sub all_my_bases {
	163	my $class = shift;
	164
	165	return $bases_map->{$class}
	166	if defined $bases_map->{$class};
	167
	168	my @bases = ($class);
	169	no strict 'refs';
	170	for my $base_class (@{"${class}::ISA"}) {
	171	push @bases, @{all_my_bases($base_class)};
	172	}
	173	my $used = {};
	174	$bases_map->{$class} = [grep {not $used->{$_}++} @bases];
	175	}
	176
	177	my %code = (
	178	sub_start =>
	179	"sub {\n",
	180	set_default =>
	181	" \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
	182	init =>
	183	" return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
	184	" unless \$#_ > 0 or defined \$_[0]->{%s};\n",
	185	weak_init =>
	186	" return do {\n" .
	187	" \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
	188	" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
	189	" \$_[0]->{%s};\n" .
	190	" } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
	191	return_if_get =>
	192	" return \$_[0]->{%s} unless \$#_ > 0;\n",
	193	set =>
	194	" \$_[0]->{%s} = \$_[1];\n",
	195	weaken =>
	196	" Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
	197	sub_end =>
	198	" return \$_[0]->{%s};\n}\n",
	199	);
	200
	201	sub field {
	202	my $package = caller;
	203	my ($args, @values) = do {
	204	no warnings;
	205	local *boolean_arguments = sub { (qw(-weak)) };
	206	local *paired_arguments = sub { (qw(-package -init)) };
	207	Spiffy->parse_arguments(@_);
	208	};
	209	my ($field, $default) = @values;
	210	$package = $args->{-package} if defined $args->{-package};
	211	die "Cannot have a default for a weakened field ($field)"
	212	if defined $default && $args->{-weak};
	213	return if defined &{"${package}::$field"};
	214	require Scalar::Util if $args->{-weak};
	215	my $default_string =
	216	( ref($default) eq 'ARRAY' and not @$default )
	217	? '[]'
	218	: (ref($default) eq 'HASH' and not keys %$default )
	219	? '{}'
	220	: default_as_code($default);
	221
	222	my $code = $code{sub_start};
	223	if ($args->{-init}) {
	224	my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
	225	$code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
	226	}
	227	$code .= sprintf $code{set_default}, $field, $default_string, $field
	228	if defined $default;
	229	$code .= sprintf $code{return_if_get}, $field;
	230	$code .= sprintf $code{set}, $field;
	231	$code .= sprintf $code{weaken}, $field, $field
	232	if $args->{-weak};
	233	$code .= sprintf $code{sub_end}, $field;
	234
	235	my $sub = eval $code;
	236	die $@ if $@;
	237	no strict 'refs';
	238	*{"${package}::$field"} = $sub;
	239	return $code if defined wantarray;
	240	}
	241
	242	sub default_as_code {
	243	require Data::Dumper;
	244	local $Data::Dumper::Sortkeys = 1;
	245	my $code = Data::Dumper::Dumper(shift);
	246	$code =~ s/^\$VAR1 = //;
	247	$code =~ s/;$//;
	248	return $code;
	249	}
	250
	251	sub const {
	252	my $package = caller;
	253	my ($args, @values) = do {
	254	no warnings;
	255	local *paired_arguments = sub { (qw(-package)) };
	256	Spiffy->parse_arguments(@_);
	257	};
	258	my ($field, $default) = @values;
	259	$package = $args->{-package} if defined $args->{-package};
	260	no strict 'refs';
	261	return if defined &{"${package}::$field"};
	262	*{"${package}::$field"} = sub { $default }
	263	}
	264
	265	sub stub {
	266	my $package = caller;
	267	my ($args, @values) = do {
	268	no warnings;
	269	local *paired_arguments = sub { (qw(-package)) };
	270	Spiffy->parse_arguments(@_);
	271	};
	272	my ($field, $default) = @values;
	273	$package = $args->{-package} if defined $args->{-package};
	274	no strict 'refs';
	275	return if defined &{"${package}::$field"};
	276	*{"${package}::$field"} =
	277	sub {
	278	require Carp;
	279	Carp::confess
	280	"Method $field in package $package must be subclassed";
	281	}
	282	}
	283
	284	sub parse_arguments {
	285	my $class = shift;
	286	my ($args, @values) = ({}, ());
	287	my %booleans = map { ($_, 1) } $class->boolean_arguments;
	288	my %pairs = map { ($_, 1) } $class->paired_arguments;
	289	while (@_) {
	290	my $elem = shift;
	291	if (defined $elem and defined $booleans{$elem}) {
	292	$args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
	293	? shift
	294	: 1;
	295	}
	296	elsif (defined $elem and defined $pairs{$elem} and @_) {
	297	$args->{$elem} = shift;
	298	}
	299	else {
	300	push @values, $elem;
	301	}
	302	}
	303	return wantarray ? ($args, @values) : $args;
	304	}
	305
	306	sub boolean_arguments { () }
	307	sub paired_arguments { () }
	308
	309	# get a unique id for any node
	310	sub id {
	311	if (not ref $_[0]) {
	312	return 'undef' if not defined $_[0];
	313	\$_[0] =~ /$(\w+)$$/o or die;
	314	return "$1-S";
	315	}
	316	require overload;
	317	overload::StrVal($_[0]) =~ /$(\w+)$$/o or die;
	318	return $1;
	319	}
	320
	321	#===============================================================================
	322	# It's super, man.
	323	#===============================================================================
	324	package DB;
	325	{
	326	no warnings 'redefine';
	327	sub super_args {
	328	my @dummy = caller(@_ ? $_[0] : 2);
	329	return @DB::args;
	330	}
	331	}
	332
	333	package Spiffy;
	334	sub super {
	335	my $method;
	336	my $frame = 1;
	337	while ($method = (caller($frame++))[3]) {
	338	$method =~ s/.*::// and last;
	339	}
	340	my @args = DB::super_args($frame);
	341	@_ = @_ ? ($args[0], @_) : @args;
	342	my $class = ref $_[0] ? ref $_[0] : $_[0];
	343	my $caller_class = caller;
	344	my $seen = 0;
	345	my @super_classes = reverse grep {
	346	($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
	347	} reverse @{all_my_bases($class)};
	348	for my $super_class (@super_classes) {
	349	no strict 'refs';
	350	next if $super_class eq $class;
	351	if (defined &{"${super_class}::$method"}) {
	352	${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
	353	if $method eq 'AUTOLOAD';
	354	return &{"${super_class}::$method"};
	355	}
	356	}
	357	return;
	358	}
	359
	360	#===============================================================================
	361	# This code deserves a spanking, because it is being very naughty.
	362	# It is exchanging base.pm's import() for its own, so that people
	363	# can use base.pm with Spiffy modules, without being the wiser.
	364	#===============================================================================
	365	my $real_base_import;
	366	my $real_mixin_import;
	367
	368	BEGIN {
	369	require base unless defined $INC{'base.pm'};
	370	$INC{'mixin.pm'} \|\|= 'Spiffy/mixin.pm';
	371	$real_base_import = \&base::import;
	372	$real_mixin_import = \&mixin::import;
	373	no warnings;
	374	*base::import = \&spiffy_base_import;
	375	*mixin::import = \&spiffy_mixin_import;
	376	}
	377
	378	# my $i = 0;
	379	# while (my $caller = caller($i++)) {
	380	# next unless $caller eq 'base' or $caller eq 'mixin';
	381	# croak <<END;
	382	# Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a
	383	# Spiffy module. See the documentation of Spiffy.pm for details.
	384	# END
	385	# }
	386
	387	sub spiffy_base_import {
	388	my @base_classes = @_;
	389	shift @base_classes;
	390	no strict 'refs';
	391	goto &$real_base_import
	392	unless grep {
	393	eval "require $_" unless %{"$_\::"};
	394	$_->isa('Spiffy');
	395	} @base_classes;
	396	my $inheritor = caller(0);
	397	for my $base_class (@base_classes) {
	398	next if $inheritor->isa($base_class);
	399	croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
	400	"See the documentation of Spiffy.pm for details\n "
	401	unless $base_class->isa('Spiffy');
	402	$stack_frame = 1; # tell import to use different caller
	403	import($base_class, '-base');
	404	$stack_frame = 0;
	405	}
	406	}
	407
	408	sub mixin {
	409	my $self = shift;
	410	my $target_class = ref($self);
	411	spiffy_mixin_import($target_class, @_)
	412	}
	413
	414	sub spiffy_mixin_import {
	415	my $target_class = shift;
	416	$target_class = caller(0)
	417	if $target_class eq 'mixin';
	418	my $mixin_class = shift
	419	or die "Nothing to mixin";
	420	eval "require $mixin_class";
	421	my @roles = @_;
	422	my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
	423	my %methods = spiffy_mixin_methods($mixin_class, @roles);
	424	no strict 'refs';
	425	no warnings;
	426	@{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
	427	@{"$target_class\::ISA"} = ($pseudo_class);
	428	for (keys %methods) {
	429	*{"$pseudo_class\::$_"} = $methods{$_};
	430	}
	431	}
	432
	433	sub spiffy_mixin_methods {
	434	my $mixin_class = shift;
	435	no strict 'refs';
	436	my %methods = spiffy_all_methods($mixin_class);
	437	map {
	438	$methods{$_}
	439	? ($_, \ &{"$methods{$_}\::$_"})
	440	: ($_, \ &{"$mixin_class\::$_"})
	441	} @_
	442	? (get_roles($mixin_class, @_))
	443	: (keys %methods);
	444	}
	445
	446	sub get_roles {
	447	my $mixin_class = shift;
	448	my @roles = @_;
	449	while (grep /^!*:/, @roles) {
	450	@roles = map {
	451	s/!!//g;
	452	/^!:(.*)/ ? do {
	453	my $m = "_role_$1";
	454	map("!$_", $mixin_class->$m);
	455	} :
	456	/^:(.*)/ ? do {
	457	my $m = "_role_$1";
	458	($mixin_class->$m);
	459	} :
	460	($_)
	461	} @roles;
	462	}
	463	if (@roles and $roles[0] =~ /^!/) {
	464	my %methods = spiffy_all_methods($mixin_class);
	465	unshift @roles, keys(%methods);
	466	}
	467	my %roles;
	468	for (@roles) {
	469	s/!!//g;
	470	delete $roles{$1}, next
	471	if /^!(.*)/;
	472	$roles{$_} = 1;
	473	}
	474	keys %roles;
	475	}
	476
	477	sub spiffy_all_methods {
	478	no strict 'refs';
	479	my $class = shift;
	480	return if $class eq 'Spiffy';
	481	my %methods = map {
	482	($_, $class)
	483	} grep {
	484	defined &{"$class\::$_"} and not /^_/
	485	} keys %{"$class\::"};
	486	my %super_methods;
	487	%super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
	488	if @{"$class\::ISA"};
	489	%{{%super_methods, %methods}};
	490	}
	491
	492
	493	# END of naughty code.
	494	#===============================================================================
	495	# Debugging support
	496	#===============================================================================
	497	sub spiffy_dump {
	498	no warnings;
	499	if ($dump eq 'dumper') {
	500	require Data::Dumper;
	501	$Data::Dumper::Sortkeys = 1;
	502	$Data::Dumper::Indent = 1;
	503	return Data::Dumper::Dumper(@_);
	504	}
	505	require YAML;
	506	$YAML::UseVersion = 0;
	507	return YAML::Dump(@_) . "...\n";
	508	}
	509
	510	sub at_line_number {
	511	my ($file_path, $line_number) = (caller(1))[1,2];
	512	" at $file_path line $line_number\n";
	513	}
	514
	515	sub WWW {
	516	warn spiffy_dump(@_) . at_line_number;
	517	return wantarray ? @_ : $_[0];
	518	}
	519
	520	sub XXX {
	521	die spiffy_dump(@_) . at_line_number;
	522	}
	523
	524	sub YYY {
	525	print spiffy_dump(@_) . at_line_number;
	526	return wantarray ? @_ : $_[0];
	527	}
	528
	529	sub ZZZ {
	530	require Carp;
	531	Carp::confess spiffy_dump(@_);
	532	}
	533
	534	1;
	535
	536	__END__
	537
	538	#line 1066

+148

-0

inc/Sub/Uplevel.pm less more

	0	#line 1
	1	package Sub::Uplevel;
	2
	3	use 5.006;
	4	use strict;
	5	our $VERSION = '0.2002';
	6	$VERSION = eval $VERSION;
	7
	8	sub import {
	9	no strict 'refs';
	10	my ($class, @args) = @_;
	11	for my $fcn ( @args ) {
	12	if ( $fcn ne 'uplevel' ) {
	13	die qq{"$fcn" is not exported by the $class module\n}
	14	}
	15	}
	16	my $caller = caller(0);
	17	*{"$caller\::uplevel"} = \&uplevel;
	18	return;
	19	}
	20
	21	# We must override *CORE::GLOBAL::caller if it hasn't already been
	22	# overridden or else Perl won't see our local override later.
	23
	24	if ( not defined *CORE::GLOBAL::caller{CODE} ) {
	25	*CORE::GLOBAL::caller = \&_normal_caller;
	26	}
	27
	28
	29	#line 96
	30
	31	# @Up_Frames -- uplevel stack
	32	# $Caller_Proxy -- whatever caller() override was in effect before uplevel
	33	our (@Up_Frames, $Caller_Proxy);
	34
	35	sub _apparent_stack_height {
	36	my $height = 1; # start above this function
	37	while ( 1 ) {
	38	last if ! defined scalar $Caller_Proxy->($height);
	39	$height++;
	40	}
	41	return $height - 1; # subtract 1 for this function
	42	}
	43
	44	sub uplevel {
	45	my($num_frames, $func, @args) = @_;
	46
	47	# backwards compatible version of "no warnings 'redefine'"
	48	my $old_W = $^W;
	49	$^W = 0;
	50
	51	# Update the caller proxy if the uplevel override isn't in effect
	52	local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
	53	if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
	54	local *CORE::GLOBAL::caller = \&_uplevel_caller;
	55
	56	# restore old warnings state
	57	$^W = $old_W;
	58
	59	if ( $num_frames >= _apparent_stack_height() ) {
	60	require Carp;
	61	Carp::carp("uplevel $num_frames is more than the caller stack");
	62	}
	63
	64	local @Up_Frames = ($num_frames, @Up_Frames );
	65
	66	return $func->(@args);
	67	}
	68
	69	sub _normal_caller (;$) { ## no critic Prototypes
	70	my $height = $_[0];
	71	$height++;
	72	if ( CORE::caller() eq 'DB' ) {
	73	# passthrough the @DB::args trick
	74	package DB;
	75	if( wantarray and !@_ ) {
	76	return (CORE::caller($height))[0..2];
	77	}
	78	else {
	79	return CORE::caller($height);
	80	}
	81	}
	82	else {
	83	if( wantarray and !@_ ) {
	84	return (CORE::caller($height))[0..2];
	85	}
	86	else {
	87	return CORE::caller($height);
	88	}
	89	}
	90	}
	91
	92	sub _uplevel_caller (;$) { ## no critic Prototypes
	93	my $height = $_[0] \|\| 0;
	94
	95	# shortcut if no uplevels have been called
	96	# always add +1 to CORE::caller (proxy caller function)
	97	# to skip this function's caller
	98	return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
	99
	100	#line 215
	101
	102	my $saw_uplevel = 0;
	103	my $adjust = 0;
	104
	105	# walk up the call stack to fight the right package level to return;
	106	# look one higher than requested for each call to uplevel found
	107	# and adjust by the amount found in the Up_Frames stack for that call.
	108	# We must use CORE::caller here since we need the real stack not what
	109	# some other override says the stack looks like, just in case that other
	110	# override breaks things in some horrible way
	111
	112	for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
	113	my @caller = CORE::caller($up + 1);
	114	if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
	115	# add one for each uplevel call seen
	116	# and look into the uplevel stack for the offset
	117	$adjust += 1 + $Up_Frames[$saw_uplevel];
	118	$saw_uplevel++;
	119	}
	120	}
	121
	122	# For returning values, we pass through the call to the proxy caller
	123	# function, just at a higher stack level
	124	my @caller;
	125	if ( CORE::caller() eq 'DB' ) {
	126	# passthrough the @DB::args trick
	127	package DB;
	128	@caller = $Sub::Uplevel::Caller_Proxy->($height + $adjust + 1);
	129	}
	130	else {
	131	@caller = $Caller_Proxy->($height + $adjust + 1);
	132	}
	133
	134	if( wantarray ) {
	135	if( !@_ ) {
	136	@caller = @caller[0..2];
	137	}
	138	return @caller;
	139	}
	140	else {
	141	return $caller[0];
	142	}
	143	}
	144
	145	#line 327
	146
	147	1;

+344

-0

inc/Test/Base/Filter.pm less more

	0	#line 1
	1	#. TODO:
	2	#.
	3
	4	#===============================================================================
	5	# This is the default class for handling Test::Base data filtering.
	6	#===============================================================================
	7	package Test::Base::Filter;
	8	use Spiffy -Base;
	9	use Spiffy ':XXX';
	10
	11	field 'current_block';
	12
	13	our $arguments;
	14	sub current_arguments {
	15	return undef unless defined $arguments;
	16	my $args = $arguments;
	17	$args =~ s/(\\s)/ /g;
	18	$args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
	19	return $args;
	20	}
	21
	22	sub assert_scalar {
	23	return if @_ == 1;
	24	require Carp;
	25	my $filter = (caller(1))[3];
	26	$filter =~ s/.*:://;
	27	Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
	28	}
	29
	30	sub _apply_deepest {
	31	my $method = shift;
	32	return () unless @_;
	33	if (ref $_[0] eq 'ARRAY') {
	34	for my $aref (@_) {
	35	@$aref = $self->_apply_deepest($method, @$aref);
	36	}
	37	return @_;
	38	}
	39	$self->$method(@_);
	40	}
	41
	42	sub _split_array {
	43	map {
	44	[$self->split($_)];
	45	} @_;
	46	}
	47
	48	sub _peel_deepest {
	49	return () unless @_;
	50	if (ref $_[0] eq 'ARRAY') {
	51	if (ref $_[0]->[0] eq 'ARRAY') {
	52	for my $aref (@_) {
	53	@$aref = $self->_peel_deepest(@$aref);
	54	}
	55	return @_;
	56	}
	57	return map { $_->[0] } @_;
	58	}
	59	return @_;
	60	}
	61
	62	#===============================================================================
	63	# these filters work on the leaves of nested arrays
	64	#===============================================================================
	65	sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
	66	sub Reverse { $self->_apply_deepest(reverse => @_) }
	67	sub Split { $self->_apply_deepest(_split_array => @_) }
	68	sub Sort { $self->_apply_deepest(sort => @_) }
	69
	70
	71	sub append {
	72	my $suffix = $self->current_arguments;
	73	map { $_ . $suffix } @_;
	74	}
	75
	76	sub array {
	77	return [@_];
	78	}
	79
	80	sub base64_decode {
	81	$self->assert_scalar(@_);
	82	require MIME::Base64;
	83	MIME::Base64::decode_base64(shift);
	84	}
	85
	86	sub base64_encode {
	87	$self->assert_scalar(@_);
	88	require MIME::Base64;
	89	MIME::Base64::encode_base64(shift);
	90	}
	91
	92	sub chomp {
	93	map { CORE::chomp; $_ } @_;
	94	}
	95
	96	sub chop {
	97	map { CORE::chop; $_ } @_;
	98	}
	99
	100	sub dumper {
	101	no warnings 'once';
	102	require Data::Dumper;
	103	local $Data::Dumper::Sortkeys = 1;
	104	local $Data::Dumper::Indent = 1;
	105	local $Data::Dumper::Terse = 1;
	106	Data::Dumper::Dumper(@_);
	107	}
	108
	109	sub escape {
	110	$self->assert_scalar(@_);
	111	my $text = shift;
	112	$text =~ s/(\\.)/eval "qq{$1}"/ge;
	113	return $text;
	114	}
	115
	116	sub eval {
	117	$self->assert_scalar(@_);
	118	my @return = CORE::eval(shift);
	119	return $@ if $@;
	120	return @return;
	121	}
	122
	123	sub eval_all {
	124	$self->assert_scalar(@_);
	125	my $out = '';
	126	my $err = '';
	127	Test::Base::tie_output(*STDOUT, $out);
	128	Test::Base::tie_output(*STDERR, $err);
	129	my $return = CORE::eval(shift);
	130	no warnings;
	131	untie *STDOUT;
	132	untie *STDERR;
	133	return $return, $@, $out, $err;
	134	}
	135
	136	sub eval_stderr {
	137	$self->assert_scalar(@_);
	138	my $output = '';
	139	Test::Base::tie_output(*STDERR, $output);
	140	CORE::eval(shift);
	141	no warnings;
	142	untie *STDERR;
	143	return $output;
	144	}
	145
	146	sub eval_stdout {
	147	$self->assert_scalar(@_);
	148	my $output = '';
	149	Test::Base::tie_output(*STDOUT, $output);
	150	CORE::eval(shift);
	151	no warnings;
	152	untie *STDOUT;
	153	return $output;
	154	}
	155
	156	sub exec_perl_stdout {
	157	my $tmpfile = "/tmp/test-blocks-$$";
	158	$self->_write_to($tmpfile, @_);
	159	open my $execution, "$^X $tmpfile 2>&1 \|"
	160	or die "Couldn't open subprocess: $!\n";
	161	local $/;
	162	my $output = <$execution>;
	163	close $execution;
	164	unlink($tmpfile)
	165	or die "Couldn't unlink $tmpfile: $!\n";
	166	return $output;
	167	}
	168
	169	sub flatten {
	170	$self->assert_scalar(@_);
	171	my $ref = shift;
	172	if (ref($ref) eq 'HASH') {
	173	return map {
	174	($_, $ref->{$_});
	175	} sort keys %$ref;
	176	}
	177	if (ref($ref) eq 'ARRAY') {
	178	return @$ref;
	179	}
	180	die "Can only flatten a hash or array ref";
	181	}
	182
	183	sub get_url {
	184	$self->assert_scalar(@_);
	185	my $url = shift;
	186	CORE::chomp($url);
	187	require LWP::Simple;
	188	LWP::Simple::get($url);
	189	}
	190
	191	sub hash {
	192	return +{ @_ };
	193	}
	194
	195	sub head {
	196	my $size = $self->current_arguments \|\| 1;
	197	return splice(@_, 0, $size);
	198	}
	199
	200	sub join {
	201	my $string = $self->current_arguments;
	202	$string = '' unless defined $string;
	203	CORE::join $string, @_;
	204	}
	205
	206	sub lines {
	207	$self->assert_scalar(@_);
	208	my $text = shift;
	209	return () unless length $text;
	210	my @lines = ($text =~ /^(.*\n?)/gm);
	211	return @lines;
	212	}
	213
	214	sub norm {
	215	$self->assert_scalar(@_);
	216	my $text = shift;
	217	$text = '' unless defined $text;
	218	$text =~ s/\015\012/\n/g;
	219	$text =~ s/\r/\n/g;
	220	return $text;
	221	}
	222
	223	sub prepend {
	224	my $prefix = $self->current_arguments;
	225	map { $prefix . $_ } @_;
	226	}
	227
	228	sub read_file {
	229	$self->assert_scalar(@_);
	230	my $file = shift;
	231	CORE::chomp $file;
	232	open my $fh, $file
	233	or die "Can't open '$file' for input:\n$!";
	234	CORE::join '', <$fh>;
	235	}
	236
	237	sub regexp {
	238	$self->assert_scalar(@_);
	239	my $text = shift;
	240	my $flags = $self->current_arguments;
	241	if ($text =~ /\n.*?\n/s) {
	242	$flags = 'xism'
	243	unless defined $flags;
	244	}
	245	else {
	246	CORE::chomp($text);
	247	}
	248	$flags \|\|= '';
	249	my $regexp = eval "qr{$text}$flags";
	250	die $@ if $@;
	251	return $regexp;
	252	}
	253
	254	sub reverse {
	255	CORE::reverse(@_);
	256	}
	257
	258	sub slice {
	259	die "Invalid args for slice"
	260	unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
	261	my ($x, $y) = ($1, $2);
	262	$y = $x if not defined $y;
	263	die "Invalid args for slice"
	264	if $x > $y;
	265	return splice(@_, $x, 1 + $y - $x);
	266	}
	267
	268	sub sort {
	269	CORE::sort(@_);
	270	}
	271
	272	sub split {
	273	$self->assert_scalar(@_);
	274	my $separator = $self->current_arguments;
	275	if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
	276	my $regexp = $1;
	277	$separator = qr{$regexp};
	278	}
	279	$separator = qr/\s+/ unless $separator;
	280	CORE::split $separator, shift;
	281	}
	282
	283	sub strict {
	284	$self->assert_scalar(@_);
	285	<<'...' . shift;
	286	use strict;
	287	use warnings;
	288	...
	289	}
	290
	291	sub tail {
	292	my $size = $self->current_arguments \|\| 1;
	293	return splice(@_, @_ - $size, $size);
	294	}
	295
	296	sub trim {
	297	map {
	298	s/\A([ \t]*\n)+//;
	299	s/(?<=\n)\s*\z//g;
	300	$_;
	301	} @_;
	302	}
	303
	304	sub unchomp {
	305	map { $_ . "\n" } @_;
	306	}
	307
	308	sub write_file {
	309	my $file = $self->current_arguments
	310	or die "No file specified for write_file filter";
	311	if ($file =~ /(.*)[\\\/]/) {
	312	my $dir = $1;
	313	if (not -e $dir) {
	314	require File::Path;
	315	File::Path::mkpath($dir)
	316	or die "Can't create $dir";
	317	}
	318	}
	319	open my $fh, ">$file"
	320	or die "Can't open '$file' for output\n:$!";
	321	print $fh @_;
	322	close $fh;
	323	return $file;
	324	}
	325
	326	sub yaml {
	327	$self->assert_scalar(@_);
	328	require YAML;
	329	return YAML::Load(shift);
	330	}
	331
	332	sub _write_to {
	333	my $filename = shift;
	334	open my $script, ">$filename"
	335	or die "Couldn't open $filename: $!\n";
	336	print $script @_;
	337	close $script
	338	or die "Couldn't close $filename: $!\n";
	339	}
	340
	341	__DATA__
	342
	343	#line 639

+684

-0

inc/Test/Base.pm less more

	0	#line 1
	1	# TODO:
	2	#
	3	package Test::Base;
	4	use 5.006001;
	5	use Spiffy 0.30 -Base;
	6	use Spiffy ':XXX';
	7	our $VERSION = '0.59';
	8
	9	my @test_more_exports;
	10	BEGIN {
	11	@test_more_exports = qw(
	12	ok isnt like unlike is_deeply cmp_ok
	13	skip todo_skip pass fail
	14	eq_array eq_hash eq_set
	15	plan can_ok isa_ok diag
	16	use_ok
	17	$TODO
	18	);
	19	}
	20
	21	use Test::More import => \@test_more_exports;
	22	use Carp;
	23
	24	our @EXPORT = (@test_more_exports, qw(
	25	is no_diff
	26
	27	blocks next_block first_block
	28	delimiters spec_file spec_string
	29	filters filters_delay filter_arguments
	30	run run_compare run_is run_is_deeply run_like run_unlike
	31	skip_all_unless_require is_deep run_is_deep
	32	WWW XXX YYY ZZZ
	33	tie_output no_diag_on_only
	34
	35	find_my_self default_object
	36
	37	croak carp cluck confess
	38	));
	39
	40	field '_spec_file';
	41	field '_spec_string';
	42	field _filters => [qw(norm trim)];
	43	field _filters_map => {};
	44	field spec =>
	45	-init => '$self->_spec_init';
	46	field block_list =>
	47	-init => '$self->_block_list_init';
	48	field _next_list => [];
	49	field block_delim =>
	50	-init => '$self->block_delim_default';
	51	field data_delim =>
	52	-init => '$self->data_delim_default';
	53	field _filters_delay => 0;
	54	field _no_diag_on_only => 0;
	55
	56	field block_delim_default => '===';
	57	field data_delim_default => '---';
	58
	59	my $default_class;
	60	my $default_object;
	61	my $reserved_section_names = {};
	62
	63	sub default_object {
	64	$default_object \|\|= $default_class->new;
	65	return $default_object;
	66	}
	67
	68	my $import_called = 0;
	69	sub import() {
	70	$import_called = 1;
	71	my $class = (grep /^-base$/i, @_)
	72	? scalar(caller)
	73	: $_[0];
	74	if (not defined $default_class) {
	75	$default_class = $class;
	76	}
	77	# else {
	78	# croak "Can't use $class after using $default_class"
	79	# unless $default_class->isa($class);
	80	# }
	81
	82	unless (grep /^-base$/i, @_) {
	83	my @args;
	84	for (my $ii = 1; $ii <= $#_; ++$ii) {
	85	if ($_[$ii] eq '-package') {
	86	++$ii;
	87	} else {
	88	push @args, $_[$ii];
	89	}
	90	}
	91	Test::More->import(import => \@test_more_exports, @args)
	92	if @args;
	93	}
	94
	95	_strict_warnings();
	96	goto &Spiffy::import;
	97	}
	98
	99	# Wrap Test::Builder::plan
	100	my $plan_code = \&Test::Builder::plan;
	101	my $Have_Plan = 0;
	102	{
	103	no warnings 'redefine';
	104	*Test::Builder::plan = sub {
	105	$Have_Plan = 1;
	106	goto &$plan_code;
	107	};
	108	}
	109
	110	my $DIED = 0;
	111	$SIG{__DIE__} = sub { $DIED = 1; die @_ };
	112
	113	sub block_class { $self->find_class('Block') }
	114	sub filter_class { $self->find_class('Filter') }
	115
	116	sub find_class {
	117	my $suffix = shift;
	118	my $class = ref($self) . "::$suffix";
	119	return $class if $class->can('new');
	120	$class = __PACKAGE__ . "::$suffix";
	121	return $class if $class->can('new');
	122	eval "require $class";
	123	return $class if $class->can('new');
	124	die "Can't find a class for $suffix";
	125	}
	126
	127	sub check_late {
	128	if ($self->{block_list}) {
	129	my $caller = (caller(1))[3];
	130	$caller =~ s/.*:://;
	131	croak "Too late to call $caller()"
	132	}
	133	}
	134
	135	sub find_my_self() {
	136	my $self = ref($_[0]) eq $default_class
	137	? splice(@_, 0, 1)
	138	: default_object();
	139	return $self, @_;
	140	}
	141
	142	sub blocks() {
	143	(my ($self), @_) = find_my_self(@_);
	144
	145	croak "Invalid arguments passed to 'blocks'"
	146	if @_ > 1;
	147	croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
	148	if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
	149
	150	my $blocks = $self->block_list;
	151
	152	my $section_name = shift \|\| '';
	153	my @blocks = $section_name
	154	? (grep { exists $_->{$section_name} } @$blocks)
	155	: (@$blocks);
	156
	157	return scalar(@blocks) unless wantarray;
	158
	159	return (@blocks) if $self->_filters_delay;
	160
	161	for my $block (@blocks) {
	162	$block->run_filters
	163	unless $block->is_filtered;
	164	}
	165
	166	return (@blocks);
	167	}
	168
	169	sub next_block() {
	170	(my ($self), @_) = find_my_self(@_);
	171	my $list = $self->_next_list;
	172	if (@$list == 0) {
	173	$list = [@{$self->block_list}, undef];
	174	$self->_next_list($list);
	175	}
	176	my $block = shift @$list;
	177	if (defined $block and not $block->is_filtered) {
	178	$block->run_filters;
	179	}
	180	return $block;
	181	}
	182
	183	sub first_block() {
	184	(my ($self), @_) = find_my_self(@_);
	185	$self->_next_list([]);
	186	$self->next_block;
	187	}
	188
	189	sub filters_delay() {
	190	(my ($self), @_) = find_my_self(@_);
	191	$self->_filters_delay(defined $_[0] ? shift : 1);
	192	}
	193
	194	sub no_diag_on_only() {
	195	(my ($self), @_) = find_my_self(@_);
	196	$self->_no_diag_on_only(defined $_[0] ? shift : 1);
	197	}
	198
	199	sub delimiters() {
	200	(my ($self), @_) = find_my_self(@_);
	201	$self->check_late;
	202	my ($block_delimiter, $data_delimiter) = @_;
	203	$block_delimiter \|\|= $self->block_delim_default;
	204	$data_delimiter \|\|= $self->data_delim_default;
	205	$self->block_delim($block_delimiter);
	206	$self->data_delim($data_delimiter);
	207	return $self;
	208	}
	209
	210	sub spec_file() {
	211	(my ($self), @_) = find_my_self(@_);
	212	$self->check_late;
	213	$self->_spec_file(shift);
	214	return $self;
	215	}
	216
	217	sub spec_string() {
	218	(my ($self), @_) = find_my_self(@_);
	219	$self->check_late;
	220	$self->_spec_string(shift);
	221	return $self;
	222	}
	223
	224	sub filters() {
	225	(my ($self), @_) = find_my_self(@_);
	226	if (ref($_[0]) eq 'HASH') {
	227	$self->_filters_map(shift);
	228	}
	229	else {
	230	my $filters = $self->_filters;
	231	push @$filters, @_;
	232	}
	233	return $self;
	234	}
	235
	236	sub filter_arguments() {
	237	$Test::Base::Filter::arguments;
	238	}
	239
	240	sub have_text_diff {
	241	eval { require Text::Diff; 1 } &&
	242	$Text::Diff::VERSION >= 0.35 &&
	243	$Algorithm::Diff::VERSION >= 1.15;
	244	}
	245
	246	sub is($$;$) {
	247	(my ($self), @_) = find_my_self(@_);
	248	my ($actual, $expected, $name) = @_;
	249	local $Test::Builder::Level = $Test::Builder::Level + 1;
	250	if ($ENV{TEST_SHOW_NO_DIFFS} or
	251	not defined $actual or
	252	not defined $expected or
	253	$actual eq $expected or
	254	not($self->have_text_diff) or
	255	$expected !~ /\n./s
	256	) {
	257	Test::More::is($actual, $expected, $name);
	258	}
	259	else {
	260	$name = '' unless defined $name;
	261	ok $actual eq $expected,
	262	$name . "\n" . Text::Diff::diff(\$expected, \$actual);
	263	}
	264	}
	265
	266	sub run(&;$) {
	267	(my ($self), @_) = find_my_self(@_);
	268	my $callback = shift;
	269	for my $block (@{$self->block_list}) {
	270	$block->run_filters unless $block->is_filtered;
	271	&{$callback}($block);
	272	}
	273	}
	274
	275	my $name_error = "Can't determine section names";
	276	sub _section_names {
	277	return @_ if @_ == 2;
	278	my $block = $self->first_block
	279	or croak $name_error;
	280	my @names = grep {
	281	$_ !~ /^(ONLY\|LAST\|SKIP)$/;
	282	} @{$block->{_section_order}[0] \|\| []};
	283	croak "$name_error. Need two sections in first block"
	284	unless @names == 2;
	285	return @names;
	286	}
	287
	288	sub _assert_plan {
	289	plan('no_plan') unless $Have_Plan;
	290	}
	291
	292	sub END {
	293	run_compare() unless $Have_Plan or $DIED or not $import_called;
	294	}
	295
	296	sub run_compare() {
	297	(my ($self), @_) = find_my_self(@_);
	298	$self->_assert_plan;
	299	my ($x, $y) = $self->_section_names(@_);
	300	local $Test::Builder::Level = $Test::Builder::Level + 1;
	301	for my $block (@{$self->block_list}) {
	302	next unless exists($block->{$x}) and exists($block->{$y});
	303	$block->run_filters unless $block->is_filtered;
	304	if (ref $block->$x) {
	305	is_deeply($block->$x, $block->$y,
	306	$block->name ? $block->name : ());
	307	}
	308	elsif (ref $block->$y eq 'Regexp') {
	309	my $regexp = ref $y ? $y : $block->$y;
	310	like($block->$x, $regexp, $block->name ? $block->name : ());
	311	}
	312	else {
	313	is($block->$x, $block->$y, $block->name ? $block->name : ());
	314	}
	315	}
	316	}
	317
	318	sub run_is() {
	319	(my ($self), @_) = find_my_self(@_);
	320	$self->_assert_plan;
	321	my ($x, $y) = $self->_section_names(@_);
	322	local $Test::Builder::Level = $Test::Builder::Level + 1;
	323	for my $block (@{$self->block_list}) {
	324	next unless exists($block->{$x}) and exists($block->{$y});
	325	$block->run_filters unless $block->is_filtered;
	326	is($block->$x, $block->$y,
	327	$block->name ? $block->name : ()
	328	);
	329	}
	330	}
	331
	332	sub run_is_deeply() {
	333	(my ($self), @_) = find_my_self(@_);
	334	$self->_assert_plan;
	335	my ($x, $y) = $self->_section_names(@_);
	336	for my $block (@{$self->block_list}) {
	337	next unless exists($block->{$x}) and exists($block->{$y});
	338	$block->run_filters unless $block->is_filtered;
	339	is_deeply($block->$x, $block->$y,
	340	$block->name ? $block->name : ()
	341	);
	342	}
	343	}
	344
	345	sub run_like() {
	346	(my ($self), @_) = find_my_self(@_);
	347	$self->_assert_plan;
	348	my ($x, $y) = $self->_section_names(@_);
	349	for my $block (@{$self->block_list}) {
	350	next unless exists($block->{$x}) and defined($y);
	351	$block->run_filters unless $block->is_filtered;
	352	my $regexp = ref $y ? $y : $block->$y;
	353	like($block->$x, $regexp,
	354	$block->name ? $block->name : ()
	355	);
	356	}
	357	}
	358
	359	sub run_unlike() {
	360	(my ($self), @_) = find_my_self(@_);
	361	$self->_assert_plan;
	362	my ($x, $y) = $self->_section_names(@_);
	363	for my $block (@{$self->block_list}) {
	364	next unless exists($block->{$x}) and defined($y);
	365	$block->run_filters unless $block->is_filtered;
	366	my $regexp = ref $y ? $y : $block->$y;
	367	unlike($block->$x, $regexp,
	368	$block->name ? $block->name : ()
	369	);
	370	}
	371	}
	372
	373	sub skip_all_unless_require() {
	374	(my ($self), @_) = find_my_self(@_);
	375	my $module = shift;
	376	eval "require $module; 1"
	377	or Test::More::plan(
	378	skip_all => "$module failed to load"
	379	);
	380	}
	381
	382	sub is_deep() {
	383	(my ($self), @_) = find_my_self(@_);
	384	require Test::Deep;
	385	Test::Deep::cmp_deeply(@_);
	386	}
	387
	388	sub run_is_deep() {
	389	(my ($self), @_) = find_my_self(@_);
	390	$self->_assert_plan;
	391	my ($x, $y) = $self->_section_names(@_);
	392	for my $block (@{$self->block_list}) {
	393	next unless exists($block->{$x}) and exists($block->{$y});
	394	$block->run_filters unless $block->is_filtered;
	395	is_deep($block->$x, $block->$y,
	396	$block->name ? $block->name : ()
	397	);
	398	}
	399	}
	400
	401	sub _pre_eval {
	402	my $spec = shift;
	403	return $spec unless $spec =~
	404	s/\A\s<<<(.?)>>>\s*$//sm;
	405	my $eval_code = $1;
	406	eval "package main; $eval_code";
	407	croak $@ if $@;
	408	return $spec;
	409	}
	410
	411	sub _block_list_init {
	412	my $spec = $self->spec;
	413	$spec = $self->_pre_eval($spec);
	414	my $cd = $self->block_delim;
	415	my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E\|\z))/msg);
	416	my $blocks = $self->_choose_blocks(@hunks);
	417	$self->block_list($blocks); # Need to set early for possible filter use
	418	my $seq = 1;
	419	for my $block (@$blocks) {
	420	$block->blocks_object($self);
	421	$block->seq_num($seq++);
	422	}
	423	return $blocks;
	424	}
	425
	426	sub _choose_blocks {
	427	my $blocks = [];
	428	for my $hunk (@_) {
	429	my $block = $self->_make_block($hunk);
	430	if (exists $block->{ONLY}) {
	431	diag "I found ONLY: maybe you're debugging?"
	432	unless $self->_no_diag_on_only;
	433	return [$block];
	434	}
	435	next if exists $block->{SKIP};
	436	push @$blocks, $block;
	437	if (exists $block->{LAST}) {
	438	return $blocks;
	439	}
	440	}
	441	return $blocks;
	442	}
	443
	444	sub _check_reserved {
	445	my $id = shift;
	446	croak "'$id' is a reserved name. Use something else.\n"
	447	if $reserved_section_names->{$id} or
	448	$id =~ /^_/;
	449	}
	450
	451	sub _make_block {
	452	my $hunk = shift;
	453	my $cd = $self->block_delim;
	454	my $dd = $self->data_delim;
	455	my $block = $self->block_class->new;
	456	$hunk =~ s/\A\Q${cd}\E[ \t](.)\s+// or die;
	457	my $name = $1;
	458	my @parts = split /^\Q${dd}\E +$?(\w+)$? (.)?\n/m, $hunk;
	459	my $description = shift @parts;
	460	$description \|\|= '';
	461	unless ($description =~ /\S/) {
	462	$description = $name;
	463	}
	464	$description =~ s/\s*\z//;
	465	$block->set_value(description => $description);
	466
	467	my $section_map = {};
	468	my $section_order = [];
	469	while (@parts) {
	470	my ($type, $filters, $value) = splice(@parts, 0, 3);
	471	$self->_check_reserved($type);
	472	$value = '' unless defined $value;
	473	$filters = '' unless defined $filters;
	474	if ($filters =~ /:(\s\|\z)/) {
	475	croak "Extra lines not allowed in '$type' section"
	476	if $value =~ /\S/;
	477	($filters, $value) = split /\s*:(?:\s+\|\z)/, $filters, 2;
	478	$value = '' unless defined $value;
	479	$value =~ s/^\s(.?)\s*$/$1/;
	480	}
	481	$section_map->{$type} = {
	482	filters => $filters,
	483	};
	484	push @$section_order, $type;
	485	$block->set_value($type, $value);
	486	}
	487	$block->set_value(name => $name);
	488	$block->set_value(_section_map => $section_map);
	489	$block->set_value(_section_order => $section_order);
	490	return $block;
	491	}
	492
	493	sub _spec_init {
	494	return $self->_spec_string
	495	if $self->_spec_string;
	496	local $/;
	497	my $spec;
	498	if (my $spec_file = $self->_spec_file) {
	499	open FILE, $spec_file or die $!;
	500	$spec = <FILE>;
	501	close FILE;
	502	}
	503	else {
	504	$spec = do {
	505	package main;
	506	no warnings 'once';
	507	<DATA>;
	508	};
	509	}
	510	return $spec;
	511	}
	512
	513	sub _strict_warnings() {
	514	require Filter::Util::Call;
	515	my $done = 0;
	516	Filter::Util::Call::filter_add(
	517	sub {
	518	return 0 if $done;
	519	my ($data, $end) = ('', '');
	520	while (my $status = Filter::Util::Call::filter_read()) {
	521	return $status if $status < 0;
	522	if (/^__(?:END\|DATA)__\r?$/) {
	523	$end = $_;
	524	last;
	525	}
	526	$data .= $_;
	527	$_ = '';
	528	}
	529	$_ = "use strict;use warnings;$data$end";
	530	$done = 1;
	531	}
	532	);
	533	}
	534
	535	sub tie_output() {
	536	my $handle = shift;
	537	die "No buffer to tie" unless @_;
	538	tie $handle, 'Test::Base::Handle', $_[0];
	539	}
	540
	541	sub no_diff {
	542	$ENV{TEST_SHOW_NO_DIFFS} = 1;
	543	}
	544
	545	package Test::Base::Handle;
	546
	547	sub TIEHANDLE() {
	548	my $class = shift;
	549	bless \ $_[0], $class;
	550	}
	551
	552	sub PRINT {
	553	$$self .= $_ for @_;
	554	}
	555
	556	#===============================================================================
	557	# Test::Base::Block
	558	#
	559	# This is the default class for accessing a Test::Base block object.
	560	#===============================================================================
	561	package Test::Base::Block;
	562	our @ISA = qw(Spiffy);
	563
	564	our @EXPORT = qw(block_accessor);
	565
	566	sub AUTOLOAD {
	567	return;
	568	}
	569
	570	sub block_accessor() {
	571	my $accessor = shift;
	572	no strict 'refs';
	573	return if defined &$accessor;
	574	*$accessor = sub {
	575	my $self = shift;
	576	if (@_) {
	577	Carp::croak "Not allowed to set values for '$accessor'";
	578	}
	579	my @list = @{$self->{$accessor} \|\| []};
	580	return wantarray
	581	? (@list)
	582	: $list[0];
	583	};
	584	}
	585
	586	block_accessor 'name';
	587	block_accessor 'description';
	588	Spiffy::field 'seq_num';
	589	Spiffy::field 'is_filtered';
	590	Spiffy::field 'blocks_object';
	591	Spiffy::field 'original_values' => {};
	592
	593	sub set_value {
	594	no strict 'refs';
	595	my $accessor = shift;
	596	block_accessor $accessor
	597	unless defined &$accessor;
	598	$self->{$accessor} = [@_];
	599	}
	600
	601	sub run_filters {
	602	my $map = $self->_section_map;
	603	my $order = $self->_section_order;
	604	Carp::croak "Attempt to filter a block twice"
	605	if $self->is_filtered;
	606	for my $type (@$order) {
	607	my $filters = $map->{$type}{filters};
	608	my @value = $self->$type;
	609	$self->original_values->{$type} = $value[0];
	610	for my $filter ($self->_get_filters($type, $filters)) {
	611	$Test::Base::Filter::arguments =
	612	$filter =~ s/=(.*)$// ? $1 : undef;
	613	my $function = "main::$filter";
	614	no strict 'refs';
	615	if (defined &$function) {
	616	local $_ =
	617	(@value == 1 and not defined($value[0])) ? undef :
	618	join '', @value;
	619	my $old = $_;
	620	@value = &$function(@value);
	621	if (not(@value) or
	622	@value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+\|)\z/
	623	) {
	624	if ($value[0] && $_ eq $old) {
	625	Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't.");
	626	}
	627	@value = ($_);
	628	}
	629	}
	630	else {
	631	my $filter_object = $self->blocks_object->filter_class->new;
	632	die "Can't find a function or method for '$filter' filter\n"
	633	unless $filter_object->can($filter);
	634	$filter_object->current_block($self);
	635	@value = $filter_object->$filter(@value);
	636	}
	637	# Set the value after each filter since other filters may be
	638	# introspecting.
	639	$self->set_value($type, @value);
	640	}
	641	}
	642	$self->is_filtered(1);
	643	}
	644
	645	sub _get_filters {
	646	my $type = shift;
	647	my $string = shift \|\| '';
	648	$string =~ s/\s(.?)\s*/$1/;
	649	my @filters = ();
	650	my $map_filters = $self->blocks_object->_filters_map->{$type} \|\| [];
	651	$map_filters = [ $map_filters ] unless ref $map_filters;
	652	my @append = ();
	653	for (
	654	@{$self->blocks_object->_filters},
	655	@$map_filters,
	656	split(/\s+/, $string),
	657	) {
	658	my $filter = $_;
	659	last unless length $filter;
	660	if ($filter =~ s/^-//) {
	661	@filters = grep { $_ ne $filter } @filters;
	662	}
	663	elsif ($filter =~ s/^\+//) {
	664	push @append, $filter;
	665	}
	666	else {
	667	push @filters, $filter;
	668	}
	669	}
	670	return @filters, @append;
	671	}
	672
	673	{
	674	%$reserved_section_names = map {
	675	($_, 1);
	676	} keys(%Test::Base::Block::), qw( new DESTROY );
	677	}
	678
	679	__DATA__
	680
	681	=encoding utf8
	682
	683	#line 1376

+73

-0

inc/Test/Builder/Module.pm less more

	0	#line 1
	1	package Test::Builder::Module;
	2
	3	use strict;
	4
	5	use Test::Builder;
	6
	7	require Exporter;
	8	our @ISA = qw(Exporter);
	9
	10	our $VERSION = '0.94';
	11	$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	12
	13
	14	#line 74
	15
	16	sub import {
	17	my($class) = shift;
	18
	19	# Don't run all this when loading ourself.
	20	return 1 if $class eq 'Test::Builder::Module';
	21
	22	my $test = $class->builder;
	23
	24	my $caller = caller;
	25
	26	$test->exported_to($caller);
	27
	28	$class->import_extra( \@_ );
	29	my(@imports) = $class->_strip_imports( \@_ );
	30
	31	$test->plan(@_);
	32
	33	$class->export_to_level( 1, $class, @imports );
	34	}
	35
	36	sub _strip_imports {
	37	my $class = shift;
	38	my $list = shift;
	39
	40	my @imports = ();
	41	my @other = ();
	42	my $idx = 0;
	43	while( $idx <= $#{$list} ) {
	44	my $item = $list->[$idx];
	45
	46	if( defined $item and $item eq 'import' ) {
	47	push @imports, @{ $list->[ $idx + 1 ] };
	48	$idx++;
	49	}
	50	else {
	51	push @other, $item;
	52	}
	53
	54	$idx++;
	55	}
	56
	57	@$list = @other;
	58
	59	return @imports;
	60	}
	61
	62	#line 137
	63
	64	sub import_extra { }
	65
	66	#line 167
	67
	68	sub builder {
	69	return Test::Builder->new;
	70	}
	71
	72	1;

+1589

-0

inc/Test/Builder.pm less more

	0	#line 1
	1	package Test::Builder;
	2
	3	use 5.006;
	4	use strict;
	5	use warnings;
	6
	7	our $VERSION = '0.94';
	8	$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	9
	10	BEGIN {
	11	if( $] < 5.008 ) {
	12	require Test::Builder::IO::Scalar;
	13	}
	14	}
	15
	16
	17	# Make Test::Builder thread-safe for ithreads.
	18	BEGIN {
	19	use Config;
	20	# Load threads::shared when threads are turned on.
	21	# 5.8.0's threads are so busted we no longer support them.
	22	if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
	23	require threads::shared;
	24
	25	# Hack around YET ANOTHER threads::shared bug. It would
	26	# occassionally forget the contents of the variable when sharing it.
	27	# So we first copy the data, then share, then put our copy back.
	28	*share = sub (\[$@%]) {
	29	my $type = ref $_[0];
	30	my $data;
	31
	32	if( $type eq 'HASH' ) {
	33	%$data = %{ $_[0] };
	34	}
	35	elsif( $type eq 'ARRAY' ) {
	36	@$data = @{ $_[0] };
	37	}
	38	elsif( $type eq 'SCALAR' ) {
	39	$$data = ${ $_[0] };
	40	}
	41	else {
	42	die( "Unknown type: " . $type );
	43	}
	44
	45	$_[0] = &threads::shared::share( $_[0] );
	46
	47	if( $type eq 'HASH' ) {
	48	%{ $_[0] } = %$data;
	49	}
	50	elsif( $type eq 'ARRAY' ) {
	51	@{ $_[0] } = @$data;
	52	}
	53	elsif( $type eq 'SCALAR' ) {
	54	${ $_[0] } = $$data;
	55	}
	56	else {
	57	die( "Unknown type: " . $type );
	58	}
	59
	60	return $_[0];
	61	};
	62	}
	63	# 5.8.0's threads::shared is busted when threads are off
	64	# and earlier Perls just don't have that module at all.
	65	else {
	66	*share = sub { return $_[0] };
	67	*lock = sub { 0 };
	68	}
	69	}
	70
	71	#line 117
	72
	73	our $Test = Test::Builder->new;
	74
	75	sub new {
	76	my($class) = shift;
	77	$Test \|\|= $class->create;
	78	return $Test;
	79	}
	80
	81	#line 139
	82
	83	sub create {
	84	my $class = shift;
	85
	86	my $self = bless {}, $class;
	87	$self->reset;
	88
	89	return $self;
	90	}
	91
	92	#line 168
	93
	94	sub child {
	95	my( $self, $name ) = @_;
	96
	97	if( $self->{Child_Name} ) {
	98	$self->croak("You already have a child named ($self->{Child_Name}) running");
	99	}
	100
	101	my $child = bless {}, ref $self;
	102	$child->reset;
	103
	104	# Add to our indentation
	105	$child->_indent( $self->_indent . ' ' );
	106	$child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
	107
	108	# This will be reset in finalize. We do this here lest one child failure
	109	# cause all children to fail.
	110	$child->{Child_Error} = $?;
	111	$? = 0;
	112	$child->{Parent} = $self;
	113	$child->{Name} = $name \|\| "Child of " . $self->name;
	114	$self->{Child_Name} = $child->name;
	115	return $child;
	116	}
	117
	118
	119	#line 201
	120
	121	sub subtest {
	122	my $self = shift;
	123	my($name, $subtests) = @_;
	124
	125	if ('CODE' ne ref $subtests) {
	126	$self->croak("subtest()'s second argument must be a code ref");
	127	}
	128
	129	# Turn the child into the parent so anyone who has stored a copy of
	130	# the Test::Builder singleton will get the child.
	131	my $child = $self->child($name);
	132	my %parent = %$self;
	133	%$self = %$child;
	134
	135	my $error;
	136	if( !eval { $subtests->(); 1 } ) {
	137	$error = $@;
	138	}
	139
	140	# Restore the parent and the copied child.
	141	%$child = %$self;
	142	%$self = %parent;
	143
	144	# Die after we restore the parent.
	145	die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
	146
	147	return $child->finalize;
	148	}
	149
	150
	151	#line 250
	152
	153	sub finalize {
	154	my $self = shift;
	155
	156	return unless $self->parent;
	157	if( $self->{Child_Name} ) {
	158	$self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
	159	}
	160	$self->_ending;
	161
	162	# XXX This will only be necessary for TAP envelopes (we think)
	163	#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
	164
	165	my $ok = 1;
	166	$self->parent->{Child_Name} = undef;
	167	if ( $self->{Skip_All} ) {
	168	$self->parent->skip($self->{Skip_All});
	169	}
	170	elsif ( not @{ $self->{Test_Results} } ) {
	171	$self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
	172	}
	173	else {
	174	$self->parent->ok( $self->is_passing, $self->name );
	175	}
	176	$? = $self->{Child_Error};
	177	delete $self->{Parent};
	178
	179	return $self->is_passing;
	180	}
	181
	182	sub _indent {
	183	my $self = shift;
	184
	185	if( @_ ) {
	186	$self->{Indent} = shift;
	187	}
	188
	189	return $self->{Indent};
	190	}
	191
	192	#line 300
	193
	194	sub parent { shift->{Parent} }
	195
	196	#line 312
	197
	198	sub name { shift->{Name} }
	199
	200	sub DESTROY {
	201	my $self = shift;
	202	if ( $self->parent ) {
	203	my $name = $self->name;
	204	$self->diag(<<"FAIL");
	205	Child ($name) exited without calling finalize()
	206	FAIL
	207	$self->parent->{In_Destroy} = 1;
	208	$self->parent->ok(0, $name);
	209	}
	210	}
	211
	212	#line 336
	213
	214	our $Level;
	215
	216	sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
	217	my($self) = @_;
	218
	219	# We leave this a global because it has to be localized and localizing
	220	# hash keys is just asking for pain. Also, it was documented.
	221	$Level = 1;
	222
	223	$self->{Name} = $0;
	224	$self->is_passing(1);
	225	$self->{Ending} = 0;
	226	$self->{Have_Plan} = 0;
	227	$self->{No_Plan} = 0;
	228	$self->{Have_Output_Plan} = 0;
	229
	230	$self->{Original_Pid} = $$;
	231	$self->{Child_Name} = undef;
	232	$self->{Indent} \|\|= '';
	233
	234	share( $self->{Curr_Test} );
	235	$self->{Curr_Test} = 0;
	236	$self->{Test_Results} = &share( [] );
	237
	238	$self->{Exported_To} = undef;
	239	$self->{Expected_Tests} = 0;
	240
	241	$self->{Skip_All} = 0;
	242
	243	$self->{Use_Nums} = 1;
	244
	245	$self->{No_Header} = 0;
	246	$self->{No_Ending} = 0;
	247
	248	$self->{Todo} = undef;
	249	$self->{Todo_Stack} = [];
	250	$self->{Start_Todo} = 0;
	251	$self->{Opened_Testhandles} = 0;
	252
	253	$self->_dup_stdhandles;
	254
	255	return;
	256	}
	257
	258	#line 414
	259
	260	my %plan_cmds = (
	261	no_plan => \&no_plan,
	262	skip_all => \&skip_all,
	263	tests => \&_plan_tests,
	264	);
	265
	266	sub plan {
	267	my( $self, $cmd, $arg ) = @_;
	268
	269	return unless $cmd;
	270
	271	local $Level = $Level + 1;
	272
	273	$self->croak("You tried to plan twice") if $self->{Have_Plan};
	274
	275	if( my $method = $plan_cmds{$cmd} ) {
	276	local $Level = $Level + 1;
	277	$self->$method($arg);
	278	}
	279	else {
	280	my @args = grep { defined } ( $cmd, $arg );
	281	$self->croak("plan() doesn't understand @args");
	282	}
	283
	284	return 1;
	285	}
	286
	287
	288	sub _plan_tests {
	289	my($self, $arg) = @_;
	290
	291	if($arg) {
	292	local $Level = $Level + 1;
	293	return $self->expected_tests($arg);
	294	}
	295	elsif( !defined $arg ) {
	296	$self->croak("Got an undefined number of tests");
	297	}
	298	else {
	299	$self->croak("You said to run 0 tests");
	300	}
	301
	302	return;
	303	}
	304
	305
	306	#line 470
	307
	308	sub expected_tests {
	309	my $self = shift;
	310	my($max) = @_;
	311
	312	if(@_) {
	313	$self->croak("Number of tests must be a positive integer. You gave it '$max'")
	314	unless $max =~ /^\+?\d+$/;
	315
	316	$self->{Expected_Tests} = $max;
	317	$self->{Have_Plan} = 1;
	318
	319	$self->_output_plan($max) unless $self->no_header;
	320	}
	321	return $self->{Expected_Tests};
	322	}
	323
	324	#line 494
	325
	326	sub no_plan {
	327	my($self, $arg) = @_;
	328
	329	$self->carp("no_plan takes no arguments") if $arg;
	330
	331	$self->{No_Plan} = 1;
	332	$self->{Have_Plan} = 1;
	333
	334	return 1;
	335	}
	336
	337
	338	#line 528
	339
	340	sub _output_plan {
	341	my($self, $max, $directive, $reason) = @_;
	342
	343	$self->carp("The plan was already output") if $self->{Have_Output_Plan};
	344
	345	my $plan = "1..$max";
	346	$plan .= " # $directive" if defined $directive;
	347	$plan .= " $reason" if defined $reason;
	348
	349	$self->_print("$plan\n");
	350
	351	$self->{Have_Output_Plan} = 1;
	352
	353	return;
	354	}
	355
	356	#line 579
	357
	358	sub done_testing {
	359	my($self, $num_tests) = @_;
	360
	361	# If done_testing() specified the number of tests, shut off no_plan.
	362	if( defined $num_tests ) {
	363	$self->{No_Plan} = 0;
	364	}
	365	else {
	366	$num_tests = $self->current_test;
	367	}
	368
	369	if( $self->{Done_Testing} ) {
	370	my($file, $line) = @{$self->{Done_Testing}}[1,2];
	371	$self->ok(0, "done_testing() was already called at $file line $line");
	372	return;
	373	}
	374
	375	$self->{Done_Testing} = [caller];
	376
	377	if( $self->expected_tests && $num_tests != $self->expected_tests ) {
	378	$self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
	379	"but done_testing() expects $num_tests");
	380	}
	381	else {
	382	$self->{Expected_Tests} = $num_tests;
	383	}
	384
	385	$self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
	386
	387	$self->{Have_Plan} = 1;
	388
	389	# The wrong number of tests were run
	390	$self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
	391
	392	# No tests were run
	393	$self->is_passing(0) if $self->{Curr_Test} == 0;
	394
	395	return 1;
	396	}
	397
	398
	399	#line 630
	400
	401	sub has_plan {
	402	my $self = shift;
	403
	404	return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
	405	return('no_plan') if $self->{No_Plan};
	406	return(undef);
	407	}
	408
	409	#line 647
	410
	411	sub skip_all {
	412	my( $self, $reason ) = @_;
	413
	414	$self->{Skip_All} = $self->parent ? $reason : 1;
	415
	416	$self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
	417	if ( $self->parent ) {
	418	die bless {} => 'Test::Builder::Exception';
	419	}
	420	exit(0);
	421	}
	422
	423	#line 672
	424
	425	sub exported_to {
	426	my( $self, $pack ) = @_;
	427
	428	if( defined $pack ) {
	429	$self->{Exported_To} = $pack;
	430	}
	431	return $self->{Exported_To};
	432	}
	433
	434	#line 702
	435
	436	sub ok {
	437	my( $self, $test, $name ) = @_;
	438
	439	if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
	440	$name = 'unnamed test' unless defined $name;
	441	$self->is_passing(0);
	442	$self->croak("Cannot run test ($name) with active children");
	443	}
	444	# $test might contain an object which we don't want to accidentally
	445	# store, so we turn it into a boolean.
	446	$test = $test ? 1 : 0;
	447
	448	lock $self->{Curr_Test};
	449	$self->{Curr_Test}++;
	450
	451	# In case $name is a string overloaded object, force it to stringify.
	452	$self->_unoverload_str( \$name );
	453
	454	$self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
	455	You named your test '$name'. You shouldn't use numbers for your test names.
	456	Very confusing.
	457	ERR
	458
	459	# Capture the value of $TODO for the rest of this ok() call
	460	# so it can more easily be found by other routines.
	461	my $todo = $self->todo();
	462	my $in_todo = $self->in_todo;
	463	local $self->{Todo} = $todo if $in_todo;
	464
	465	$self->_unoverload_str( \$todo );
	466
	467	my $out;
	468	my $result = &share( {} );
	469
	470	unless($test) {
	471	$out .= "not ";
	472	@$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
	473	}
	474	else {
	475	@$result{ 'ok', 'actual_ok' } = ( 1, $test );
	476	}
	477
	478	$out .= "ok";
	479	$out .= " $self->{Curr_Test}" if $self->use_numbers;
	480
	481	if( defined $name ) {
	482	$name =~ s\|#\|\\#\|g; # # in a name can confuse Test::Harness.
	483	$out .= " - $name";
	484	$result->{name} = $name;
	485	}
	486	else {
	487	$result->{name} = '';
	488	}
	489
	490	if( $self->in_todo ) {
	491	$out .= " # TODO $todo";
	492	$result->{reason} = $todo;
	493	$result->{type} = 'todo';
	494	}
	495	else {
	496	$result->{reason} = '';
	497	$result->{type} = '';
	498	}
	499
	500	$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
	501	$out .= "\n";
	502
	503	$self->_print($out);
	504
	505	unless($test) {
	506	my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
	507	$self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
	508
	509	my( undef, $file, $line ) = $self->caller;
	510	if( defined $name ) {
	511	$self->diag(qq[ $msg test '$name'\n]);
	512	$self->diag(qq[ at $file line $line.\n]);
	513	}
	514	else {
	515	$self->diag(qq[ $msg test at $file line $line.\n]);
	516	}
	517	}
	518
	519	$self->is_passing(0) unless $test \|\| $self->in_todo;
	520
	521	# Check that we haven't violated the plan
	522	$self->_check_is_passing_plan();
	523
	524	return $test ? 1 : 0;
	525	}
	526
	527
	528	# Check that we haven't yet violated the plan and set
	529	# is_passing() accordingly
	530	sub _check_is_passing_plan {
	531	my $self = shift;
	532
	533	my $plan = $self->has_plan;
	534	return unless defined $plan; # no plan yet defined
	535	return unless $plan !~ /\D/; # no numeric plan
	536	$self->is_passing(0) if $plan < $self->{Curr_Test};
	537	}
	538
	539
	540	sub _unoverload {
	541	my $self = shift;
	542	my $type = shift;
	543
	544	$self->_try(sub { require overload; }, die_on_fail => 1);
	545
	546	foreach my $thing (@_) {
	547	if( $self->_is_object($$thing) ) {
	548	if( my $string_meth = overload::Method( $$thing, $type ) ) {
	549	$$thing = $$thing->$string_meth();
	550	}
	551	}
	552	}
	553
	554	return;
	555	}
	556
	557	sub _is_object {
	558	my( $self, $thing ) = @_;
	559
	560	return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
	561	}
	562
	563	sub _unoverload_str {
	564	my $self = shift;
	565
	566	return $self->_unoverload( q[""], @_ );
	567	}
	568
	569	sub _unoverload_num {
	570	my $self = shift;
	571
	572	$self->_unoverload( '0+', @_ );
	573
	574	for my $val (@_) {
	575	next unless $self->_is_dualvar($$val);
	576	$$val = $$val + 0;
	577	}
	578
	579	return;
	580	}
	581
	582	# This is a hack to detect a dualvar such as $!
	583	sub _is_dualvar {
	584	my( $self, $val ) = @_;
	585
	586	# Objects are not dualvars.
	587	return 0 if ref $val;
	588
	589	no warnings 'numeric';
	590	my $numval = $val + 0;
	591	return $numval != 0 and $numval ne $val ? 1 : 0;
	592	}
	593
	594	#line 876
	595
	596	sub is_eq {
	597	my( $self, $got, $expect, $name ) = @_;
	598	local $Level = $Level + 1;
	599
	600	$self->_unoverload_str( \$got, \$expect );
	601
	602	if( !defined $got \|\| !defined $expect ) {
	603	# undef only matches undef and nothing else
	604	my $test = !defined $got && !defined $expect;
	605
	606	$self->ok( $test, $name );
	607	$self->_is_diag( $got, 'eq', $expect ) unless $test;
	608	return $test;
	609	}
	610
	611	return $self->cmp_ok( $got, 'eq', $expect, $name );
	612	}
	613
	614	sub is_num {
	615	my( $self, $got, $expect, $name ) = @_;
	616	local $Level = $Level + 1;
	617
	618	$self->_unoverload_num( \$got, \$expect );
	619
	620	if( !defined $got \|\| !defined $expect ) {
	621	# undef only matches undef and nothing else
	622	my $test = !defined $got && !defined $expect;
	623
	624	$self->ok( $test, $name );
	625	$self->_is_diag( $got, '==', $expect ) unless $test;
	626	return $test;
	627	}
	628
	629	return $self->cmp_ok( $got, '==', $expect, $name );
	630	}
	631
	632	sub _diag_fmt {
	633	my( $self, $type, $val ) = @_;
	634
	635	if( defined $$val ) {
	636	if( $type eq 'eq' or $type eq 'ne' ) {
	637	# quote and force string context
	638	$$val = "'$$val'";
	639	}
	640	else {
	641	# force numeric context
	642	$self->_unoverload_num($val);
	643	}
	644	}
	645	else {
	646	$$val = 'undef';
	647	}
	648
	649	return;
	650	}
	651
	652	sub _is_diag {
	653	my( $self, $got, $type, $expect ) = @_;
	654
	655	$self->_diag_fmt( $type, $_ ) for \$got, \$expect;
	656
	657	local $Level = $Level + 1;
	658	return $self->diag(<<"DIAGNOSTIC");
	659	got: $got
	660	expected: $expect
	661	DIAGNOSTIC
	662
	663	}
	664
	665	sub _isnt_diag {
	666	my( $self, $got, $type ) = @_;
	667
	668	$self->_diag_fmt( $type, \$got );
	669
	670	local $Level = $Level + 1;
	671	return $self->diag(<<"DIAGNOSTIC");
	672	got: $got
	673	expected: anything else
	674	DIAGNOSTIC
	675	}
	676
	677	#line 973
	678
	679	sub isnt_eq {
	680	my( $self, $got, $dont_expect, $name ) = @_;
	681	local $Level = $Level + 1;
	682
	683	if( !defined $got \|\| !defined $dont_expect ) {
	684	# undef only matches undef and nothing else
	685	my $test = defined $got \|\| defined $dont_expect;
	686
	687	$self->ok( $test, $name );
	688	$self->_isnt_diag( $got, 'ne' ) unless $test;
	689	return $test;
	690	}
	691
	692	return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
	693	}
	694
	695	sub isnt_num {
	696	my( $self, $got, $dont_expect, $name ) = @_;
	697	local $Level = $Level + 1;
	698
	699	if( !defined $got \|\| !defined $dont_expect ) {
	700	# undef only matches undef and nothing else
	701	my $test = defined $got \|\| defined $dont_expect;
	702
	703	$self->ok( $test, $name );
	704	$self->_isnt_diag( $got, '!=' ) unless $test;
	705	return $test;
	706	}
	707
	708	return $self->cmp_ok( $got, '!=', $dont_expect, $name );
	709	}
	710
	711	#line 1022
	712
	713	sub like {
	714	my( $self, $this, $regex, $name ) = @_;
	715
	716	local $Level = $Level + 1;
	717	return $self->_regex_ok( $this, $regex, '=~', $name );
	718	}
	719
	720	sub unlike {
	721	my( $self, $this, $regex, $name ) = @_;
	722
	723	local $Level = $Level + 1;
	724	return $self->_regex_ok( $this, $regex, '!~', $name );
	725	}
	726
	727	#line 1046
	728
	729	my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
	730
	731	sub cmp_ok {
	732	my( $self, $got, $type, $expect, $name ) = @_;
	733
	734	my $test;
	735	my $error;
	736	{
	737	## no critic (BuiltinFunctions::ProhibitStringyEval)
	738
	739	local( $@, $!, $SIG{__DIE__} ); # isolate eval
	740
	741	my($pack, $file, $line) = $self->caller();
	742
	743	$test = eval qq[
	744	#line 1 "cmp_ok [from $file line $line]"
	745	\$got $type \$expect;
	746	];
	747	$error = $@;
	748	}
	749	local $Level = $Level + 1;
	750	my $ok = $self->ok( $test, $name );
	751
	752	# Treat overloaded objects as numbers if we're asked to do a
	753	# numeric comparison.
	754	my $unoverload
	755	= $numeric_cmps{$type}
	756	? '_unoverload_num'
	757	: '_unoverload_str';
	758
	759	$self->diag(<<"END") if $error;
	760	An error occurred while using $type:
	761	------------------------------------
	762	$error
	763	------------------------------------
	764	END
	765
	766	unless($ok) {
	767	$self->$unoverload( \$got, \$expect );
	768
	769	if( $type =~ /^(eq\|==)$/ ) {
	770	$self->_is_diag( $got, $type, $expect );
	771	}
	772	elsif( $type =~ /^(ne\|!=)$/ ) {
	773	$self->_isnt_diag( $got, $type );
	774	}
	775	else {
	776	$self->_cmp_diag( $got, $type, $expect );
	777	}
	778	}
	779	return $ok;
	780	}
	781
	782	sub _cmp_diag {
	783	my( $self, $got, $type, $expect ) = @_;
	784
	785	$got = defined $got ? "'$got'" : 'undef';
	786	$expect = defined $expect ? "'$expect'" : 'undef';
	787
	788	local $Level = $Level + 1;
	789	return $self->diag(<<"DIAGNOSTIC");
	790	$got
	791	$type
	792	$expect
	793	DIAGNOSTIC
	794	}
	795
	796	sub _caller_context {
	797	my $self = shift;
	798
	799	my( $pack, $file, $line ) = $self->caller(1);
	800
	801	my $code = '';
	802	$code .= "#line $line $file\n" if defined $file and defined $line;
	803
	804	return $code;
	805	}
	806
	807	#line 1145
	808
	809	sub BAIL_OUT {
	810	my( $self, $reason ) = @_;
	811
	812	$self->{Bailed_Out} = 1;
	813	$self->_print("Bail out! $reason");
	814	exit 255;
	815	}
	816
	817	#line 1158
	818
	819	{
	820	no warnings 'once';
	821	*BAILOUT = \&BAIL_OUT;
	822	}
	823
	824	#line 1172
	825
	826	sub skip {
	827	my( $self, $why ) = @_;
	828	$why \|\|= '';
	829	$self->_unoverload_str( \$why );
	830
	831	lock( $self->{Curr_Test} );
	832	$self->{Curr_Test}++;
	833
	834	$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
	835	{
	836	'ok' => 1,
	837	actual_ok => 1,
	838	name => '',
	839	type => 'skip',
	840	reason => $why,
	841	}
	842	);
	843
	844	my $out = "ok";
	845	$out .= " $self->{Curr_Test}" if $self->use_numbers;
	846	$out .= " # skip";
	847	$out .= " $why" if length $why;
	848	$out .= "\n";
	849
	850	$self->_print($out);
	851
	852	return 1;
	853	}
	854
	855	#line 1213
	856
	857	sub todo_skip {
	858	my( $self, $why ) = @_;
	859	$why \|\|= '';
	860
	861	lock( $self->{Curr_Test} );
	862	$self->{Curr_Test}++;
	863
	864	$self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
	865	{
	866	'ok' => 1,
	867	actual_ok => 0,
	868	name => '',
	869	type => 'todo_skip',
	870	reason => $why,
	871	}
	872	);
	873
	874	my $out = "not ok";
	875	$out .= " $self->{Curr_Test}" if $self->use_numbers;
	876	$out .= " # TODO & SKIP $why\n";
	877
	878	$self->_print($out);
	879
	880	return 1;
	881	}
	882
	883	#line 1293
	884
	885	sub maybe_regex {
	886	my( $self, $regex ) = @_;
	887	my $usable_regex = undef;
	888
	889	return $usable_regex unless defined $regex;
	890
	891	my( $re, $opts );
	892
	893	# Check for qr/foo/
	894	if( _is_qr($regex) ) {
	895	$usable_regex = $regex;
	896	}
	897	# Check for '/foo/' or 'm,foo,'
	898	elsif(( $re, $opts ) = $regex =~ m{^ /(.)/ (\w) $ }sx or
	899	( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
	900	)
	901	{
	902	$usable_regex = length $opts ? "(?$opts)$re" : $re;
	903	}
	904
	905	return $usable_regex;
	906	}
	907
	908	sub _is_qr {
	909	my $regex = shift;
	910
	911	# is_regexp() checks for regexes in a robust manner, say if they're
	912	# blessed.
	913	return re::is_regexp($regex) if defined &re::is_regexp;
	914	return ref $regex eq 'Regexp';
	915	}
	916
	917	sub _regex_ok {
	918	my( $self, $this, $regex, $cmp, $name ) = @_;
	919
	920	my $ok = 0;
	921	my $usable_regex = $self->maybe_regex($regex);
	922	unless( defined $usable_regex ) {
	923	local $Level = $Level + 1;
	924	$ok = $self->ok( 0, $name );
	925	$self->diag(" '$regex' doesn't look much like a regex to me.");
	926	return $ok;
	927	}
	928
	929	{
	930	## no critic (BuiltinFunctions::ProhibitStringyEval)
	931
	932	my $test;
	933	my $context = $self->_caller_context;
	934
	935	local( $@, $!, $SIG{__DIE__} ); # isolate eval
	936
	937	$test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
	938
	939	$test = !$test if $cmp eq '!~';
	940
	941	local $Level = $Level + 1;
	942	$ok = $self->ok( $test, $name );
	943	}
	944
	945	unless($ok) {
	946	$this = defined $this ? "'$this'" : 'undef';
	947	my $match = $cmp eq '=~' ? "doesn't match" : "matches";
	948
	949	local $Level = $Level + 1;
	950	$self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
	951	%s
	952	%13s '%s'
	953	DIAGNOSTIC
	954
	955	}
	956
	957	return $ok;
	958	}
	959
	960	# I'm not ready to publish this. It doesn't deal with array return
	961	# values from the code or context.
	962
	963	#line 1389
	964
	965	sub _try {
	966	my( $self, $code, %opts ) = @_;
	967
	968	my $error;
	969	my $return;
	970	{
	971	local $!; # eval can mess up $!
	972	local $@; # don't set $@ in the test
	973	local $SIG{__DIE__}; # don't trip an outside DIE handler.
	974	$return = eval { $code->() };
	975	$error = $@;
	976	}
	977
	978	die $error if $error and $opts{die_on_fail};
	979
	980	return wantarray ? ( $return, $error ) : $return;
	981	}
	982
	983	#line 1418
	984
	985	sub is_fh {
	986	my $self = shift;
	987	my $maybe_fh = shift;
	988	return 0 unless defined $maybe_fh;
	989
	990	return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
	991	return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
	992
	993	return eval { $maybe_fh->isa("IO::Handle") } \|\|
	994	eval { tied($maybe_fh)->can('TIEHANDLE') };
	995	}
	996
	997	#line 1461
	998
	999	sub level {
	1000	my( $self, $level ) = @_;
	1001
	1002	if( defined $level ) {
	1003	$Level = $level;
	1004	}
	1005	return $Level;
	1006	}
	1007
	1008	#line 1493
	1009
	1010	sub use_numbers {
	1011	my( $self, $use_nums ) = @_;
	1012
	1013	if( defined $use_nums ) {
	1014	$self->{Use_Nums} = $use_nums;
	1015	}
	1016	return $self->{Use_Nums};
	1017	}
	1018
	1019	#line 1526
	1020
	1021	foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
	1022	my $method = lc $attribute;
	1023
	1024	my $code = sub {
	1025	my( $self, $no ) = @_;
	1026
	1027	if( defined $no ) {
	1028	$self->{$attribute} = $no;
	1029	}
	1030	return $self->{$attribute};
	1031	};
	1032
	1033	no strict 'refs'; ## no critic
	1034	*{ __PACKAGE__ . '::' . $method } = $code;
	1035	}
	1036
	1037	#line 1579
	1038
	1039	sub diag {
	1040	my $self = shift;
	1041
	1042	$self->_print_comment( $self->_diag_fh, @_ );
	1043	}
	1044
	1045	#line 1594
	1046
	1047	sub note {
	1048	my $self = shift;
	1049
	1050	$self->_print_comment( $self->output, @_ );
	1051	}
	1052
	1053	sub _diag_fh {
	1054	my $self = shift;
	1055
	1056	local $Level = $Level + 1;
	1057	return $self->in_todo ? $self->todo_output : $self->failure_output;
	1058	}
	1059
	1060	sub _print_comment {
	1061	my( $self, $fh, @msgs ) = @_;
	1062
	1063	return if $self->no_diag;
	1064	return unless @msgs;
	1065
	1066	# Prevent printing headers when compiling (i.e. -c)
	1067	return if $^C;
	1068
	1069	# Smash args together like print does.
	1070	# Convert undef to 'undef' so its readable.
	1071	my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
	1072
	1073	# Escape the beginning, _print will take care of the rest.
	1074	$msg =~ s/^/# /;
	1075
	1076	local $Level = $Level + 1;
	1077	$self->_print_to_fh( $fh, $msg );
	1078
	1079	return 0;
	1080	}
	1081
	1082	#line 1644
	1083
	1084	sub explain {
	1085	my $self = shift;
	1086
	1087	return map {
	1088	ref $_
	1089	? do {
	1090	$self->_try(sub { require Data::Dumper }, die_on_fail => 1);
	1091
	1092	my $dumper = Data::Dumper->new( [$_] );
	1093	$dumper->Indent(1)->Terse(1);
	1094	$dumper->Sortkeys(1) if $dumper->can("Sortkeys");
	1095	$dumper->Dump;
	1096	}
	1097	: $_
	1098	} @_;
	1099	}
	1100
	1101	#line 1673
	1102
	1103	sub _print {
	1104	my $self = shift;
	1105	return $self->_print_to_fh( $self->output, @_ );
	1106	}
	1107
	1108	sub _print_to_fh {
	1109	my( $self, $fh, @msgs ) = @_;
	1110
	1111	# Prevent printing headers when only compiling. Mostly for when
	1112	# tests are deparsed with B::Deparse
	1113	return if $^C;
	1114
	1115	my $msg = join '', @msgs;
	1116
	1117	local( $\, $", $, ) = ( undef, ' ', '' );
	1118
	1119	# Escape each line after the first with a # so we don't
	1120	# confuse Test::Harness.
	1121	$msg =~ s{\n(?!\z)}{\n# }sg;
	1122
	1123	# Stick a newline on the end if it needs it.
	1124	$msg .= "\n" unless $msg =~ /\n\z/;
	1125
	1126	return print $fh $self->_indent, $msg;
	1127	}
	1128
	1129	#line 1732
	1130
	1131	sub output {
	1132	my( $self, $fh ) = @_;
	1133
	1134	if( defined $fh ) {
	1135	$self->{Out_FH} = $self->_new_fh($fh);
	1136	}
	1137	return $self->{Out_FH};
	1138	}
	1139
	1140	sub failure_output {
	1141	my( $self, $fh ) = @_;
	1142
	1143	if( defined $fh ) {
	1144	$self->{Fail_FH} = $self->_new_fh($fh);
	1145	}
	1146	return $self->{Fail_FH};
	1147	}
	1148
	1149	sub todo_output {
	1150	my( $self, $fh ) = @_;
	1151
	1152	if( defined $fh ) {
	1153	$self->{Todo_FH} = $self->_new_fh($fh);
	1154	}
	1155	return $self->{Todo_FH};
	1156	}
	1157
	1158	sub _new_fh {
	1159	my $self = shift;
	1160	my($file_or_fh) = shift;
	1161
	1162	my $fh;
	1163	if( $self->is_fh($file_or_fh) ) {
	1164	$fh = $file_or_fh;
	1165	}
	1166	elsif( ref $file_or_fh eq 'SCALAR' ) {
	1167	# Scalar refs as filehandles was added in 5.8.
	1168	if( $] >= 5.008 ) {
	1169	open $fh, ">>", $file_or_fh
	1170	or $self->croak("Can't open scalar ref $file_or_fh: $!");
	1171	}
	1172	# Emulate scalar ref filehandles with a tie.
	1173	else {
	1174	$fh = Test::Builder::IO::Scalar->new($file_or_fh)
	1175	or $self->croak("Can't tie scalar ref $file_or_fh");
	1176	}
	1177	}
	1178	else {
	1179	open $fh, ">", $file_or_fh
	1180	or $self->croak("Can't open test output log $file_or_fh: $!");
	1181	_autoflush($fh);
	1182	}
	1183
	1184	return $fh;
	1185	}
	1186
	1187	sub _autoflush {
	1188	my($fh) = shift;
	1189	my $old_fh = select $fh;
	1190	$\| = 1;
	1191	select $old_fh;
	1192
	1193	return;
	1194	}
	1195
	1196	my( $Testout, $Testerr );
	1197
	1198	sub _dup_stdhandles {
	1199	my $self = shift;
	1200
	1201	$self->_open_testhandles;
	1202
	1203	# Set everything to unbuffered else plain prints to STDOUT will
	1204	# come out in the wrong order from our own prints.
	1205	_autoflush($Testout);
	1206	_autoflush( \*STDOUT );
	1207	_autoflush($Testerr);
	1208	_autoflush( \*STDERR );
	1209
	1210	$self->reset_outputs;
	1211
	1212	return;
	1213	}
	1214
	1215	sub _open_testhandles {
	1216	my $self = shift;
	1217
	1218	return if $self->{Opened_Testhandles};
	1219
	1220	# We dup STDOUT and STDERR so people can change them in their
	1221	# test suites while still getting normal test output.
	1222	open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
	1223	open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
	1224
	1225	# $self->_copy_io_layers( \*STDOUT, $Testout );
	1226	# $self->_copy_io_layers( \*STDERR, $Testerr );
	1227
	1228	$self->{Opened_Testhandles} = 1;
	1229
	1230	return;
	1231	}
	1232
	1233	sub _copy_io_layers {
	1234	my( $self, $src, $dst ) = @_;
	1235
	1236	$self->_try(
	1237	sub {
	1238	require PerlIO;
	1239	my @src_layers = PerlIO::get_layers($src);
	1240
	1241	binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
	1242	}
	1243	);
	1244
	1245	return;
	1246	}
	1247
	1248	#line 1857
	1249
	1250	sub reset_outputs {
	1251	my $self = shift;
	1252
	1253	$self->output ($Testout);
	1254	$self->failure_output($Testerr);
	1255	$self->todo_output ($Testout);
	1256
	1257	return;
	1258	}
	1259
	1260	#line 1883
	1261
	1262	sub _message_at_caller {
	1263	my $self = shift;
	1264
	1265	local $Level = $Level + 1;
	1266	my( $pack, $file, $line ) = $self->caller;
	1267	return join( "", @_ ) . " at $file line $line.\n";
	1268	}
	1269
	1270	sub carp {
	1271	my $self = shift;
	1272	return warn $self->_message_at_caller(@_);
	1273	}
	1274
	1275	sub croak {
	1276	my $self = shift;
	1277	return die $self->_message_at_caller(@_);
	1278	}
	1279
	1280
	1281	#line 1923
	1282
	1283	sub current_test {
	1284	my( $self, $num ) = @_;
	1285
	1286	lock( $self->{Curr_Test} );
	1287	if( defined $num ) {
	1288	$self->{Curr_Test} = $num;
	1289
	1290	# If the test counter is being pushed forward fill in the details.
	1291	my $test_results = $self->{Test_Results};
	1292	if( $num > @$test_results ) {
	1293	my $start = @$test_results ? @$test_results : 0;
	1294	for( $start .. $num - 1 ) {
	1295	$test_results->[$_] = &share(
	1296	{
	1297	'ok' => 1,
	1298	actual_ok => undef,
	1299	reason => 'incrementing test number',
	1300	type => 'unknown',
	1301	name => undef
	1302	}
	1303	);
	1304	}
	1305	}
	1306	# If backward, wipe history. Its their funeral.
	1307	elsif( $num < @$test_results ) {
	1308	$#{$test_results} = $num - 1;
	1309	}
	1310	}
	1311	return $self->{Curr_Test};
	1312	}
	1313
	1314	#line 1971
	1315
	1316	sub is_passing {
	1317	my $self = shift;
	1318
	1319	if( @_ ) {
	1320	$self->{Is_Passing} = shift;
	1321	}
	1322
	1323	return $self->{Is_Passing};
	1324	}
	1325
	1326
	1327	#line 1993
	1328
	1329	sub summary {
	1330	my($self) = shift;
	1331
	1332	return map { $_->{'ok'} } @{ $self->{Test_Results} };
	1333	}
	1334
	1335	#line 2048
	1336
	1337	sub details {
	1338	my $self = shift;
	1339	return @{ $self->{Test_Results} };
	1340	}
	1341
	1342	#line 2077
	1343
	1344	sub todo {
	1345	my( $self, $pack ) = @_;
	1346
	1347	return $self->{Todo} if defined $self->{Todo};
	1348
	1349	local $Level = $Level + 1;
	1350	my $todo = $self->find_TODO($pack);
	1351	return $todo if defined $todo;
	1352
	1353	return '';
	1354	}
	1355
	1356	#line 2099
	1357
	1358	sub find_TODO {
	1359	my( $self, $pack ) = @_;
	1360
	1361	$pack = $pack \|\| $self->caller(1) \|\| $self->exported_to;
	1362	return unless $pack;
	1363
	1364	no strict 'refs'; ## no critic
	1365	return ${ $pack . '::TODO' };
	1366	}
	1367
	1368	#line 2117
	1369
	1370	sub in_todo {
	1371	my $self = shift;
	1372
	1373	local $Level = $Level + 1;
	1374	return( defined $self->{Todo} \|\| $self->find_TODO ) ? 1 : 0;
	1375	}
	1376
	1377	#line 2167
	1378
	1379	sub todo_start {
	1380	my $self = shift;
	1381	my $message = @_ ? shift : '';
	1382
	1383	$self->{Start_Todo}++;
	1384	if( $self->in_todo ) {
	1385	push @{ $self->{Todo_Stack} } => $self->todo;
	1386	}
	1387	$self->{Todo} = $message;
	1388
	1389	return;
	1390	}
	1391
	1392	#line 2189
	1393
	1394	sub todo_end {
	1395	my $self = shift;
	1396
	1397	if( !$self->{Start_Todo} ) {
	1398	$self->croak('todo_end() called without todo_start()');
	1399	}
	1400
	1401	$self->{Start_Todo}--;
	1402
	1403	if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
	1404	$self->{Todo} = pop @{ $self->{Todo_Stack} };
	1405	}
	1406	else {
	1407	delete $self->{Todo};
	1408	}
	1409
	1410	return;
	1411	}
	1412
	1413	#line 2222
	1414
	1415	sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
	1416	my( $self, $height ) = @_;
	1417	$height \|\|= 0;
	1418
	1419	my $level = $self->level + $height + 1;
	1420	my @caller;
	1421	do {
	1422	@caller = CORE::caller( $level );
	1423	$level--;
	1424	} until @caller;
	1425	return wantarray ? @caller : $caller[0];
	1426	}
	1427
	1428	#line 2239
	1429
	1430	#line 2253
	1431
	1432	#'#
	1433	sub _sanity_check {
	1434	my $self = shift;
	1435
	1436	$self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
	1437	$self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
	1438	'Somehow you got a different number of results than tests ran!' );
	1439
	1440	return;
	1441	}
	1442
	1443	#line 2274
	1444
	1445	sub _whoa {
	1446	my( $self, $check, $desc ) = @_;
	1447	if($check) {
	1448	local $Level = $Level + 1;
	1449	$self->croak(<<"WHOA");
	1450	WHOA! $desc
	1451	This should never happen! Please contact the author immediately!
	1452	WHOA
	1453	}
	1454
	1455	return;
	1456	}
	1457
	1458	#line 2298
	1459
	1460	sub _my_exit {
	1461	$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
	1462
	1463	return 1;
	1464	}
	1465
	1466	#line 2310
	1467
	1468	sub _ending {
	1469	my $self = shift;
	1470	return if $self->no_ending;
	1471	return if $self->{Ending}++;
	1472
	1473	my $real_exit_code = $?;
	1474
	1475	# Don't bother with an ending if this is a forked copy. Only the parent
	1476	# should do the ending.
	1477	if( $self->{Original_Pid} != $$ ) {
	1478	return;
	1479	}
	1480
	1481	# Ran tests but never declared a plan or hit done_testing
	1482	if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
	1483	$self->is_passing(0);
	1484	$self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
	1485	}
	1486
	1487	# Exit if plan() was never called. This is so "require Test::Simple"
	1488	# doesn't puke.
	1489	if( !$self->{Have_Plan} ) {
	1490	return;
	1491	}
	1492
	1493	# Don't do an ending if we bailed out.
	1494	if( $self->{Bailed_Out} ) {
	1495	$self->is_passing(0);
	1496	return;
	1497	}
	1498	# Figure out if we passed or failed and print helpful messages.
	1499	my $test_results = $self->{Test_Results};
	1500	if(@$test_results) {
	1501	# The plan? We have no plan.
	1502	if( $self->{No_Plan} ) {
	1503	$self->_output_plan($self->{Curr_Test}) unless $self->no_header;
	1504	$self->{Expected_Tests} = $self->{Curr_Test};
	1505	}
	1506
	1507	# Auto-extended arrays and elements which aren't explicitly
	1508	# filled in with a shared reference will puke under 5.8.0
	1509	# ithreads. So we have to fill them in by hand. :(
	1510	my $empty_result = &share( {} );
	1511	for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
	1512	$test_results->[$idx] = $empty_result
	1513	unless defined $test_results->[$idx];
	1514	}
	1515
	1516	my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
	1517
	1518	my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
	1519
	1520	if( $num_extra != 0 ) {
	1521	my $s = $self->{Expected_Tests} == 1 ? '' : 's';
	1522	$self->diag(<<"FAIL");
	1523	Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
	1524	FAIL
	1525	$self->is_passing(0);
	1526	}
	1527
	1528	if($num_failed) {
	1529	my $num_tests = $self->{Curr_Test};
	1530	my $s = $num_failed == 1 ? '' : 's';
	1531
	1532	my $qualifier = $num_extra == 0 ? '' : ' run';
	1533
	1534	$self->diag(<<"FAIL");
	1535	Looks like you failed $num_failed test$s of $num_tests$qualifier.
	1536	FAIL
	1537	$self->is_passing(0);
	1538	}
	1539
	1540	if($real_exit_code) {
	1541	$self->diag(<<"FAIL");
	1542	Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
	1543	FAIL
	1544	$self->is_passing(0);
	1545	_my_exit($real_exit_code) && return;
	1546	}
	1547
	1548	my $exit_code;
	1549	if($num_failed) {
	1550	$exit_code = $num_failed <= 254 ? $num_failed : 254;
	1551	}
	1552	elsif( $num_extra != 0 ) {
	1553	$exit_code = 255;
	1554	}
	1555	else {
	1556	$exit_code = 0;
	1557	}
	1558
	1559	_my_exit($exit_code) && return;
	1560	}
	1561	elsif( $self->{Skip_All} ) {
	1562	_my_exit(0) && return;
	1563	}
	1564	elsif($real_exit_code) {
	1565	$self->diag(<<"FAIL");
	1566	Looks like your test exited with $real_exit_code before it could output anything.
	1567	FAIL
	1568	$self->is_passing(0);
	1569	_my_exit($real_exit_code) && return;
	1570	}
	1571	else {
	1572	$self->diag("No tests run!\n");
	1573	$self->is_passing(0);
	1574	_my_exit(255) && return;
	1575	}
	1576
	1577	$self->is_passing(0);
	1578	$self->_whoa( 1, "We fell off the end of _ending()" );
	1579	}
	1580
	1581	END {
	1582	$Test->_ending if defined $Test;
	1583	}
	1584
	1585	#line 2498
	1586
	1587	1;
	1588

+144

-0

inc/Test/Exception.pm less more

	0	#line 1
	1	use strict;
	2	use warnings;
	3
	4	package Test::Exception;
	5	use Test::Builder;
	6	use Sub::Uplevel qw( uplevel );
	7	use base qw( Exporter );
	8
	9	our $VERSION = '0.29';
	10	our @EXPORT = qw(dies_ok lives_ok throws_ok lives_and);
	11
	12	my $Tester = Test::Builder->new;
	13
	14	sub import {
	15	my $self = shift;
	16	if ( @_ ) {
	17	my $package = caller;
	18	$Tester->exported_to( $package );
	19	$Tester->plan( @_ );
	20	};
	21	$self->export_to_level( 1, $self, $_ ) foreach @EXPORT;
	22	}
	23
	24	#line 83
	25
	26	sub _quiet_caller (;$) { ## no critic Prototypes
	27	my $height = $_[0];
	28	$height++;
	29	if( wantarray and !@_ ) {
	30	return (CORE::caller($height))[0..2];
	31	}
	32	else {
	33	return CORE::caller($height);
	34	}
	35	}
	36
	37	sub _try_as_caller {
	38	my $coderef = shift;
	39
	40	# local works here because Sub::Uplevel has already overridden caller
	41	local *CORE::GLOBAL::caller;
	42	{ no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
	43
	44	eval { uplevel 3, $coderef };
	45	return $@;
	46	};
	47
	48
	49	sub _is_exception {
	50	my $exception = shift;
	51	return ref $exception \|\| $exception ne '';
	52	};
	53
	54
	55	sub _exception_as_string {
	56	my ( $prefix, $exception ) = @_;
	57	return "$prefix normal exit" unless _is_exception( $exception );
	58	my $class = ref $exception;
	59	$exception = "$class ($exception)"
	60	if $class && "$exception" !~ m/^\Q$class/;
	61	chomp $exception;
	62	return "$prefix $exception";
	63	};
	64
	65
	66	#line 168
	67
	68
	69	sub throws_ok (&$;$) {
	70	my ( $coderef, $expecting, $description ) = @_;
	71	unless (defined $expecting) {
	72	require Carp;
	73	Carp::croak( "throws_ok: must pass exception class/object or regex" );
	74	}
	75	$description = _exception_as_string( "threw", $expecting )
	76	unless defined $description;
	77	my $exception = _try_as_caller( $coderef );
	78	my $regex = $Tester->maybe_regex( $expecting );
	79	my $ok = $regex
	80	? ( $exception =~ m/$regex/ )
	81	: eval {
	82	$exception->isa( ref $expecting ? ref $expecting : $expecting )
	83	};
	84	$Tester->ok( $ok, $description );
	85	unless ( $ok ) {
	86	$Tester->diag( _exception_as_string( "expecting:", $expecting ) );
	87	$Tester->diag( _exception_as_string( "found:", $exception ) );
	88	};
	89	$@ = $exception;
	90	return $ok;
	91	};
	92
	93
	94	#line 216
	95
	96	sub dies_ok (&;$) {
	97	my ( $coderef, $description ) = @_;
	98	my $exception = _try_as_caller( $coderef );
	99	my $ok = $Tester->ok( _is_exception($exception), $description );
	100	$@ = $exception;
	101	return $ok;
	102	}
	103
	104
	105	#line 255
	106
	107	sub lives_ok (&;$) {
	108	my ( $coderef, $description ) = @_;
	109	my $exception = _try_as_caller( $coderef );
	110	my $ok = $Tester->ok( ! _is_exception( $exception ), $description );
	111	$Tester->diag( _exception_as_string( "died:", $exception ) ) unless $ok;
	112	$@ = $exception;
	113	return $ok;
	114	}
	115
	116
	117	#line 295
	118
	119	sub lives_and (&;$) {
	120	my ( $test, $description ) = @_;
	121	{
	122	local $Test::Builder::Level = $Test::Builder::Level + 1;
	123	my $ok = \&Test::Builder::ok;
	124	no warnings;
	125	local *Test::Builder::ok = sub {
	126	$_[2] = $description unless defined $_[2];
	127	$ok->(@_);
	128	};
	129	use warnings;
	130	eval { $test->() } and return 1;
	131	};
	132	my $exception = $@;
	133	if ( _is_exception( $exception ) ) {
	134	$Tester->ok( 0, $description );
	135	$Tester->diag( _exception_as_string( "died:", $exception ) );
	136	};
	137	$@ = $exception;
	138	return;
	139	}
	140
	141	#line 462
	142
	143	1;

+746

-0

inc/Test/More.pm less more

	0	#line 1
	1	package Test::More;
	2
	3	use 5.006;
	4	use strict;
	5	use warnings;
	6
	7	#---- perlcritic exemptions. ----#
	8
	9	# We use a lot of subroutine prototypes
	10	## no critic (Subroutines::ProhibitSubroutinePrototypes)
	11
	12	# Can't use Carp because it might cause use_ok() to accidentally succeed
	13	# even though the module being used forgot to use Carp. Yes, this
	14	# actually happened.
	15	sub _carp {
	16	my( $file, $line ) = ( caller(1) )[ 1, 2 ];
	17	return warn @_, " at $file line $line\n";
	18	}
	19
	20	our $VERSION = '0.94';
	21	$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	22
	23	use Test::Builder::Module;
	24	our @ISA = qw(Test::Builder::Module);
	25	our @EXPORT = qw(ok use_ok require_ok
	26	is isnt like unlike is_deeply
	27	cmp_ok
	28	skip todo todo_skip
	29	pass fail
	30	eq_array eq_hash eq_set
	31	$TODO
	32	plan
	33	done_testing
	34	can_ok isa_ok new_ok
	35	diag note explain
	36	subtest
	37	BAIL_OUT
	38	);
	39
	40	#line 164
	41
	42	sub plan {
	43	my $tb = Test::More->builder;
	44
	45	return $tb->plan(@_);
	46	}
	47
	48	# This implements "use Test::More 'no_diag'" but the behavior is
	49	# deprecated.
	50	sub import_extra {
	51	my $class = shift;
	52	my $list = shift;
	53
	54	my @other = ();
	55	my $idx = 0;
	56	while( $idx <= $#{$list} ) {
	57	my $item = $list->[$idx];
	58
	59	if( defined $item and $item eq 'no_diag' ) {
	60	$class->builder->no_diag(1);
	61	}
	62	else {
	63	push @other, $item;
	64	}
	65
	66	$idx++;
	67	}
	68
	69	@$list = @other;
	70
	71	return;
	72	}
	73
	74	#line 217
	75
	76	sub done_testing {
	77	my $tb = Test::More->builder;
	78	$tb->done_testing(@_);
	79	}
	80
	81	#line 289
	82
	83	sub ok ($;$) {
	84	my( $test, $name ) = @_;
	85	my $tb = Test::More->builder;
	86
	87	return $tb->ok( $test, $name );
	88	}
	89
	90	#line 367
	91
	92	sub is ($$;$) {
	93	my $tb = Test::More->builder;
	94
	95	return $tb->is_eq(@_);
	96	}
	97
	98	sub isnt ($$;$) {
	99	my $tb = Test::More->builder;
	100
	101	return $tb->isnt_eq(@_);
	102	}
	103
	104	*isn't = \&isnt;
	105
	106	#line 411
	107
	108	sub like ($$;$) {
	109	my $tb = Test::More->builder;
	110
	111	return $tb->like(@_);
	112	}
	113
	114	#line 426
	115
	116	sub unlike ($$;$) {
	117	my $tb = Test::More->builder;
	118
	119	return $tb->unlike(@_);
	120	}
	121
	122	#line 471
	123
	124	sub cmp_ok($$$;$) {
	125	my $tb = Test::More->builder;
	126
	127	return $tb->cmp_ok(@_);
	128	}
	129
	130	#line 506
	131
	132	sub can_ok ($@) {
	133	my( $proto, @methods ) = @_;
	134	my $class = ref $proto \|\| $proto;
	135	my $tb = Test::More->builder;
	136
	137	unless($class) {
	138	my $ok = $tb->ok( 0, "->can(...)" );
	139	$tb->diag(' can_ok() called with empty class or reference');
	140	return $ok;
	141	}
	142
	143	unless(@methods) {
	144	my $ok = $tb->ok( 0, "$class->can(...)" );
	145	$tb->diag(' can_ok() called with no methods');
	146	return $ok;
	147	}
	148
	149	my @nok = ();
	150	foreach my $method (@methods) {
	151	$tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
	152	}
	153
	154	my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
	155	"$class->can(...)" ;
	156
	157	my $ok = $tb->ok( !@nok, $name );
	158
	159	$tb->diag( map " $class->can('$_') failed\n", @nok );
	160
	161	return $ok;
	162	}
	163
	164	#line 572
	165
	166	sub isa_ok ($$;$) {
	167	my( $object, $class, $obj_name ) = @_;
	168	my $tb = Test::More->builder;
	169
	170	my $diag;
	171
	172	if( !defined $object ) {
	173	$obj_name = 'The thing' unless defined $obj_name;
	174	$diag = "$obj_name isn't defined";
	175	}
	176	else {
	177	my $whatami = ref $object ? 'object' : 'class';
	178	# We can't use UNIVERSAL::isa because we want to honor isa() overrides
	179	my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
	180	if($error) {
	181	if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
	182	# Its an unblessed reference
	183	$obj_name = 'The reference' unless defined $obj_name;
	184	if( !UNIVERSAL::isa( $object, $class ) ) {
	185	my $ref = ref $object;
	186	$diag = "$obj_name isn't a '$class' it's a '$ref'";
	187	}
	188	}
	189	elsif( $error =~ /Can't call method "isa" without a package/ ) {
	190	# It's something that can't even be a class
	191	$obj_name = 'The thing' unless defined $obj_name;
	192	$diag = "$obj_name isn't a class or reference";
	193	}
	194	else {
	195	die <<WHOA;
	196	WHOA! I tried to call ->isa on your $whatami and got some weird error.
	197	Here's the error.
	198	$error
	199	WHOA
	200	}
	201	}
	202	else {
	203	$obj_name = "The $whatami" unless defined $obj_name;
	204	if( !$rslt ) {
	205	my $ref = ref $object;
	206	$diag = "$obj_name isn't a '$class' it's a '$ref'";
	207	}
	208	}
	209	}
	210
	211	my $name = "$obj_name isa $class";
	212	my $ok;
	213	if($diag) {
	214	$ok = $tb->ok( 0, $name );
	215	$tb->diag(" $diag\n");
	216	}
	217	else {
	218	$ok = $tb->ok( 1, $name );
	219	}
	220
	221	return $ok;
	222	}
	223
	224	#line 651
	225
	226	sub new_ok {
	227	my $tb = Test::More->builder;
	228	$tb->croak("new_ok() must be given at least a class") unless @_;
	229
	230	my( $class, $args, $object_name ) = @_;
	231
	232	$args \|\|= [];
	233	$object_name = "The object" unless defined $object_name;
	234
	235	my $obj;
	236	my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
	237	if($success) {
	238	local $Test::Builder::Level = $Test::Builder::Level + 1;
	239	isa_ok $obj, $class, $object_name;
	240	}
	241	else {
	242	$tb->ok( 0, "new() died" );
	243	$tb->diag(" Error was: $error");
	244	}
	245
	246	return $obj;
	247	}
	248
	249	#line 719
	250
	251	sub subtest($&) {
	252	my ($name, $subtests) = @_;
	253
	254	my $tb = Test::More->builder;
	255	return $tb->subtest(@_);
	256	}
	257
	258	#line 743
	259
	260	sub pass (;$) {
	261	my $tb = Test::More->builder;
	262
	263	return $tb->ok( 1, @_ );
	264	}
	265
	266	sub fail (;$) {
	267	my $tb = Test::More->builder;
	268
	269	return $tb->ok( 0, @_ );
	270	}
	271
	272	#line 806
	273
	274	sub use_ok ($;@) {
	275	my( $module, @imports ) = @_;
	276	@imports = () unless @imports;
	277	my $tb = Test::More->builder;
	278
	279	my( $pack, $filename, $line ) = caller;
	280
	281	my $code;
	282	if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
	283	# probably a version check. Perl needs to see the bare number
	284	# for it to work with non-Exporter based modules.
	285	$code = <<USE;
	286	package $pack;
	287	use $module $imports[0];
	288	1;
	289	USE
	290	}
	291	else {
	292	$code = <<USE;
	293	package $pack;
	294	use $module \@{\$args[0]};
	295	1;
	296	USE
	297	}
	298
	299	my( $eval_result, $eval_error ) = _eval( $code, \@imports );
	300	my $ok = $tb->ok( $eval_result, "use $module;" );
	301
	302	unless($ok) {
	303	chomp $eval_error;
	304	$@ =~ s{^BEGIN failed--compilation aborted at .*$}
	305	{BEGIN failed--compilation aborted at $filename line $line.}m;
	306	$tb->diag(<<DIAGNOSTIC);
	307	Tried to use '$module'.
	308	Error: $eval_error
	309	DIAGNOSTIC
	310
	311	}
	312
	313	return $ok;
	314	}
	315
	316	sub _eval {
	317	my( $code, @args ) = @_;
	318
	319	# Work around oddities surrounding resetting of $@ by immediately
	320	# storing it.
	321	my( $sigdie, $eval_result, $eval_error );
	322	{
	323	local( $@, $!, $SIG{__DIE__} ); # isolate eval
	324	$eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
	325	$eval_error = $@;
	326	$sigdie = $SIG{__DIE__} \|\| undef;
	327	}
	328	# make sure that $code got a chance to set $SIG{__DIE__}
	329	$SIG{__DIE__} = $sigdie if defined $sigdie;
	330
	331	return( $eval_result, $eval_error );
	332	}
	333
	334	#line 875
	335
	336	sub require_ok ($) {
	337	my($module) = shift;
	338	my $tb = Test::More->builder;
	339
	340	my $pack = caller;
	341
	342	# Try to deterine if we've been given a module name or file.
	343	# Module names must be barewords, files not.
	344	$module = qq['$module'] unless _is_module_name($module);
	345
	346	my $code = <<REQUIRE;
	347	package $pack;
	348	require $module;
	349	1;
	350	REQUIRE
	351
	352	my( $eval_result, $eval_error ) = _eval($code);
	353	my $ok = $tb->ok( $eval_result, "require $module;" );
	354
	355	unless($ok) {
	356	chomp $eval_error;
	357	$tb->diag(<<DIAGNOSTIC);
	358	Tried to require '$module'.
	359	Error: $eval_error
	360	DIAGNOSTIC
	361
	362	}
	363
	364	return $ok;
	365	}
	366
	367	sub _is_module_name {
	368	my $module = shift;
	369
	370	# Module names start with a letter.
	371	# End with an alphanumeric.
	372	# The rest is an alphanumeric or ::
	373	$module =~ s/\b::\b//g;
	374
	375	return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
	376	}
	377
	378	#line 952
	379
	380	our( @Data_Stack, %Refs_Seen );
	381	my $DNE = bless [], 'Does::Not::Exist';
	382
	383	sub _dne {
	384	return ref $_[0] eq ref $DNE;
	385	}
	386
	387	## no critic (Subroutines::RequireArgUnpacking)
	388	sub is_deeply {
	389	my $tb = Test::More->builder;
	390
	391	unless( @_ == 2 or @_ == 3 ) {
	392	my $msg = <<'WARNING';
	393	is_deeply() takes two or three args, you gave %d.
	394	This usually means you passed an array or hash instead
	395	of a reference to it
	396	WARNING
	397	chop $msg; # clip off newline so carp() will put in line/file
	398
	399	_carp sprintf $msg, scalar @_;
	400
	401	return $tb->ok(0);
	402	}
	403
	404	my( $got, $expected, $name ) = @_;
	405
	406	$tb->_unoverload_str( \$expected, \$got );
	407
	408	my $ok;
	409	if( !ref $got and !ref $expected ) { # neither is a reference
	410	$ok = $tb->is_eq( $got, $expected, $name );
	411	}
	412	elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
	413	$ok = $tb->ok( 0, $name );
	414	$tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
	415	}
	416	else { # both references
	417	local @Data_Stack = ();
	418	if( _deep_check( $got, $expected ) ) {
	419	$ok = $tb->ok( 1, $name );
	420	}
	421	else {
	422	$ok = $tb->ok( 0, $name );
	423	$tb->diag( _format_stack(@Data_Stack) );
	424	}
	425	}
	426
	427	return $ok;
	428	}
	429
	430	sub _format_stack {
	431	my(@Stack) = @_;
	432
	433	my $var = '$FOO';
	434	my $did_arrow = 0;
	435	foreach my $entry (@Stack) {
	436	my $type = $entry->{type} \|\| '';
	437	my $idx = $entry->{'idx'};
	438	if( $type eq 'HASH' ) {
	439	$var .= "->" unless $did_arrow++;
	440	$var .= "{$idx}";
	441	}
	442	elsif( $type eq 'ARRAY' ) {
	443	$var .= "->" unless $did_arrow++;
	444	$var .= "[$idx]";
	445	}
	446	elsif( $type eq 'REF' ) {
	447	$var = "\${$var}";
	448	}
	449	}
	450
	451	my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
	452	my @vars = ();
	453	( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
	454	( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
	455
	456	my $out = "Structures begin differing at:\n";
	457	foreach my $idx ( 0 .. $#vals ) {
	458	my $val = $vals[$idx];
	459	$vals[$idx]
	460	= !defined $val ? 'undef'
	461	: _dne($val) ? "Does not exist"
	462	: ref $val ? "$val"
	463	: "'$val'";
	464	}
	465
	466	$out .= "$vars[0] = $vals[0]\n";
	467	$out .= "$vars[1] = $vals[1]\n";
	468
	469	$out =~ s/^/ /msg;
	470	return $out;
	471	}
	472
	473	sub _type {
	474	my $thing = shift;
	475
	476	return '' if !ref $thing;
	477
	478	for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
	479	return $type if UNIVERSAL::isa( $thing, $type );
	480	}
	481
	482	return '';
	483	}
	484
	485	#line 1112
	486
	487	sub diag {
	488	return Test::More->builder->diag(@_);
	489	}
	490
	491	sub note {
	492	return Test::More->builder->note(@_);
	493	}
	494
	495	#line 1138
	496
	497	sub explain {
	498	return Test::More->builder->explain(@_);
	499	}
	500
	501	#line 1204
	502
	503	## no critic (Subroutines::RequireFinalReturn)
	504	sub skip {
	505	my( $why, $how_many ) = @_;
	506	my $tb = Test::More->builder;
	507
	508	unless( defined $how_many ) {
	509	# $how_many can only be avoided when no_plan is in use.
	510	_carp "skip() needs to know \$how_many tests are in the block"
	511	unless $tb->has_plan eq 'no_plan';
	512	$how_many = 1;
	513	}
	514
	515	if( defined $how_many and $how_many =~ /\D/ ) {
	516	_carp
	517	"skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
	518	$how_many = 1;
	519	}
	520
	521	for( 1 .. $how_many ) {
	522	$tb->skip($why);
	523	}
	524
	525	no warnings 'exiting';
	526	last SKIP;
	527	}
	528
	529	#line 1288
	530
	531	sub todo_skip {
	532	my( $why, $how_many ) = @_;
	533	my $tb = Test::More->builder;
	534
	535	unless( defined $how_many ) {
	536	# $how_many can only be avoided when no_plan is in use.
	537	_carp "todo_skip() needs to know \$how_many tests are in the block"
	538	unless $tb->has_plan eq 'no_plan';
	539	$how_many = 1;
	540	}
	541
	542	for( 1 .. $how_many ) {
	543	$tb->todo_skip($why);
	544	}
	545
	546	no warnings 'exiting';
	547	last TODO;
	548	}
	549
	550	#line 1343
	551
	552	sub BAIL_OUT {
	553	my $reason = shift;
	554	my $tb = Test::More->builder;
	555
	556	$tb->BAIL_OUT($reason);
	557	}
	558
	559	#line 1382
	560
	561	#'#
	562	sub eq_array {
	563	local @Data_Stack = ();
	564	_deep_check(@_);
	565	}
	566
	567	sub _eq_array {
	568	my( $a1, $a2 ) = @_;
	569
	570	if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
	571	warn "eq_array passed a non-array ref";
	572	return 0;
	573	}
	574
	575	return 1 if $a1 eq $a2;
	576
	577	my $ok = 1;
	578	my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
	579	for( 0 .. $max ) {
	580	my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
	581	my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
	582
	583	push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
	584	$ok = _deep_check( $e1, $e2 );
	585	pop @Data_Stack if $ok;
	586
	587	last unless $ok;
	588	}
	589
	590	return $ok;
	591	}
	592
	593	sub _deep_check {
	594	my( $e1, $e2 ) = @_;
	595	my $tb = Test::More->builder;
	596
	597	my $ok = 0;
	598
	599	# Effectively turn %Refs_Seen into a stack. This avoids picking up
	600	# the same referenced used twice (such as [\$a, \$a]) to be considered
	601	# circular.
	602	local %Refs_Seen = %Refs_Seen;
	603
	604	{
	605	# Quiet uninitialized value warnings when comparing undefs.
	606	no warnings 'uninitialized';
	607
	608	$tb->_unoverload_str( \$e1, \$e2 );
	609
	610	# Either they're both references or both not.
	611	my $same_ref = !( !ref $e1 xor !ref $e2 );
	612	my $not_ref = ( !ref $e1 and !ref $e2 );
	613
	614	if( defined $e1 xor defined $e2 ) {
	615	$ok = 0;
	616	}
	617	elsif( !defined $e1 and !defined $e2 ) {
	618	# Shortcut if they're both defined.
	619	$ok = 1;
	620	}
	621	elsif( _dne($e1) xor _dne($e2) ) {
	622	$ok = 0;
	623	}
	624	elsif( $same_ref and( $e1 eq $e2 ) ) {
	625	$ok = 1;
	626	}
	627	elsif($not_ref) {
	628	push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
	629	$ok = 0;
	630	}
	631	else {
	632	if( $Refs_Seen{$e1} ) {
	633	return $Refs_Seen{$e1} eq $e2;
	634	}
	635	else {
	636	$Refs_Seen{$e1} = "$e2";
	637	}
	638
	639	my $type = _type($e1);
	640	$type = 'DIFFERENT' unless _type($e2) eq $type;
	641
	642	if( $type eq 'DIFFERENT' ) {
	643	push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
	644	$ok = 0;
	645	}
	646	elsif( $type eq 'ARRAY' ) {
	647	$ok = _eq_array( $e1, $e2 );
	648	}
	649	elsif( $type eq 'HASH' ) {
	650	$ok = _eq_hash( $e1, $e2 );
	651	}
	652	elsif( $type eq 'REF' ) {
	653	push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
	654	$ok = _deep_check( $$e1, $$e2 );
	655	pop @Data_Stack if $ok;
	656	}
	657	elsif( $type eq 'SCALAR' ) {
	658	push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
	659	$ok = _deep_check( $$e1, $$e2 );
	660	pop @Data_Stack if $ok;
	661	}
	662	elsif($type) {
	663	push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
	664	$ok = 0;
	665	}
	666	else {
	667	_whoa( 1, "No type in _deep_check" );
	668	}
	669	}
	670	}
	671
	672	return $ok;
	673	}
	674
	675	sub _whoa {
	676	my( $check, $desc ) = @_;
	677	if($check) {
	678	die <<"WHOA";
	679	WHOA! $desc
	680	This should never happen! Please contact the author immediately!
	681	WHOA
	682	}
	683	}
	684
	685	#line 1515
	686
	687	sub eq_hash {
	688	local @Data_Stack = ();
	689	return _deep_check(@_);
	690	}
	691
	692	sub _eq_hash {
	693	my( $a1, $a2 ) = @_;
	694
	695	if( grep _type($_) ne 'HASH', $a1, $a2 ) {
	696	warn "eq_hash passed a non-hash ref";
	697	return 0;
	698	}
	699
	700	return 1 if $a1 eq $a2;
	701
	702	my $ok = 1;
	703	my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
	704	foreach my $k ( keys %$bigger ) {
	705	my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
	706	my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
	707
	708	push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
	709	$ok = _deep_check( $e1, $e2 );
	710	pop @Data_Stack if $ok;
	711
	712	last unless $ok;
	713	}
	714
	715	return $ok;
	716	}
	717
	718	#line 1572
	719
	720	sub eq_set {
	721	my( $a1, $a2 ) = @_;
	722	return 0 unless @$a1 == @$a2;
	723
	724	no warnings 'uninitialized';
	725
	726	# It really doesn't matter how we sort them, as long as both arrays are
	727	# sorted with the same algorithm.
	728	#
	729	# Ensure that references are not accidentally treated the same as a
	730	# string containing the reference.
	731	#
	732	# Have to inline the sort routine due to a threading/sort bug.
	733	# See [rt.cpan.org 6782]
	734	#
	735	# I don't know how references would be sorted so we just don't sort
	736	# them. This means eq_set doesn't really work with refs.
	737	return eq_array(
	738	[ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
	739	[ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
	740	);
	741	}
	742
	743	#line 1774
	744
	745	1;

-2

lib/Convert/PEM/CBC.pm less more

0		# $Id: CBC.pm 1829 2005-05-25 21:51:40Z btrott $
1
2	0	package Convert::PEM::CBC;
3	1	use strict;
4	2

114	112	Passphrase => 'foo'
115	113	);
116	114
	115	my $plaintext = 'foo bar baz';
117	116	$cbc->encrypt($plaintext);
118	117
119	118	=head1 DESCRIPTION

+17

-9

lib/Convert/PEM.pm less more

0		# $Id: PEM.pm 1829 2005-05-25 21:51:40Z btrott $
1
2	0	package Convert::PEM;
3	1	use strict;
	2	use 5.008_001;
	3
4	4	use base qw( Class::ErrorHandler );
5	5
6	6	use MIME::Base64;

10	10	use Convert::PEM::CBC;
11	11
12	12	use vars qw( $VERSION );
13		$VERSION = '0.07';
	13	$VERSION = '0.08';
14	14
15	15	sub new {
16	16	my $class = shift;

134	134	sub explode {
135	135	my $pem = shift;
136	136	my($message) = @_;
	137
	138	# Canonicalize line endings into "\n".
	139	$message =~ s/\r\n\|\n\|\r/\n/g;
	140
137	141	my($head, $object, $headers, $content, $tail) = $message =~
138	142	m:(-----BEGIN ([^\n\-]+)-----)\n(.?\n\n)?(.+)(-----END .?-----)$:s;
139	143	my $buf = decode_base64($content);

224	228	}
225	229	));
226	230
	231	my $keyfile = 'private-key.pem';
	232	my $pwd = 'foobar';
	233
227	234	my $pkey = $pem->read(
228	235	Filename => $keyfile,
229	236	Password => $pwd

459	466	my $obj = $pem->read( Filename => "encrypted.pem" )
460	467	or die "Decryption failed: ", $pem->errstr;
461	468
	469	=head1 LICENSE
	470
	471	Convert::PEM is free software; you may redistribute it and/or modify
	472	it under the same terms as Perl itself.
	473
462	474	=head1 AUTHOR & COPYRIGHTS
463	475
464		Benjamin Trott, ben@rhumba.pair.com
465
466		Except where otherwise noted, Convert::PEM is Copyright 2001
467		Benjamin Trott. All rights reserved. Convert::PEM is free
468		software; you may redistribute it and/or modify it under
469		the same terms as Perl itself.
	476	Except where otherwise noted, Convert::PEM is Copyright Benjamin
	477	Trott, cpan@stupidfool.org. All rights reserved.
470	478
471	479	=cut

-7

t/00-compile.t less more

0		# $Id: 00-compile.t 85 2001-04-22 07:22:42Z btrott $
	0	use strict;
	1	use Test::More tests => 1;
1	2
2		my $loaded;
3		BEGIN { print "1..1\n" }
4		use Convert::PEM;
5		$loaded++;
6		print "ok 1\n";
7		END { print "not ok 1\n" unless $loaded }
	3	BEGIN { use_ok 'Convert::PEM' }

+19

-25

t/01-readwrite.t less more

0		# $Id: 01-readwrite.t 85 2001-04-22 07:22:42Z btrott $
	0	use strict;
	1	use Test::More tests => 16;
	2	use Test::Exception;
1	3
2		use strict;
3
4		use Test;
5	4	use Convert::PEM;
6	5	use Math::BigInt;
7
8		BEGIN { plan tests => 15 };
9	6
10	7	my $objfile = "./object.pem";
11	8

16	13	int INTEGER
17	14	}
18	15	));
19		ok($pem);
	16	isa_ok $pem, 'Convert::PEM';
20	17
21	18	my($obj, $obj2);
22	19	$obj = { TestObject => { int => 4 } };
23	20
24		ok($pem->write( Filename => $objfile, Content => $obj));
25		ok(-e $objfile);
26		$obj2 = $pem->read( Filename => $objfile );
27		ok($obj2);
28		ok($obj->{TestObject}{int}, $obj2->{TestObject}{int});
	21	lives_ok { $pem->write( Filename => $objfile, Content => $obj) } 'can write';
	22	ok -e $objfile, 'output file exists';
	23	lives_ok { $obj2 = $pem->read( Filename => $objfile ) } 'can read';
	24	is $obj->{TestObject}{int}, $obj2->{TestObject}{int}, 'input matches output';
29	25	unlink $objfile;
30	26
31		ok($pem->write( Filename => $objfile, Content => $obj, Password => 'xx' ));
32		ok(-e $objfile);
33		$obj2 = $pem->read( Filename => $objfile );
34		ok(!$obj2);
35		ok($pem->errstr =~ /^Decryption failed/);
36		$obj2 = $pem->read( Filename => $objfile, Password => 'xx');
37		ok($obj2);
38		ok($obj->{TestObject}{int}, $obj2->{TestObject}{int});
	27	lives_ok { $pem->write( Filename => $objfile, Content => $obj, Password => 'xx' ) } 'can write';
	28	ok -e $objfile, 'output file exists';
	29	lives_ok { $obj2 = $pem->read( Filename => $objfile ) } 'can read';
	30	ok !defined $obj2, 'cannot read encrypted file';
	31	like $pem->errstr, qr/^Decryption failed/, 'errstr matches decryption failed';
	32	lives_ok { $obj2 = $pem->read( Filename => $objfile, Password => 'xx') } 'can read';
	33	is $obj->{TestObject}{int}, $obj2->{TestObject}{int}, 'input matches output';
39	34	unlink $objfile;
40	35
41	36	$obj->{TestObject}{int} = Math::BigInt->new("110982309809809850938509");
42		ok($pem->write( Filename => $objfile, Content => $obj));
43		ok(-e $objfile);
44		$obj2 = $pem->read( Filename => $objfile );
45		ok($obj2);
46		ok($obj->{TestObject}{int}, $obj2->{TestObject}{int});
	37	lives_ok { $pem->write( Filename => $objfile, Content => $obj) } 'can write';
	38	ok -e $objfile, 'output file exists';
	39	lives_ok { $obj2 = $pem->read( Filename => $objfile ) } 'can read';
	40	is $obj->{TestObject}{int}, $obj2->{TestObject}{int}, 'input matches output';
47	41	unlink $objfile;

+13

-20

t/02-encode.t less more

0		# $Id: 02-encode.t 89 2001-04-22 08:01:45Z btrott $
	0	use strict;
	1	use Test::More tests => 9;
1	2
2		use strict;
3
4		use Test;
5	3	use Convert::PEM;
6	4	use Math::BigInt;
7
8		BEGIN { plan tests => 12 };
9	5
10	6	my $pem = Convert::PEM->new(
11	7	Name => 'TEST OBJECT',

14	10	int INTEGER
15	11	}
16	12	));
17		ok($pem);
	13	isa_ok $pem, 'Convert::PEM';
18	14
19	15	my($obj, $obj2, $blob);
20	16	$obj = { TestObject => { int => 4 } };
21	17
22		$blob = $pem->encode( Content => $obj);
23		ok($blob);
	18	$blob = $pem->encode( Content => $obj );
	19	ok $blob, 'encode gave us something';
24	20	$obj2 = $pem->decode( Content => $blob );
25		ok($obj2);
26		ok($obj->{TestObject}{int}, $obj2->{TestObject}{int});
	21	is $obj->{TestObject}{int}, $obj2->{TestObject}{int}, 'input matches output';
27	22
28	23	$blob = $pem->encode( Content => $obj, Password => 'xx' );
29		ok($blob);
	24	ok $blob, 'encode gave us something';
30	25	$obj2 = $pem->decode( Content => $blob );
31		ok(!$obj2);
32		ok($pem->errstr =~ /^Decryption failed/);
33		$obj2 = $pem->decode( Content => $blob, Password => 'xx');
34		ok($obj2);
35		ok($obj->{TestObject}{int}, $obj2->{TestObject}{int});
	26	ok !defined $obj2, 'decode fails on encrypted input';
	27	like $pem->errstr, qr/^Decryption failed/, 'errstr matches decrypt failed';
	28	$obj2 = $pem->decode( Content => $blob, Password => 'xx' );
	29	is $obj->{TestObject}{int}, $obj2->{TestObject}{int}, 'input matches output';
36	30
37	31	$obj->{TestObject}{int} = Math::BigInt->new("110982309809809850938509");
38	32	$blob = $pem->encode( Content => $obj );
39		ok($blob);
	33	ok $blob, 'encode gave us something';
40	34	$obj2 = $pem->decode( Content => $blob );
41		ok($obj2);
42		ok($obj->{TestObject}{int}, $obj2->{TestObject}{int});
	35	is $obj->{TestObject}{int}, $obj2->{TestObject}{int}, 'input matches output';

-12

t/03-ede3.t less more

0		# $Id: 03-ede3.t 86 2001-04-22 07:31:08Z btrott $
	0	use strict;
	1	use Test::More tests => 6;
1	2
2		use strict;
3
4		use Test;
5	3	use Convert::PEM::CBC;
6
7		BEGIN { plan tests => 6 };
8	4
9	5	my $KEY = pack "H64", ("0123456789ABCDEF" x 4);
10	6	my $IV = "\0" x 8;

16	12	Key => $KEY,
17	13	IV => $IV,
18	14	);
19		ok($cbc1);
	15	isa_ok $cbc1, 'Convert::PEM::CBC';
20	16
21	17	$cbc2 = Convert::PEM::CBC->new(
22	18	Cipher => 'Crypt::DES_EDE3',
23	19	Key => $KEY,
24	20	IV => $IV,
25	21	);
26		ok($cbc2);
	22	isa_ok $cbc2, 'Convert::PEM::CBC';
27	23
28	24	my($enc, $dec);
29	25	$enc = $cbc1->encrypt( _checkbytes() );
30		ok($enc);
	26	ok defined $enc, 'got something from encrypt';
31	27	$dec = $cbc2->decrypt($enc);
32		ok($dec);
	28	ok defined $dec, 'got something from decrypt';
33	29
34		ok( vec($dec, 0, 8) == vec($dec, 2, 8) );
35		ok( vec($dec, 1, 8) == vec($dec, 3, 8) );
	30	is vec($dec, 0, 8), vec($dec, 2, 8), 'input1 matches output1';
	31	is vec($dec, 1, 8), vec($dec, 3, 8), 'input2 matches output2';
36	32
37	33	sub _checkbytes {
38	34	my($check1, $check2) = (chr int rand 255, chr int rand 255);

+38

-0

t/04-explode.t less more

	0	use strict;
	1	use Test::More tests => 4;
	2
	3	use Convert::PEM;
	4
	5	my $pem = Convert::PEM->new(
	6	'Name' => 'TEST OBJECT',
	7	'ASN' => q(
	8	TestObject SEQUENCE {
	9	int INTEGER
	10	}
	11	)
	12	);
	13
	14	isa_ok( $pem, 'Convert::PEM' );
	15
	16	my %pemhash = (
	17	'Object' => 'TEST OBJECT',
	18	'Content' => 'Simple test content that is long enough to wrap in base64.',
	19	'Headers' =>
	20	[ [ 'A' => 'Alpha' ], [ 'B' => 'Bravo' ], [ 'C' => 'Charlie' ] ],
	21	);
	22
	23	my $pemData = $pem->implode( %pemhash );
	24
	25	my $pemUnix = my $pemDos = my $pemOldMac = $pemData;
	26	$pemUnix =~ s/\r\n\|\n\|\r/\n/g;
	27	$pemDos =~ s/\r\n\|\n\|\r/\r\n/g;
	28	$pemOldMac =~ s/\r\n\|\n\|\r/\r/g;
	29
	30	my $explodeUnix = $pem->explode( $pemUnix );
	31	is_deeply( $explodeUnix, \%pemhash, "explode with unix line break" );
	32
	33	my $explodeDos = $pem->explode( $pemDos );
	34	is_deeply( $explodeDos, \%pemhash, "explode with dos line break" );
	35
	36	my $explodeOldMac = $pem->explode( $pemOldMac );
	37	is_deeply( $explodeOldMac, \%pemhash, "explode with old mac line break" );

-0

xt/pod.t less more

	0	use Test::More;
	1	eval "use Test::Pod 1.00";
	2	plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
	3	all_pod_files_ok();

-0

xt/synopsis.t less more

	0	use Test::More;
	1	eval "use Test::Synopsis";
	2	plan skip_all => "Test::Synopsis required" if $@;
	3	all_synopsis_ok();