Commit 45d2be3f0ca0691ee8a02e8efaf8aea65f0c87ff - libhtml-selector-xpath-perl

[svn-upgrade] Integrating new upstream version, libhtml-selector-xpath-perl (0.04) Gregor Herrmann 14 years ago

22 changed file(s) with 1356 addition(s) and 4225 deletion(s). Raw diff Collapse all Expand all

-0

Changes less more

0	0	Revision history for Perl extension HTML::Selector::XPath
	1
	2	0.04 Sat Feb 27 01:43:00 PST 2010
	3	- No code change. Fix the packaging issue and typo in the doc
1	4
2	5	0.03 Sat Nov 10 20:26:47 PST 2007
3	6	* Added nth-child() support (Thanks to Tokuhiro Matsuno)

-8

MANIFEST less more

2	2	inc/Module/Install/Base.pm
3	3	inc/Module/Install/Can.pm
4	4	inc/Module/Install/Fetch.pm
5		inc/Module/Install/Include.pm
6	5	inc/Module/Install/Makefile.pm
7	6	inc/Module/Install/Metadata.pm
8		inc/Module/Install/TestBase.pm
9	7	inc/Module/Install/Win32.pm
10	8	inc/Module/Install/WriteAll.pm
11		inc/Spiffy.pm
12		inc/Test/Base.pm
13		inc/Test/Base/Filter.pm
14		inc/Test/Builder.pm
15		inc/Test/Builder/Module.pm
16		inc/Test/More.pm
17	9	lib/HTML/Selector/XPath.pm
18	10	Makefile.PL
19	11	MANIFEST This list of files

+20

-7

META.yml less more

0		abstract: CSS Selector to XPath compiler
1		author: Tatsuhiko Miyagawa <miyagawa@bulknews.net>
2		build_requires:
	0	---
	1	abstract: 'CSS Selector to XPath compiler'
	2	author:
	3	- 'Tatsuhiko Miyagawa <miyagawa@bulknews.net>'
	4	build_requires:
	5	ExtUtils::MakeMaker: 6.42
	6	Test::Base: 0
3	7	Test::More: 0
	8	configure_requires:
	9	ExtUtils::MakeMaker: 6.42
4	10	distribution_type: module
5		generated_by: Module::Install version 0.64
	11	generated_by: 'Module::Install version 0.92'
6	12	license: perl
	13	meta-spec:
	14	url: http://module-build.sourceforge.net/META-spec-v1.4.html
	15	version: 1.4
7	16	name: HTML-Selector-XPath
8		no_index:
9		directory:
	17	no_index:
	18	directory:
10	19	- inc
11	20	- t
12		version: 0.03
	21	requires:
	22	perl: 5.8.1
	23	resources:
	24	license: http://dev.perl.org/licenses/
	25	version: 0.04

-2

Makefile.PL less more

2	2	all_from 'lib/HTML/Selector/XPath.pm';
3	3
4	4	build_requires 'Test::More';
5		use_test_base;
6		auto_include;
	5	build_requires 'Test::Base';
7	6	WriteAll;

+34

-26

inc/Module/Install/Base.pm less more

0	0	#line 1
1	1	package Module::Install::Base;
2	2
3		$VERSION = '0.64';
	3	use strict 'vars';
	4	use vars qw{$VERSION};
	5	BEGIN {
	6	$VERSION = '0.92';
	7	}
4	8
5	9	# Suspend handler for "redefined" warnings
6	10	BEGIN {

8	12	$SIG{__WARN__} = sub { $w };
9	13	}
10	14
11		### This is the ONLY module that shouldn't have strict on
12		# use strict;
13
14		#line 41
	15	#line 42
15	16
16	17	sub new {
17		my ($class, %args) = @_;
18
19		foreach my $method ( qw(call load) ) {
20		*{"$class\::$method"} = sub {
21		shift()->_top->$method(@_);
22		} unless defined &{"$class\::$method"};
23		}
24
25		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;
26	26	}
27	27
28	28	#line 61
29	29
30	30	sub AUTOLOAD {
31		my $self = shift;
32		local $@;
33		my $autoload = eval { $self->_top->autoload } or return;
34		goto &$autoload;
	31	local $@;
	32	my $func = eval { shift->_top->autoload } or return;
	33	goto &$func;
35	34	}
36	35
37		#line 76
	36	#line 75
38	37
39		sub _top { $_[0]->{_top} }
	38	sub _top {
	39	$_[0]->{_top};
	40	}
40	41
41		#line 89
	42	#line 90
42	43
43	44	sub admin {
44		$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
	45	$_[0]->_top->{admin}
	46	or
	47	Module::Install::Base::FakeAdmin->new;
45	48	}
46	49
	50	#line 106
	51
47	52	sub is_admin {
48		$_[0]->admin->VERSION;
	53	$_[0]->admin->VERSION;
49	54	}
50	55
51	56	sub DESTROY {}
52	57
53	58	package Module::Install::Base::FakeAdmin;
54	59
55		my $Fake;
56		sub new { $Fake \|\|= bless(\@_, $_[0]) }
	60	my $fake;
	61
	62	sub new {
	63	$fake \|\|= bless(\@_, $_[0]);
	64	}
57	65
58	66	sub AUTOLOAD {}
59	67

66	74
67	75	1;
68	76
69		#line 138
	77	#line 154

-10

inc/Module/Install/Can.pm less more

1	1	package Module::Install::Can;
2	2
3	3	use strict;
4		use Module::Install::Base;
5		use Config ();
6		### This adds a 5.005 Perl version dependency.
7		### This is a bug and will be fixed.
8		use File::Spec ();
9		use ExtUtils::MakeMaker ();
	4	use Config ();
	5	use File::Spec ();
	6	use ExtUtils::MakeMaker ();
	7	use Module::Install::Base ();
10	8
11		use vars qw{$VERSION $ISCORE @ISA};
	9	use vars qw{$VERSION @ISA $ISCORE};
12	10	BEGIN {
13		$VERSION = '0.64';
	11	$VERSION = '0.92';
	12	@ISA = 'Module::Install::Base';
14	13	$ISCORE = 1;
15		@ISA = qw{Module::Install::Base};
16	14	}
17	15
18	16	# check if we can load some module

38	36	return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
39	37
40	38	for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
	39	next if $dir eq '';
41	40	my $abs = File::Spec->catfile($dir, $_[1]);
42	41	return $abs if (-x $abs or $abs = MM->maybe_command($abs));
43	42	}

78	77
79	78	__END__
80	79
81		#line 157
	80	#line 156

-6

inc/Module/Install/Fetch.pm less more

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

-34

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

0		#line 1
1		package Module::Install::Include;
2
3		use strict;
4		use Module::Install::Base;
5
6		use vars qw{$VERSION $ISCORE @ISA};
7		BEGIN {
8		$VERSION = '0.64';
9		$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
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		}
32
33		1;

+246

-154

inc/Module/Install/Makefile.pm less more

1	1	package Module::Install::Makefile;
2	2
3	3	use strict 'vars';
4		use Module::Install::Base;
5		use ExtUtils::MakeMaker ();
6
7		use vars qw{$VERSION $ISCORE @ISA};
	4	use ExtUtils::MakeMaker ();
	5	use Module::Install::Base ();
	6
	7	use vars qw{$VERSION @ISA $ISCORE};
8	8	BEGIN {
9		$VERSION = '0.64';
	9	$VERSION = '0.92';
	10	@ISA = 'Module::Install::Base';
10	11	$ISCORE = 1;
11		@ISA = qw{Module::Install::Base};
12	12	}
13	13
14	14	sub Makefile { $_[0] }

16	16	my %seen = ();
17	17
18	18	sub prompt {
19		shift;
20
21		# Infinite loop protection
22		my @c = caller();
23		if ( ++$seen{"$c[1]\|$c[2]\|$_[0]"} > 3 ) {
24		die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])";
25		}
26
27		# In automated testing, always use defaults
28		if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
29		local $ENV{PERL_MM_USE_DEFAULT} = 1;
30		goto &ExtUtils::MakeMaker::prompt;
31		} else {
32		goto &ExtUtils::MakeMaker::prompt;
33		}
	19	shift;
	20
	21	# Infinite loop protection
	22	my @c = caller();
	23	if ( ++$seen{"$c[1]\|$c[2]\|$_[0]"} > 3 ) {
	24	die "Caught an potential prompt infinite loop ($c[1]\|$c[2]\|$_[0])";
	25	}
	26
	27	# In automated testing, always use defaults
	28	if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
	29	local $ENV{PERL_MM_USE_DEFAULT} = 1;
	30	goto &ExtUtils::MakeMaker::prompt;
	31	} else {
	32	goto &ExtUtils::MakeMaker::prompt;
	33	}
	34	}
	35
	36	# Store a cleaned up version of the MakeMaker version,
	37	# since we need to behave differently in a variety of
	38	# ways based on the MM version.
	39	my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
	40
	41	# If we are passed a param, do a "newer than" comparison.
	42	# Otherwise, just return the MakeMaker version.
	43	sub makemaker {
	44	( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
34	45	}
35	46
36	47	sub makemaker_args {
37		my $self = shift;
38		my $args = ($self->{makemaker_args} \|\|= {});
39		%$args = ( %$args, @_ ) if @_;
40		$args;
	48	my $self = shift;
	49	my $args = ( $self->{makemaker_args} \|\|= {} );
	50	%$args = ( %$args, @_ );
	51	return $args;
41	52	}
42	53
43	54	# For mm args that take multiple space-seperated args,
44	55	# append an argument to the current list.
45	56	sub makemaker_append {
46		my $self = shift;
47		my $name = shift;
48		my $args = $self->makemaker_args;
49		$args->{name} = defined $args->{$name}
50		? join( ' ', $args->{name}, @_ )
51		: join( ' ', @_ );
	57	my $self = shift;
	58	my $name = shift;
	59	my $args = $self->makemaker_args;
	60	$args->{name} = defined $args->{$name}
	61	? join( ' ', $args->{name}, @_ )
	62	: join( ' ', @_ );
52	63	}
53	64
54	65	sub build_subdirs {
55		my $self = shift;
56		my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
57		for my $subdir (@_) {
58		push @$subdirs, $subdir;
59		}
	66	my $self = shift;
	67	my $subdirs = $self->makemaker_args->{DIR} \|\|= [];
	68	for my $subdir (@_) {
	69	push @$subdirs, $subdir;
	70	}
60	71	}
61	72
62	73	sub clean_files {
63		my $self = shift;
64		my $clean = $self->makemaker_args->{clean} \|\|= {};
65		%$clean = (
66		%$clean,
67		FILES => join(' ', grep length, $clean->{FILES}, @_),
68		);
	74	my $self = shift;
	75	my $clean = $self->makemaker_args->{clean} \|\|= {};
	76	%$clean = (
	77	%$clean,
	78	FILES => join ' ', grep { length $_ } ($clean->{FILES} \|\| (), @_),
	79	);
69	80	}
70	81
71	82	sub realclean_files {
72		my $self = shift;
73		my $realclean = $self->makemaker_args->{realclean} \|\|= {};
74		%$realclean = (
75		%$realclean,
76		FILES => join(' ', grep length, $realclean->{FILES}, @_),
77		);
	83	my $self = shift;
	84	my $realclean = $self->makemaker_args->{realclean} \|\|= {};
	85	%$realclean = (
	86	%$realclean,
	87	FILES => join ' ', grep { length $_ } ($realclean->{FILES} \|\| (), @_),
	88	);
78	89	}
79	90
80	91	sub libs {
81		my $self = shift;
82		my $libs = ref $_[0] ? shift : [ shift ];
83		$self->makemaker_args( LIBS => $libs );
	92	my $self = shift;
	93	my $libs = ref $_[0] ? shift : [ shift ];
	94	$self->makemaker_args( LIBS => $libs );
84	95	}
85	96
86	97	sub inc {
87		my $self = shift;
88		$self->makemaker_args( INC => shift );
	98	my $self = shift;
	99	$self->makemaker_args( INC => shift );
	100	}
	101
	102	my %test_dir = ();
	103
	104	sub _wanted_t {
	105	/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
	106	}
	107
	108	sub tests_recursive {
	109	my $self = shift;
	110	if ( $self->tests ) {
	111	die "tests_recursive will not work if tests are already defined";
	112	}
	113	my $dir = shift \|\| 't';
	114	unless ( -d $dir ) {
	115	die "tests_recursive dir '$dir' does not exist";
	116	}
	117	%test_dir = ();
	118	require File::Find;
	119	File::Find::find( \&_wanted_t, $dir );
	120	$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
89	121	}
90	122
91	123	sub write {
92		my $self = shift;
93		die "&Makefile->write() takes no arguments\n" if @_;
94
95		my $args = $self->makemaker_args;
96		$args->{DISTNAME} = $self->name;
97		$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);
98		$args->{VERSION} = $self->version \|\| $self->determine_VERSION($args);
99		$args->{NAME} =~ s/-/::/g;
100		if ( $self->tests ) {
101		$args->{test} = { TESTS => $self->tests };
102		}
103		if ($] >= 5.005) {
104		$args->{ABSTRACT} = $self->abstract;
105		$args->{AUTHOR} = $self->author;
106		}
107		if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
108		$args->{NO_META} = 1;
109		}
110		if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
111		$args->{SIGN} = 1;
112		}
113		unless ( $self->is_admin ) {
114		delete $args->{SIGN};
115		}
116
117		# merge both kinds of requires into prereq_pm
118		my $prereq = ($args->{PREREQ_PM} \|\|= {});
119		%$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
120		($self->build_requires, $self->requires) );
121
122		# merge both kinds of requires into prereq_pm
123		my $subdirs = ($args->{DIR} \|\|= []);
124		if ($self->bundles) {
125		foreach my $bundle (@{ $self->bundles }) {
126		my ($file, $dir) = @$bundle;
127		push @$subdirs, $dir if -d $dir;
128		delete $prereq->{$file};
129		}
130		}
131
132		if ( my $perl_version = $self->perl_version ) {
133		eval "use $perl_version; 1"
134		or die "ERROR: perl: Version $] is installed, "
135		. "but we need version >= $perl_version";
136		}
137
138		my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
139		if ($self->admin->preop) {
140		$args{dist} = $self->admin->preop;
141		}
142
143		my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
144		$self->fix_up_makefile($mm->{FIRST_MAKEFILE} \|\| 'Makefile');
	124	my $self = shift;
	125	die "&Makefile->write() takes no arguments\n" if @_;
	126
	127	# Check the current Perl version
	128	my $perl_version = $self->perl_version;
	129	if ( $perl_version ) {
	130	eval "use $perl_version; 1"
	131	or die "ERROR: perl: Version $] is installed, "
	132	. "but we need version >= $perl_version";
	133	}
	134
	135	# Make sure we have a new enough MakeMaker
	136	require ExtUtils::MakeMaker;
	137
	138	if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
	139	# MakeMaker can complain about module versions that include
	140	# an underscore, even though its own version may contain one!
	141	# Hence the funny regexp to get rid of it. See RT #35800
	142	# for details.
	143	my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
	144	$self->build_requires( 'ExtUtils::MakeMaker' => $v );
	145	$self->configure_requires( 'ExtUtils::MakeMaker' => $v );
	146	} else {
	147	# Allow legacy-compatibility with 5.005 by depending on the
	148	# most recent EU:MM that supported 5.005.
	149	$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
	150	$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
	151	}
	152
	153	# Generate the MakeMaker params
	154	my $args = $self->makemaker_args;
	155	$args->{DISTNAME} = $self->name;
	156	$args->{NAME} = $self->module_name \|\| $self->name;
	157	$args->{VERSION} = $self->version;
	158	$args->{NAME} =~ s/-/::/g;
	159	if ( $self->tests ) {
	160	$args->{test} = { TESTS => $self->tests };
	161	}
	162	if ( $] >= 5.005 ) {
	163	$args->{ABSTRACT} = $self->abstract;
	164	$args->{AUTHOR} = $self->author;
	165	}
	166	if ( $self->makemaker(6.10) ) {
	167	$args->{NO_META} = 1;
	168	}
	169	if ( $self->makemaker(6.17) and $self->sign ) {
	170	$args->{SIGN} = 1;
	171	}
	172	unless ( $self->is_admin ) {
	173	delete $args->{SIGN};
	174	}
	175
	176	my $prereq = ($args->{PREREQ_PM} \|\|= {});
	177	%$prereq = ( %$prereq,
	178	map { @$_ } # flatten [module => version]
	179	map { @$_ }
	180	grep $_,
	181	($self->requires)
	182	);
	183
	184	# Remove any reference to perl, PREREQ_PM doesn't support it
	185	delete $args->{PREREQ_PM}->{perl};
	186
	187	# Merge both kinds of requires into BUILD_REQUIRES
	188	my $build_prereq = ($args->{BUILD_REQUIRES} \|\|= {});
	189	%$build_prereq = ( %$build_prereq,
	190	map { @$_ } # flatten [module => version]
	191	map { @$_ }
	192	grep $_,
	193	($self->configure_requires, $self->build_requires)
	194	);
	195
	196	# Remove any reference to perl, BUILD_REQUIRES doesn't support it
	197	delete $args->{BUILD_REQUIRES}->{perl};
	198
	199	# Delete bundled dists from prereq_pm
	200	my $subdirs = ($args->{DIR} \|\|= []);
	201	if ($self->bundles) {
	202	foreach my $bundle (@{ $self->bundles }) {
	203	my ($file, $dir) = @$bundle;
	204	push @$subdirs, $dir if -d $dir;
	205	delete $build_prereq->{$file}; #Delete from build prereqs only
	206	}
	207	}
	208
	209	unless ( $self->makemaker('6.55_03') ) {
	210	%$prereq = (%$prereq,%$build_prereq);
	211	delete $args->{BUILD_REQUIRES};
	212	}
	213
	214	if ( my $perl_version = $self->perl_version ) {
	215	eval "use $perl_version; 1"
	216	or die "ERROR: perl: Version $] is installed, "
	217	. "but we need version >= $perl_version";
	218
	219	if ( $self->makemaker(6.48) ) {
	220	$args->{MIN_PERL_VERSION} = $perl_version;
	221	}
	222	}
	223
	224	$args->{INSTALLDIRS} = $self->installdirs;
	225
	226	my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
	227
	228	my $user_preop = delete $args{dist}->{PREOP};
	229	if (my $preop = $self->admin->preop($user_preop)) {
	230	foreach my $key ( keys %$preop ) {
	231	$args{dist}->{$key} = $preop->{$key};
	232	}
	233	}
	234
	235	my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
	236	$self->fix_up_makefile($mm->{FIRST_MAKEFILE} \|\| 'Makefile');
145	237	}
146	238
147	239	sub fix_up_makefile {
148		my $self = shift;
149		my $makefile_name = shift;
150		my $top_class = ref($self->_top) \|\| '';
151		my $top_version = $self->_top->VERSION \|\| '';
152
153		my $preamble = $self->preamble
154		? "# Preamble by $top_class $top_version\n"
155		. $self->preamble
156		: '';
157		my $postamble = "# Postamble by $top_class $top_version\n"
158		. ($self->postamble \|\| '');
159
160		local *MAKEFILE;
161		open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
162		my $makefile = do { local $/; <MAKEFILE> };
163		close MAKEFILE or die $!;
164
165		$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
166		$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
167		$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
168		$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
169		$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
170
171		# Module::Install will never be used to build the Core Perl
172		# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
173		# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
174		$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
175		#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
176
177		# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
178		$makefile =~ s/("?)-I\$$PERL_LIB$\1//g;
179
180		# XXX - This is currently unused; not sure if it breaks other MM-users
181		# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
182
183		open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
184		print MAKEFILE "$preamble$makefile$postamble" or die $!;
185		close MAKEFILE or die $!;
186
187		1;
	240	my $self = shift;
	241	my $makefile_name = shift;
	242	my $top_class = ref($self->_top) \|\| '';
	243	my $top_version = $self->_top->VERSION \|\| '';
	244
	245	my $preamble = $self->preamble
	246	? "# Preamble by $top_class $top_version\n"
	247	. $self->preamble
	248	: '';
	249	my $postamble = "# Postamble by $top_class $top_version\n"
	250	. ($self->postamble \|\| '');
	251
	252	local *MAKEFILE;
	253	open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	254	my $makefile = do { local $/; <MAKEFILE> };
	255	close MAKEFILE or die $!;
	256
	257	$makefile =~ s/\b(test_harness$\$\(TEST_VERBOSE$, )/$1'inc', /;
	258	$makefile =~ s/( -I\$$INST_ARCHLIB$)/ -Iinc$1/g;
	259	$makefile =~ s/( "-I\$$INST_LIB$")/ "-Iinc"$1/g;
	260	$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
	261	$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
	262
	263	# Module::Install will never be used to build the Core Perl
	264	# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
	265	# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
	266	$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
	267	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
	268
	269	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
	270	$makefile =~ s/(\"?)-I\$$PERL_LIB$\1//g;
	271
	272	# XXX - This is currently unused; not sure if it breaks other MM-users
	273	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
	274
	275	open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	276	print MAKEFILE "$preamble$makefile$postamble" or die $!;
	277	close MAKEFILE or die $!;
	278
	279	1;
188	280	}
189	281
190	282	sub preamble {
191		my ($self, $text) = @_;
192		$self->{preamble} = $text . $self->{preamble} if defined $text;
193		$self->{preamble};
	283	my ($self, $text) = @_;
	284	$self->{preamble} = $text . $self->{preamble} if defined $text;
	285	$self->{preamble};
194	286	}
195	287
196	288	sub postamble {
197		my ($self, $text) = @_;
198		$self->{postamble} \|\|= $self->admin->postamble;
199		$self->{postamble} .= $text if defined $text;
200		$self->{postamble}
	289	my ($self, $text) = @_;
	290	$self->{postamble} \|\|= $self->admin->postamble;
	291	$self->{postamble} .= $text if defined $text;
	292	$self->{postamble}
201	293	}
202	294
203	295	1;
204	296
205	297	__END__
206	298
207		#line 334
	299	#line 426

+606

-274

inc/Module/Install/Metadata.pm less more

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

-26

~~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		}
22
23		1;
24
25		#line 67

-8

inc/Module/Install/Win32.pm less more

1	1	package Module::Install::Win32;
2	2
3	3	use strict;
4		use Module::Install::Base;
	4	use Module::Install::Base ();
5	5
6		use vars qw{$VERSION $ISCORE @ISA};
	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.64';
	8	$VERSION = '0.92';
	9	@ISA = 'Module::Install::Base';
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	# determine if the user needs nmake, and download it if needed

15	15	my $self = shift;
16	16	$self->load('can_run');
17	17	$self->load('get_file');
18
	18
19	19	require Config;
20	20	return unless (
21	21	$^O eq 'MSWin32' and

37	37	remove => 1,
38	38	);
39	39
40		if (!$rv) {
41		die <<'END_MESSAGE';
	40	die <<'END_MESSAGE' unless $rv;
42	41
43	42	-------------------------------------------------------------------------------
44	43

58	57
59	58	-------------------------------------------------------------------------------
60	59	END_MESSAGE
61		}
	60
62	61	}
63	62
64	63	1;

+45

-28

inc/Module/Install/WriteAll.pm less more

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

+354

-190

inc/Module/Install.pm less more

16	16	# 3. The ./inc/ version of Module::Install loads
17	17	# }
18	18
19		use 5.004;
	19	use 5.005;
20	20	use strict 'vars';
21	21
22		use vars qw{$VERSION};
	22	use vars qw{$VERSION $MAIN};
23	23	BEGIN {
24		# All Module::Install core packages now require synchronised versions.
25		# This will be used to ensure we don't accidentally load old or
26		# different versions of modules.
27		# This is not enforced yet, but will be some time in the next few
28		# releases once we can make sure it won't clash with custom
29		# Module::Install extensions.
30		$VERSION = '0.64';
31		}
	24	# All Module::Install core packages now require synchronised versions.
	25	# This will be used to ensure we don't accidentally load old or
	26	# different versions of modules.
	27	# This is not enforced yet, but will be some time in the next few
	28	# releases once we can make sure it won't clash with custom
	29	# Module::Install extensions.
	30	$VERSION = '0.92';
	31
	32	# Storage for the pseudo-singleton
	33	$MAIN = undef;
	34
	35	inc::Module::Install::VERSION = VERSION;
	36	@inc::Module::Install::ISA = __PACKAGE__;
	37
	38	}
	39
	40
	41
	42
32	43
33	44	# Whether or not inc::Module::Install is actually loaded, the
34	45	# $INC{inc/Module/Install.pm} is what will still get set as long as

37	48	# they may not have a MI version that works with the Makefile.PL. This would
38	49	# result in false errors or unexpected behaviour. And we don't want that.
39	50	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
40		unless ( $INC{$file} ) {
41		die <<"END_DIE";
	51	unless ( $INC{$file} ) { die <<"END_DIE" }
	52
42	53	Please invoke ${\__PACKAGE__} with:
43	54
44		use inc::${\__PACKAGE__};
	55	use inc::${\__PACKAGE__};
45	56
46	57	not:
47	58
48		use ${\__PACKAGE__};
	59	use ${\__PACKAGE__};
49	60
50	61	END_DIE
51		}
	62
	63
	64
	65
52	66
53	67	# If the script that is loading Module::Install is from the future,
54	68	# then make will detect this and cause it to re-run over and over
55	69	# again. This is bad. Rather than taking action to touch it (which
56	70	# is unreliable on some platforms and requires write permissions)
57	71	# for now we should catch this and refuse to run.
58		if ( -f $0 and (stat($0))[9] > time ) {
59		die << "END_DIE";
60		Your installer $0 has a modification time in the future.
	72	if ( -f $0 ) {
	73	my $s = (stat($0))[9];
	74
	75	# If the modification time is only slightly in the future,
	76	# sleep briefly to remove the problem.
	77	my $a = $s - time;
	78	if ( $a > 0 and $a < 5 ) { sleep 5 }
	79
	80	# Too far in the future, throw an error.
	81	my $t = time;
	82	if ( $s > $t ) { die <<"END_DIE" }
	83
	84	Your installer $0 has a modification time in the future ($s > $t).
61	85
62	86	This is known to create infinite loops in make.
63	87

65	89
66	90	END_DIE
67	91	}
	92
	93
	94
	95
	96
	97	# Build.PL was formerly supported, but no longer is due to excessive
	98	# difficulty in implementing every single feature twice.
	99	if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
	100
	101	Module::Install no longer supports Build.PL.
	102
	103	It was impossible to maintain duel backends, and has been deprecated.
	104
	105	Please remove all Build.PL files and only use the Makefile.PL installer.
	106
	107	END_DIE
	108
	109
	110
	111
	112
	113	# To save some more typing in Module::Install installers, every...
	114	# use inc::Module::Install
	115	# ...also acts as an implicit use strict.
	116	$^H \|= strict::bits(qw(refs subs vars));
	117
	118
	119
	120
68	121
69	122	use Cwd ();
70	123	use File::Find ();
71	124	use File::Path ();
72	125	use FindBin;
73	126
74		inc::Module::Install::VERSION = VERSION;
75		@inc::Module::Install::ISA = __PACKAGE__;
76
77	127	sub autoload {
78		my $self = shift;
79		my $who = $self->_caller;
80		my $cwd = Cwd::cwd();
81		my $sym = "${who}::AUTOLOAD";
82		$sym->{$cwd} = sub {
83		my $pwd = Cwd::cwd();
84		if ( my $code = $sym->{$pwd} ) {
85		# delegate back to parent dirs
86		goto &$code unless $cwd eq $pwd;
87		}
88		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
89		unshift @_, ($self, $1);
90		goto &{$self->can('call')} unless uc($1) eq $1;
91		};
	128	my $self = shift;
	129	my $who = $self->_caller;
	130	my $cwd = Cwd::cwd();
	131	my $sym = "${who}::AUTOLOAD";
	132	$sym->{$cwd} = sub {
	133	my $pwd = Cwd::cwd();
	134	if ( my $code = $sym->{$pwd} ) {
	135	# Delegate back to parent dirs
	136	goto &$code unless $cwd eq $pwd;
	137	}
	138	$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
	139	my $method = $1;
	140	if ( uc($method) eq $method ) {
	141	# Do nothing
	142	return;
	143	} elsif ( $method =~ /^_/ and $self->can($method) ) {
	144	# Dispatch to the root M:I class
	145	return $self->$method(@_);
	146	}
	147
	148	# Dispatch to the appropriate plugin
	149	unshift @_, ( $self, $1 );
	150	goto &{$self->can('call')};
	151	};
92	152	}
93	153
94	154	sub import {
95		my $class = shift;
96		my $self = $class->new(@_);
97		my $who = $self->_caller;
98
99		unless ( -f $self->{file} ) {
100		require "$self->{path}/$self->{dispatch}.pm";
101		File::Path::mkpath("$self->{prefix}/$self->{author}");
102		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
103		$self->{admin}->init;
104		@_ = ($class, _self => $self);
105		goto &{"$self->{name}::import"};
106		}
107
108		*{"${who}::AUTOLOAD"} = $self->autoload;
109		$self->preload;
110
111		# Unregister loader and worker packages so subdirs can use them again
112		delete $INC{"$self->{file}"};
113		delete $INC{"$self->{path}.pm"};
	155	my $class = shift;
	156	my $self = $class->new(@_);
	157	my $who = $self->_caller;
	158
	159	unless ( -f $self->{file} ) {
	160	require "$self->{path}/$self->{dispatch}.pm";
	161	File::Path::mkpath("$self->{prefix}/$self->{author}");
	162	$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
	163	$self->{admin}->init;
	164	@_ = ($class, _self => $self);
	165	goto &{"$self->{name}::import"};
	166	}
	167
	168	*{"${who}::AUTOLOAD"} = $self->autoload;
	169	$self->preload;
	170
	171	# Unregister loader and worker packages so subdirs can use them again
	172	delete $INC{"$self->{file}"};
	173	delete $INC{"$self->{path}.pm"};
	174
	175	# Save to the singleton
	176	$MAIN = $self;
	177
	178	return 1;
114	179	}
115	180
116	181	sub preload {
117		my ($self) = @_;
118
119		unless ( $self->{extensions} ) {
120		$self->load_extensions(
121		"$self->{prefix}/$self->{path}", $self
122		);
123		}
124
125		my @exts = @{$self->{extensions}};
126		unless ( @exts ) {
127		my $admin = $self->{admin};
128		@exts = $admin->load_all_extensions;
129		}
130
131		my %seen;
132		foreach my $obj ( @exts ) {
133		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
134		next unless $obj->can($method);
135		next if $method =~ /^_/;
136		next if $method eq uc($method);
137		$seen{$method}++;
138		}
139		}
140
141		my $who = $self->_caller;
142		foreach my $name ( sort keys %seen ) {
143		*{"${who}::$name"} = sub {
144		${"${who}::AUTOLOAD"} = "${who}::$name";
145		goto &{"${who}::AUTOLOAD"};
146		};
147		}
	182	my $self = shift;
	183	unless ( $self->{extensions} ) {
	184	$self->load_extensions(
	185	"$self->{prefix}/$self->{path}", $self
	186	);
	187	}
	188
	189	my @exts = @{$self->{extensions}};
	190	unless ( @exts ) {
	191	@exts = $self->{admin}->load_all_extensions;
	192	}
	193
	194	my %seen;
	195	foreach my $obj ( @exts ) {
	196	while (my ($method, $glob) = each %{ref($obj) . '::'}) {
	197	next unless $obj->can($method);
	198	next if $method =~ /^_/;
	199	next if $method eq uc($method);
	200	$seen{$method}++;
	201	}
	202	}
	203
	204	my $who = $self->_caller;
	205	foreach my $name ( sort keys %seen ) {
	206	*{"${who}::$name"} = sub {
	207	${"${who}::AUTOLOAD"} = "${who}::$name";
	208	goto &{"${who}::AUTOLOAD"};
	209	};
	210	}
148	211	}
149	212
150	213	sub new {
151		my ($class, %args) = @_;
152
153		# ignore the prefix on extension modules built from top level.
154		my $base_path = Cwd::abs_path($FindBin::Bin);
155		unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
156		delete $args{prefix};
157		}
158
159		return $args{_self} if $args{_self};
160
161		$args{dispatch} \|\|= 'Admin';
162		$args{prefix} \|\|= 'inc';
163		$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
164		$args{bundle} \|\|= 'inc/BUNDLES';
165		$args{base} \|\|= $base_path;
166		$class =~ s/^\Q$args{prefix}\E:://;
167		$args{name} \|\|= $class;
168		$args{version} \|\|= $class->VERSION;
169		unless ( $args{path} ) {
170		$args{path} = $args{name};
171		$args{path} =~ s!::!/!g;
172		}
173		$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
174
175		bless( \%args, $class );
	214	my ($class, %args) = @_;
	215
	216	# ignore the prefix on extension modules built from top level.
	217	my $base_path = Cwd::abs_path($FindBin::Bin);
	218	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
	219	delete $args{prefix};
	220	}
	221
	222	return $args{_self} if $args{_self};
	223
	224	$args{dispatch} \|\|= 'Admin';
	225	$args{prefix} \|\|= 'inc';
	226	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
	227	$args{bundle} \|\|= 'inc/BUNDLES';
	228	$args{base} \|\|= $base_path;
	229	$class =~ s/^\Q$args{prefix}\E:://;
	230	$args{name} \|\|= $class;
	231	$args{version} \|\|= $class->VERSION;
	232	unless ( $args{path} ) {
	233	$args{path} = $args{name};
	234	$args{path} =~ s!::!/!g;
	235	}
	236	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
	237	$args{wrote} = 0;
	238
	239	bless( \%args, $class );
176	240	}
177	241
178	242	sub call {

183	247	}
184	248
185	249	sub load {
186		my ($self, $method) = @_;
187
188		$self->load_extensions(
189		"$self->{prefix}/$self->{path}", $self
190		) unless $self->{extensions};
191
192		foreach my $obj (@{$self->{extensions}}) {
193		return $obj if $obj->can($method);
194		}
195
196		my $admin = $self->{admin} or die <<"END_DIE";
	250	my ($self, $method) = @_;
	251
	252	$self->load_extensions(
	253	"$self->{prefix}/$self->{path}", $self
	254	) unless $self->{extensions};
	255
	256	foreach my $obj (@{$self->{extensions}}) {
	257	return $obj if $obj->can($method);
	258	}
	259
	260	my $admin = $self->{admin} or die <<"END_DIE";
197	261	The '$method' method does not exist in the '$self->{prefix}' path!
198	262	Please remove the '$self->{prefix}' directory and run $0 again to load it.
199	263	END_DIE
200	264
201		my $obj = $admin->load($method, 1);
202		push @{$self->{extensions}}, $obj;
203
204		$obj;
	265	my $obj = $admin->load($method, 1);
	266	push @{$self->{extensions}}, $obj;
	267
	268	$obj;
205	269	}
206	270
207	271	sub load_extensions {
208		my ($self, $path, $top) = @_;
209
210		unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
211		unshift @INC, $self->{prefix};
212		}
213
214		foreach my $rv ( $self->find_extensions($path) ) {
215		my ($file, $pkg) = @{$rv};
216		next if $self->{pathnames}{$pkg};
217
218		local $@;
219		my $new = eval { require $file; $pkg->can('new') };
220		unless ( $new ) {
221		warn $@ if $@;
222		next;
223		}
224		$self->{pathnames}{$pkg} = delete $INC{$file};
225		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
226		}
227
228		$self->{extensions} \|\|= [];
	272	my ($self, $path, $top) = @_;
	273
	274	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
	275	unshift @INC, $self->{prefix};
	276	}
	277
	278	foreach my $rv ( $self->find_extensions($path) ) {
	279	my ($file, $pkg) = @{$rv};
	280	next if $self->{pathnames}{$pkg};
	281
	282	local $@;
	283	my $new = eval { require $file; $pkg->can('new') };
	284	unless ( $new ) {
	285	warn $@ if $@;
	286	next;
	287	}
	288	$self->{pathnames}{$pkg} = delete $INC{$file};
	289	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	290	}
	291
	292	$self->{extensions} \|\|= [];
229	293	}
230	294
231	295	sub find_extensions {
232		my ($self, $path) = @_;
233
234		my @found;
235		File::Find::find( sub {
236		my $file = $File::Find::name;
237		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
238		my $subpath = $1;
239		return if lc($subpath) eq lc($self->{dispatch});
240
241		$file = "$self->{path}/$subpath.pm";
242		my $pkg = "$self->{name}::$subpath";
243		$pkg =~ s!/!::!g;
244
245		# If we have a mixed-case package name, assume case has been preserved
246		# correctly. Otherwise, root through the file to locate the case-preserved
247		# version of the package name.
248		if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
249		open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
250		my $in_pod = 0;
251		while ( <PKGFILE> ) {
252		$in_pod = 1 if /^=\w/;
253		$in_pod = 0 if /^=cut/;
254		next if ($in_pod \|\| /^=cut/); # skip pod text
255		next if /^\s*#/; # and comments
256		if ( m/^\spackage\s+($pkg)\s;/i ) {
257		$pkg = $1;
258		last;
259		}
260		}
261		close PKGFILE;
262		}
263
264		push @found, [ $file, $pkg ];
265		}, $path ) if -d $path;
266
267		@found;
268		}
	296	my ($self, $path) = @_;
	297
	298	my @found;
	299	File::Find::find( sub {
	300	my $file = $File::Find::name;
	301	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
	302	my $subpath = $1;
	303	return if lc($subpath) eq lc($self->{dispatch});
	304
	305	$file = "$self->{path}/$subpath.pm";
	306	my $pkg = "$self->{name}::$subpath";
	307	$pkg =~ s!/!::!g;
	308
	309	# If we have a mixed-case package name, assume case has been preserved
	310	# correctly. Otherwise, root through the file to locate the case-preserved
	311	# version of the package name.
	312	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
	313	my $content = Module::Install::_read($subpath . '.pm');
	314	my $in_pod = 0;
	315	foreach ( split //, $content ) {
	316	$in_pod = 1 if /^=\w/;
	317	$in_pod = 0 if /^=cut/;
	318	next if ($in_pod \|\| /^=cut/); # skip pod text
	319	next if /^\s*#/; # and comments
	320	if ( m/^\spackage\s+($pkg)\s;/i ) {
	321	$pkg = $1;
	322	last;
	323	}
	324	}
	325	}
	326
	327	push @found, [ $file, $pkg ];
	328	}, $path ) if -d $path;
	329
	330	@found;
	331	}
	332
	333
	334
	335
	336
	337	#####################################################################
	338	# Common Utility Functions
269	339
270	340	sub _caller {
271		my $depth = 0;
272		my $call = caller($depth);
273		while ( $call eq __PACKAGE__ ) {
274		$depth++;
275		$call = caller($depth);
276		}
277		return $call;
	341	my $depth = 0;
	342	my $call = caller($depth);
	343	while ( $call eq __PACKAGE__ ) {
	344	$depth++;
	345	$call = caller($depth);
	346	}
	347	return $call;
	348	}
	349
	350	# Done in evals to avoid confusing Perl::MinimumVersion
	351	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
	352	sub _read {
	353	local *FH;
	354	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
	355	my $string = do { local $/; <FH> };
	356	close FH or die "close($_[0]): $!";
	357	return $string;
	358	}
	359	END_NEW
	360	sub _read {
	361	local *FH;
	362	open( FH, "< $_[0]" ) or die "open($_[0]): $!";
	363	my $string = do { local $/; <FH> };
	364	close FH or die "close($_[0]): $!";
	365	return $string;
	366	}
	367	END_OLD
	368
	369	sub _readperl {
	370	my $string = Module::Install::_read($_[0]);
	371	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
	372	$string =~ s/(\n)\n__(?:DATA\|END)__\b.\z/$1/s;
	373	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
	374	return $string;
	375	}
	376
	377	sub _readpod {
	378	my $string = Module::Install::_read($_[0]);
	379	$string =~ s/(?:\015{1,2}\012\|\015\|\012)/\n/sg;
	380	return $string if $_[0] =~ /\.pod\z/;
	381	$string =~ s/(^\|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+\|\z)/$1$2/sg;
	382	$string =~ s/\n=pod\b[^\n]\n+/\n\n/sg;
	383	$string =~ s/\n=cut\b[^\n]\n+/\n\n/sg;
	384	$string =~ s/^\n+//s;
	385	return $string;
	386	}
	387
	388	# Done in evals to avoid confusing Perl::MinimumVersion
	389	eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
	390	sub _write {
	391	local *FH;
	392	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
	393	foreach ( 1 .. $#_ ) {
	394	print FH $_[$_] or die "print($_[0]): $!";
	395	}
	396	close FH or die "close($_[0]): $!";
	397	}
	398	END_NEW
	399	sub _write {
	400	local *FH;
	401	open( FH, "> $_[0]" ) or die "open($_[0]): $!";
	402	foreach ( 1 .. $#_ ) {
	403	print FH $_[$_] or die "print($_[0]): $!";
	404	}
	405	close FH or die "close($_[0]): $!";
	406	}
	407	END_OLD
	408
	409	# _version is for processing module versions (eg, 1.03_05) not
	410	# Perl versions (eg, 5.8.1).
	411	sub _version ($) {
	412	my $s = shift \|\| 0;
	413	my $d =()= $s =~ /(\.)/g;
	414	if ( $d >= 2 ) {
	415	# Normalise multipart versions
	416	$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
	417	}
	418	$s =~ s/^(\d+)\.?//;
	419	my $l = $1 \|\| 0;
	420	my @v = map {
	421	$_ . '0' x (3 - length $_)
	422	} $s =~ /(\d{1,3})\D?/g;
	423	$l = $l . '.' . join '', @v if @v;
	424	return $l + 0;
	425	}
	426
	427	sub _cmp ($$) {
	428	_version($_[0]) <=> _version($_[1]);
	429	}
	430
	431	# Cloned from Params::Util::_CLASS
	432	sub _CLASS ($) {
	433	(
	434	defined $_[0]
	435	and
	436	! ref $_[0]
	437	and
	438	$_[0] =~ m/^[^\W\d]\w(?:::\w+)\z/s
	439	) ? $_[0] : undef;
278	440	}
279	441
280	442	1;
	443
	444	# Copyright 2008 - 2010 Adam Kennedy.

-539

~~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

-343

~~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 =~ s/\015\012/\n/g;
218		$text =~ s/\r/\n/g;
219		return $text;
220		}
221
222		sub prepend {
223		my $prefix = $self->current_arguments;
224		map { $prefix . $_ } @_;
225		}
226
227		sub read_file {
228		$self->assert_scalar(@_);
229		my $file = shift;
230		CORE::chomp $file;
231		open my $fh, $file
232		or die "Can't open '$file' for input:\n$!";
233		CORE::join '', <$fh>;
234		}
235
236		sub regexp {
237		$self->assert_scalar(@_);
238		my $text = shift;
239		my $flags = $self->current_arguments;
240		if ($text =~ /\n.*?\n/s) {
241		$flags = 'xism'
242		unless defined $flags;
243		}
244		else {
245		CORE::chomp($text);
246		}
247		$flags \|\|= '';
248		my $regexp = eval "qr{$text}$flags";
249		die $@ if $@;
250		return $regexp;
251		}
252
253		sub reverse {
254		CORE::reverse(@_);
255		}
256
257		sub slice {
258		die "Invalid args for slice"
259		unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
260		my ($x, $y) = ($1, $2);
261		$y = $x if not defined $y;
262		die "Invalid args for slice"
263		if $x > $y;
264		return splice(@_, $x, 1 + $y - $x);
265		}
266
267		sub sort {
268		CORE::sort(@_);
269		}
270
271		sub split {
272		$self->assert_scalar(@_);
273		my $separator = $self->current_arguments;
274		if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
275		my $regexp = $1;
276		$separator = qr{$regexp};
277		}
278		$separator = qr/\s+/ unless $separator;
279		CORE::split $separator, shift;
280		}
281
282		sub strict {
283		$self->assert_scalar(@_);
284		<<'...' . shift;
285		use strict;
286		use warnings;
287		...
288		}
289
290		sub tail {
291		my $size = $self->current_arguments \|\| 1;
292		return splice(@_, @_ - $size, $size);
293		}
294
295		sub trim {
296		map {
297		s/\A([ \t]*\n)+//;
298		s/(?<=\n)\s*\z//g;
299		$_;
300		} @_;
301		}
302
303		sub unchomp {
304		map { $_ . "\n" } @_;
305		}
306
307		sub write_file {
308		my $file = $self->current_arguments
309		or die "No file specified for write_file filter";
310		if ($file =~ /(.*)[\\\/]/) {
311		my $dir = $1;
312		if (not -e $dir) {
313		require File::Path;
314		File::Path::mkpath($dir)
315		or die "Can't create $dir";
316		}
317		}
318		open my $fh, ">$file"
319		or die "Can't open '$file' for output\n:$!";
320		print $fh @_;
321		close $fh;
322		return $file;
323		}
324
325		sub yaml {
326		$self->assert_scalar(@_);
327		require YAML;
328		return YAML::Load(shift);
329		}
330
331		sub _write_to {
332		my $filename = shift;
333		open my $script, ">$filename"
334		or die "Couldn't open $filename: $!\n";
335		print $script @_;
336		close $script
337		or die "Couldn't close $filename: $!\n";
338		}
339
340		__DATA__
341
342		#line 638

-639

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

-82

~~inc/Test/Builder/Module.pm~~ less more

0		#line 1
1		package Test::Builder::Module;
2
3		use Test::Builder;
4
5		require Exporter;
6		@ISA = qw(Exporter);
7
8		$VERSION = '0.72';
9
10		use strict;
11
12		# 5.004's Exporter doesn't have export_to_level.
13		my $_export_to_level = sub {
14		my $pkg = shift;
15		my $level = shift;
16		(undef) = shift; # redundant arg
17		my $callpkg = caller($level);
18		$pkg->export($callpkg, @_);
19		};
20
21
22		#line 82
23
24		sub import {
25		my($class) = shift;
26
27		my $test = $class->builder;
28
29		my $caller = caller;
30
31		$test->exported_to($caller);
32
33		$class->import_extra(\@_);
34		my(@imports) = $class->_strip_imports(\@_);
35
36		$test->plan(@_);
37
38		$class->$_export_to_level(1, $class, @imports);
39		}
40
41
42		sub _strip_imports {
43		my $class = shift;
44		my $list = shift;
45
46		my @imports = ();
47		my @other = ();
48		my $idx = 0;
49		while( $idx <= $#{$list} ) {
50		my $item = $list->[$idx];
51
52		if( defined $item and $item eq 'import' ) {
53		push @imports, @{$list->[$idx+1]};
54		$idx++;
55		}
56		else {
57		push @other, $item;
58		}
59
60		$idx++;
61		}
62
63		@$list = @other;
64
65		return @imports;
66		}
67
68
69		#line 144
70
71		sub import_extra {}
72
73
74		#line 175
75
76		sub builder {
77		return Test::Builder->new;
78		}
79
80
81		1;

-1175

~~inc/Test/Builder.pm~~ less more

0		#line 1
1		package Test::Builder;
2
3		use 5.004;
4
5		# $^C was only introduced in 5.005-ish. We do this to prevent
6		# use of uninitialized value warnings in older perls.
7		$^C \|\|= 0;
8
9		use strict;
10		use vars qw($VERSION);
11		$VERSION = '0.72';
12		$VERSION = eval $VERSION; # make the alpha version come out as a number
13
14		# Make Test::Builder thread-safe for ithreads.
15		BEGIN {
16		use Config;
17		# Load threads::shared when threads are turned on.
18		# 5.8.0's threads are so busted we no longer support them.
19		if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
20		require threads::shared;
21
22		# Hack around YET ANOTHER threads::shared bug. It would
23		# occassionally forget the contents of the variable when sharing it.
24		# So we first copy the data, then share, then put our copy back.
25		*share = sub (\[$@%]) {
26		my $type = ref $_[0];
27		my $data;
28
29		if( $type eq 'HASH' ) {
30		%$data = %{$_[0]};
31		}
32		elsif( $type eq 'ARRAY' ) {
33		@$data = @{$_[0]};
34		}
35		elsif( $type eq 'SCALAR' ) {
36		$$data = ${$_[0]};
37		}
38		else {
39		die("Unknown type: ".$type);
40		}
41
42		$_[0] = &threads::shared::share($_[0]);
43
44		if( $type eq 'HASH' ) {
45		%{$_[0]} = %$data;
46		}
47		elsif( $type eq 'ARRAY' ) {
48		@{$_[0]} = @$data;
49		}
50		elsif( $type eq 'SCALAR' ) {
51		${$_[0]} = $$data;
52		}
53		else {
54		die("Unknown type: ".$type);
55		}
56
57		return $_[0];
58		};
59		}
60		# 5.8.0's threads::shared is busted when threads are off
61		# and earlier Perls just don't have that module at all.
62		else {
63		*share = sub { return $_[0] };
64		*lock = sub { 0 };
65		}
66		}
67
68
69		#line 128
70
71		my $Test = Test::Builder->new;
72		sub new {
73		my($class) = shift;
74		$Test \|\|= $class->create;
75		return $Test;
76		}
77
78
79		#line 150
80
81		sub create {
82		my $class = shift;
83
84		my $self = bless {}, $class;
85		$self->reset;
86
87		return $self;
88		}
89
90		#line 169
91
92		use vars qw($Level);
93
94		sub reset {
95		my ($self) = @_;
96
97		# We leave this a global because it has to be localized and localizing
98		# hash keys is just asking for pain. Also, it was documented.
99		$Level = 1;
100
101		$self->{Test_Died} = 0;
102		$self->{Have_Plan} = 0;
103		$self->{No_Plan} = 0;
104		$self->{Original_Pid} = $$;
105
106		share($self->{Curr_Test});
107		$self->{Curr_Test} = 0;
108		$self->{Test_Results} = &share([]);
109
110		$self->{Exported_To} = undef;
111		$self->{Expected_Tests} = 0;
112
113		$self->{Skip_All} = 0;
114
115		$self->{Use_Nums} = 1;
116
117		$self->{No_Header} = 0;
118		$self->{No_Ending} = 0;
119
120		$self->_dup_stdhandles unless $^C;
121
122		return undef;
123		}
124
125		#line 221
126
127		sub exported_to {
128		my($self, $pack) = @_;
129
130		if( defined $pack ) {
131		$self->{Exported_To} = $pack;
132		}
133		return $self->{Exported_To};
134		}
135
136		#line 243
137
138		sub plan {
139		my($self, $cmd, $arg) = @_;
140
141		return unless $cmd;
142
143		local $Level = $Level + 1;
144
145		if( $self->{Have_Plan} ) {
146		$self->croak("You tried to plan twice");
147		}
148
149		if( $cmd eq 'no_plan' ) {
150		$self->no_plan;
151		}
152		elsif( $cmd eq 'skip_all' ) {
153		return $self->skip_all($arg);
154		}
155		elsif( $cmd eq 'tests' ) {
156		if( $arg ) {
157		local $Level = $Level + 1;
158		return $self->expected_tests($arg);
159		}
160		elsif( !defined $arg ) {
161		$self->croak("Got an undefined number of tests");
162		}
163		elsif( !$arg ) {
164		$self->croak("You said to run 0 tests");
165		}
166		}
167		else {
168		my @args = grep { defined } ($cmd, $arg);
169		$self->croak("plan() doesn't understand @args");
170		}
171
172		return 1;
173		}
174
175		#line 290
176
177		sub expected_tests {
178		my $self = shift;
179		my($max) = @_;
180
181		if( @_ ) {
182		$self->croak("Number of tests must be a positive integer. You gave it '$max'")
183		unless $max =~ /^\+?\d+$/ and $max > 0;
184
185		$self->{Expected_Tests} = $max;
186		$self->{Have_Plan} = 1;
187
188		$self->_print("1..$max\n") unless $self->no_header;
189		}
190		return $self->{Expected_Tests};
191		}
192
193
194		#line 315
195
196		sub no_plan {
197		my $self = shift;
198
199		$self->{No_Plan} = 1;
200		$self->{Have_Plan} = 1;
201		}
202
203		#line 330
204
205		sub has_plan {
206		my $self = shift;
207
208		return($self->{Expected_Tests}) if $self->{Expected_Tests};
209		return('no_plan') if $self->{No_Plan};
210		return(undef);
211		};
212
213
214		#line 348
215
216		sub skip_all {
217		my($self, $reason) = @_;
218
219		my $out = "1..0";
220		$out .= " # Skip $reason" if $reason;
221		$out .= "\n";
222
223		$self->{Skip_All} = 1;
224
225		$self->_print($out) unless $self->no_header;
226		exit(0);
227		}
228
229		#line 382
230
231		sub ok {
232		my($self, $test, $name) = @_;
233
234		# $test might contain an object which we don't want to accidentally
235		# store, so we turn it into a boolean.
236		$test = $test ? 1 : 0;
237
238		$self->_plan_check;
239
240		lock $self->{Curr_Test};
241		$self->{Curr_Test}++;
242
243		# In case $name is a string overloaded object, force it to stringify.
244		$self->_unoverload_str(\$name);
245
246		$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
247		You named your test '$name'. You shouldn't use numbers for your test names.
248		Very confusing.
249		ERR
250
251		my($pack, $file, $line) = $self->caller;
252
253		my $todo = $self->todo($pack);
254		$self->_unoverload_str(\$todo);
255
256		my $out;
257		my $result = &share({});
258
259		unless( $test ) {
260		$out .= "not ";
261		@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
262		}
263		else {
264		@$result{ 'ok', 'actual_ok' } = ( 1, $test );
265		}
266
267		$out .= "ok";
268		$out .= " $self->{Curr_Test}" if $self->use_numbers;
269
270		if( defined $name ) {
271		$name =~ s\|#\|\\#\|g; # # in a name can confuse Test::Harness.
272		$out .= " - $name";
273		$result->{name} = $name;
274		}
275		else {
276		$result->{name} = '';
277		}
278
279		if( $todo ) {
280		$out .= " # TODO $todo";
281		$result->{reason} = $todo;
282		$result->{type} = 'todo';
283		}
284		else {
285		$result->{reason} = '';
286		$result->{type} = '';
287		}
288
289		$self->{Test_Results}[$self->{Curr_Test}-1] = $result;
290		$out .= "\n";
291
292		$self->_print($out);
293
294		unless( $test ) {
295		my $msg = $todo ? "Failed (TODO)" : "Failed";
296		$self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
297
298		if( defined $name ) {
299		$self->diag(qq[ $msg test '$name'\n]);
300		$self->diag(qq[ at $file line $line.\n]);
301		}
302		else {
303		$self->diag(qq[ $msg test at $file line $line.\n]);
304		}
305		}
306
307		return $test ? 1 : 0;
308		}
309
310
311		sub _unoverload {
312		my $self = shift;
313		my $type = shift;
314
315		$self->_try(sub { require overload } ) \|\| return;
316
317		foreach my $thing (@_) {
318		if( $self->_is_object($$thing) ) {
319		if( my $string_meth = overload::Method($$thing, $type) ) {
320		$$thing = $$thing->$string_meth();
321		}
322		}
323		}
324		}
325
326
327		sub _is_object {
328		my($self, $thing) = @_;
329
330		return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
331		}
332
333
334		sub _unoverload_str {
335		my $self = shift;
336
337		$self->_unoverload(q[""], @_);
338		}
339
340		sub _unoverload_num {
341		my $self = shift;
342
343		$self->_unoverload('0+', @_);
344
345		for my $val (@_) {
346		next unless $self->_is_dualvar($$val);
347		$$val = $$val+0;
348		}
349		}
350
351
352		# This is a hack to detect a dualvar such as $!
353		sub _is_dualvar {
354		my($self, $val) = @_;
355
356		local $^W = 0;
357		my $numval = $val+0;
358		return 1 if $numval != 0 and $numval ne $val;
359		}
360
361
362
363		#line 530
364
365		sub is_eq {
366		my($self, $got, $expect, $name) = @_;
367		local $Level = $Level + 1;
368
369		$self->_unoverload_str(\$got, \$expect);
370
371		if( !defined $got \|\| !defined $expect ) {
372		# undef only matches undef and nothing else
373		my $test = !defined $got && !defined $expect;
374
375		$self->ok($test, $name);
376		$self->_is_diag($got, 'eq', $expect) unless $test;
377		return $test;
378		}
379
380		return $self->cmp_ok($got, 'eq', $expect, $name);
381		}
382
383		sub is_num {
384		my($self, $got, $expect, $name) = @_;
385		local $Level = $Level + 1;
386
387		$self->_unoverload_num(\$got, \$expect);
388
389		if( !defined $got \|\| !defined $expect ) {
390		# undef only matches undef and nothing else
391		my $test = !defined $got && !defined $expect;
392
393		$self->ok($test, $name);
394		$self->_is_diag($got, '==', $expect) unless $test;
395		return $test;
396		}
397
398		return $self->cmp_ok($got, '==', $expect, $name);
399		}
400
401		sub _is_diag {
402		my($self, $got, $type, $expect) = @_;
403
404		foreach my $val (\$got, \$expect) {
405		if( defined $$val ) {
406		if( $type eq 'eq' ) {
407		# quote and force string context
408		$$val = "'$$val'"
409		}
410		else {
411		# force numeric context
412		$self->_unoverload_num($val);
413		}
414		}
415		else {
416		$$val = 'undef';
417		}
418		}
419
420		return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
421		got: %s
422		expected: %s
423		DIAGNOSTIC
424
425		}
426
427		#line 608
428
429		sub isnt_eq {
430		my($self, $got, $dont_expect, $name) = @_;
431		local $Level = $Level + 1;
432
433		if( !defined $got \|\| !defined $dont_expect ) {
434		# undef only matches undef and nothing else
435		my $test = defined $got \|\| defined $dont_expect;
436
437		$self->ok($test, $name);
438		$self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
439		return $test;
440		}
441
442		return $self->cmp_ok($got, 'ne', $dont_expect, $name);
443		}
444
445		sub isnt_num {
446		my($self, $got, $dont_expect, $name) = @_;
447		local $Level = $Level + 1;
448
449		if( !defined $got \|\| !defined $dont_expect ) {
450		# undef only matches undef and nothing else
451		my $test = defined $got \|\| defined $dont_expect;
452
453		$self->ok($test, $name);
454		$self->_cmp_diag($got, '!=', $dont_expect) unless $test;
455		return $test;
456		}
457
458		return $self->cmp_ok($got, '!=', $dont_expect, $name);
459		}
460
461
462		#line 660
463
464		sub like {
465		my($self, $this, $regex, $name) = @_;
466
467		local $Level = $Level + 1;
468		$self->_regex_ok($this, $regex, '=~', $name);
469		}
470
471		sub unlike {
472		my($self, $this, $regex, $name) = @_;
473
474		local $Level = $Level + 1;
475		$self->_regex_ok($this, $regex, '!~', $name);
476		}
477
478
479		#line 685
480
481
482		my %numeric_cmps = map { ($_, 1) }
483		("<", "<=", ">", ">=", "==", "!=", "<=>");
484
485		sub cmp_ok {
486		my($self, $got, $type, $expect, $name) = @_;
487
488		# Treat overloaded objects as numbers if we're asked to do a
489		# numeric comparison.
490		my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
491		: '_unoverload_str';
492
493		$self->$unoverload(\$got, \$expect);
494
495
496		my $test;
497		{
498		local($@,$!,$SIG{__DIE__}); # isolate eval
499
500		my $code = $self->_caller_context;
501
502		# Yes, it has to look like this or 5.4.5 won't see the #line directive.
503		# Don't ask me, man, I just work here.
504		$test = eval "
505		$code" . "\$got $type \$expect;";
506
507		}
508		local $Level = $Level + 1;
509		my $ok = $self->ok($test, $name);
510
511		unless( $ok ) {
512		if( $type =~ /^(eq\|==)$/ ) {
513		$self->_is_diag($got, $type, $expect);
514		}
515		else {
516		$self->_cmp_diag($got, $type, $expect);
517		}
518		}
519		return $ok;
520		}
521
522		sub _cmp_diag {
523		my($self, $got, $type, $expect) = @_;
524
525		$got = defined $got ? "'$got'" : 'undef';
526		$expect = defined $expect ? "'$expect'" : 'undef';
527		return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
528		%s
529		%s
530		%s
531		DIAGNOSTIC
532		}
533
534
535		sub _caller_context {
536		my $self = shift;
537
538		my($pack, $file, $line) = $self->caller(1);
539
540		my $code = '';
541		$code .= "#line $line $file\n" if defined $file and defined $line;
542
543		return $code;
544		}
545
546		#line 771
547
548		sub BAIL_OUT {
549		my($self, $reason) = @_;
550
551		$self->{Bailed_Out} = 1;
552		$self->_print("Bail out! $reason");
553		exit 255;
554		}
555
556		#line 784
557
558		*BAILOUT = \&BAIL_OUT;
559
560
561		#line 796
562
563		sub skip {
564		my($self, $why) = @_;
565		$why \|\|= '';
566		$self->_unoverload_str(\$why);
567
568		$self->_plan_check;
569
570		lock($self->{Curr_Test});
571		$self->{Curr_Test}++;
572
573		$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
574		'ok' => 1,
575		actual_ok => 1,
576		name => '',
577		type => 'skip',
578		reason => $why,
579		});
580
581		my $out = "ok";
582		$out .= " $self->{Curr_Test}" if $self->use_numbers;
583		$out .= " # skip";
584		$out .= " $why" if length $why;
585		$out .= "\n";
586
587		$self->_print($out);
588
589		return 1;
590		}
591
592
593		#line 838
594
595		sub todo_skip {
596		my($self, $why) = @_;
597		$why \|\|= '';
598
599		$self->_plan_check;
600
601		lock($self->{Curr_Test});
602		$self->{Curr_Test}++;
603
604		$self->{Test_Results}[$self->{Curr_Test}-1] = &share({
605		'ok' => 1,
606		actual_ok => 0,
607		name => '',
608		type => 'todo_skip',
609		reason => $why,
610		});
611
612		my $out = "not ok";
613		$out .= " $self->{Curr_Test}" if $self->use_numbers;
614		$out .= " # TODO & SKIP $why\n";
615
616		$self->_print($out);
617
618		return 1;
619		}
620
621
622		#line 916
623
624
625		sub maybe_regex {
626		my ($self, $regex) = @_;
627		my $usable_regex = undef;
628
629		return $usable_regex unless defined $regex;
630
631		my($re, $opts);
632
633		# Check for qr/foo/
634		if( ref $regex eq 'Regexp' ) {
635		$usable_regex = $regex;
636		}
637		# Check for '/foo/' or 'm,foo,'
638		elsif( ($re, $opts) = $regex =~ m{^ /(.)/ (\w) $ }sx or
639		(undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
640		)
641		{
642		$usable_regex = length $opts ? "(?$opts)$re" : $re;
643		}
644
645		return $usable_regex;
646		};
647
648		sub _regex_ok {
649		my($self, $this, $regex, $cmp, $name) = @_;
650
651		my $ok = 0;
652		my $usable_regex = $self->maybe_regex($regex);
653		unless (defined $usable_regex) {
654		$ok = $self->ok( 0, $name );
655		$self->diag(" '$regex' doesn't look much like a regex to me.");
656		return $ok;
657		}
658
659		{
660		my $test;
661		my $code = $self->_caller_context;
662
663		local($@, $!, $SIG{__DIE__}); # isolate eval
664
665		# Yes, it has to look like this or 5.4.5 won't see the #line directive.
666		# Don't ask me, man, I just work here.
667		$test = eval "
668		$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
669
670		$test = !$test if $cmp eq '!~';
671
672		local $Level = $Level + 1;
673		$ok = $self->ok( $test, $name );
674		}
675
676		unless( $ok ) {
677		$this = defined $this ? "'$this'" : 'undef';
678		my $match = $cmp eq '=~' ? "doesn't match" : "matches";
679		$self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
680		%s
681		%13s '%s'
682		DIAGNOSTIC
683
684		}
685
686		return $ok;
687		}
688
689
690		# I'm not ready to publish this. It doesn't deal with array return
691		# values from the code or context.
692
693		#line 1000
694
695		sub _try {
696		my($self, $code) = @_;
697
698		local $!; # eval can mess up $!
699		local $@; # don't set $@ in the test
700		local $SIG{__DIE__}; # don't trip an outside DIE handler.
701		my $return = eval { $code->() };
702
703		return wantarray ? ($return, $@) : $return;
704		}
705
706		#line 1022
707
708		sub is_fh {
709		my $self = shift;
710		my $maybe_fh = shift;
711		return 0 unless defined $maybe_fh;
712
713		return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
714		return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
715
716		return eval { $maybe_fh->isa("IO::Handle") } \|\|
717		# 5.5.4's tied() and can() doesn't like getting undef
718		eval { (tied($maybe_fh) \|\| '')->can('TIEHANDLE') };
719		}
720
721
722		#line 1067
723
724		sub level {
725		my($self, $level) = @_;
726
727		if( defined $level ) {
728		$Level = $level;
729		}
730		return $Level;
731		}
732
733
734		#line 1100
735
736		sub use_numbers {
737		my($self, $use_nums) = @_;
738
739		if( defined $use_nums ) {
740		$self->{Use_Nums} = $use_nums;
741		}
742		return $self->{Use_Nums};
743		}
744
745
746		#line 1134
747
748		foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
749		my $method = lc $attribute;
750
751		my $code = sub {
752		my($self, $no) = @_;
753
754		if( defined $no ) {
755		$self->{$attribute} = $no;
756		}
757		return $self->{$attribute};
758		};
759
760		no strict 'refs';
761		*{__PACKAGE__.'::'.$method} = $code;
762		}
763
764
765		#line 1188
766
767		sub diag {
768		my($self, @msgs) = @_;
769
770		return if $self->no_diag;
771		return unless @msgs;
772
773		# Prevent printing headers when compiling (i.e. -c)
774		return if $^C;
775
776		# Smash args together like print does.
777		# Convert undef to 'undef' so its readable.
778		my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
779
780		# Escape each line with a #.
781		$msg =~ s/^/# /gm;
782
783		# Stick a newline on the end if it needs it.
784		$msg .= "\n" unless $msg =~ /\n\Z/;
785
786		local $Level = $Level + 1;
787		$self->_print_diag($msg);
788
789		return 0;
790		}
791
792		#line 1225
793
794		sub _print {
795		my($self, @msgs) = @_;
796
797		# Prevent printing headers when only compiling. Mostly for when
798		# tests are deparsed with B::Deparse
799		return if $^C;
800
801		my $msg = join '', @msgs;
802
803		local($\, $", $,) = (undef, ' ', '');
804		my $fh = $self->output;
805
806		# Escape each line after the first with a # so we don't
807		# confuse Test::Harness.
808		$msg =~ s/\n(.)/\n# $1/sg;
809
810		# Stick a newline on the end if it needs it.
811		$msg .= "\n" unless $msg =~ /\n\Z/;
812
813		print $fh $msg;
814		}
815
816		#line 1259
817
818		sub _print_diag {
819		my $self = shift;
820
821		local($\, $", $,) = (undef, ' ', '');
822		my $fh = $self->todo ? $self->todo_output : $self->failure_output;
823		print $fh @_;
824		}
825
826		#line 1296
827
828		sub output {
829		my($self, $fh) = @_;
830
831		if( defined $fh ) {
832		$self->{Out_FH} = $self->_new_fh($fh);
833		}
834		return $self->{Out_FH};
835		}
836
837		sub failure_output {
838		my($self, $fh) = @_;
839
840		if( defined $fh ) {
841		$self->{Fail_FH} = $self->_new_fh($fh);
842		}
843		return $self->{Fail_FH};
844		}
845
846		sub todo_output {
847		my($self, $fh) = @_;
848
849		if( defined $fh ) {
850		$self->{Todo_FH} = $self->_new_fh($fh);
851		}
852		return $self->{Todo_FH};
853		}
854
855
856		sub _new_fh {
857		my $self = shift;
858		my($file_or_fh) = shift;
859
860		my $fh;
861		if( $self->is_fh($file_or_fh) ) {
862		$fh = $file_or_fh;
863		}
864		else {
865		$fh = do { local *FH };
866		open $fh, ">$file_or_fh" or
867		$self->croak("Can't open test output log $file_or_fh: $!");
868		_autoflush($fh);
869		}
870
871		return $fh;
872		}
873
874
875		sub _autoflush {
876		my($fh) = shift;
877		my $old_fh = select $fh;
878		$\| = 1;
879		select $old_fh;
880		}
881
882
883		sub _dup_stdhandles {
884		my $self = shift;
885
886		$self->_open_testhandles;
887
888		# Set everything to unbuffered else plain prints to STDOUT will
889		# come out in the wrong order from our own prints.
890		_autoflush(\*TESTOUT);
891		_autoflush(\*STDOUT);
892		_autoflush(\*TESTERR);
893		_autoflush(\*STDERR);
894
895		$self->output(\*TESTOUT);
896		$self->failure_output(\*TESTERR);
897		$self->todo_output(\*TESTOUT);
898		}
899
900
901		my $Opened_Testhandles = 0;
902		sub _open_testhandles {
903		return if $Opened_Testhandles;
904		# We dup STDOUT and STDERR so people can change them in their
905		# test suites while still getting normal test output.
906		open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
907		open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
908		$Opened_Testhandles = 1;
909		}
910
911
912		#line 1396
913
914		sub _message_at_caller {
915		my $self = shift;
916
917		local $Level = $Level + 1;
918		my($pack, $file, $line) = $self->caller;
919		return join("", @_) . " at $file line $line.\n";
920		}
921
922		sub carp {
923		my $self = shift;
924		warn $self->_message_at_caller(@_);
925		}
926
927		sub croak {
928		my $self = shift;
929		die $self->_message_at_caller(@_);
930		}
931
932		sub _plan_check {
933		my $self = shift;
934
935		unless( $self->{Have_Plan} ) {
936		local $Level = $Level + 2;
937		$self->croak("You tried to run a test without a plan");
938		}
939		}
940
941		#line 1444
942
943		sub current_test {
944		my($self, $num) = @_;
945
946		lock($self->{Curr_Test});
947		if( defined $num ) {
948		unless( $self->{Have_Plan} ) {
949		$self->croak("Can't change the current test number without a plan!");
950		}
951
952		$self->{Curr_Test} = $num;
953
954		# If the test counter is being pushed forward fill in the details.
955		my $test_results = $self->{Test_Results};
956		if( $num > @$test_results ) {
957		my $start = @$test_results ? @$test_results : 0;
958		for ($start..$num-1) {
959		$test_results->[$_] = &share({
960		'ok' => 1,
961		actual_ok => undef,
962		reason => 'incrementing test number',
963		type => 'unknown',
964		name => undef
965		});
966		}
967		}
968		# If backward, wipe history. Its their funeral.
969		elsif( $num < @$test_results ) {
970		$#{$test_results} = $num - 1;
971		}
972		}
973		return $self->{Curr_Test};
974		}
975
976
977		#line 1489
978
979		sub summary {
980		my($self) = shift;
981
982		return map { $_->{'ok'} } @{ $self->{Test_Results} };
983		}
984
985		#line 1544
986
987		sub details {
988		my $self = shift;
989		return @{ $self->{Test_Results} };
990		}
991
992		#line 1569
993
994		sub todo {
995		my($self, $pack) = @_;
996
997		$pack = $pack \|\| $self->exported_to \|\| $self->caller($Level);
998		return 0 unless $pack;
999
1000		no strict 'refs';
1001		return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1002		: 0;
1003		}
1004
1005		#line 1590
1006
1007		sub caller {
1008		my($self, $height) = @_;
1009		$height \|\|= 0;
1010
1011		my @caller = CORE::caller($self->level + $height + 1);
1012		return wantarray ? @caller : $caller[0];
1013		}
1014
1015		#line 1602
1016
1017		#line 1616
1018
1019		#'#
1020		sub _sanity_check {
1021		my $self = shift;
1022
1023		$self->_whoa($self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!');
1024		$self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1025		'Somehow your tests ran without a plan!');
1026		$self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1027		'Somehow you got a different number of results than tests ran!');
1028		}
1029
1030		#line 1637
1031
1032		sub _whoa {
1033		my($self, $check, $desc) = @_;
1034		if( $check ) {
1035		local $Level = $Level + 1;
1036		$self->croak(<<"WHOA");
1037		WHOA! $desc
1038		This should never happen! Please contact the author immediately!
1039		WHOA
1040		}
1041		}
1042
1043		#line 1659
1044
1045		sub _my_exit {
1046		$? = $_[0];
1047
1048		return 1;
1049		}
1050
1051
1052		#line 1672
1053
1054		$SIG{__DIE__} = sub {
1055		# We don't want to muck with death in an eval, but $^S isn't
1056		# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
1057		# with it. Instead, we use caller. This also means it runs under
1058		# 5.004!
1059		my $in_eval = 0;
1060		for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
1061		$in_eval = 1 if $sub =~ /^$eval$/;
1062		}
1063		$Test->{Test_Died} = 1 unless $in_eval;
1064		};
1065
1066		sub _ending {
1067		my $self = shift;
1068
1069		$self->_sanity_check();
1070
1071		# Don't bother with an ending if this is a forked copy. Only the parent
1072		# should do the ending.
1073		# Exit if plan() was never called. This is so "require Test::Simple"
1074		# doesn't puke.
1075		# Don't do an ending if we bailed out.
1076		if( ($self->{Original_Pid} != $$) or
1077		(!$self->{Have_Plan} && !$self->{Test_Died}) or
1078		$self->{Bailed_Out}
1079		)
1080		{
1081		_my_exit($?);
1082		return;
1083		}
1084
1085		# Figure out if we passed or failed and print helpful messages.
1086		my $test_results = $self->{Test_Results};
1087		if( @$test_results ) {
1088		# The plan? We have no plan.
1089		if( $self->{No_Plan} ) {
1090		$self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1091		$self->{Expected_Tests} = $self->{Curr_Test};
1092		}
1093
1094		# Auto-extended arrays and elements which aren't explicitly
1095		# filled in with a shared reference will puke under 5.8.0
1096		# ithreads. So we have to fill them in by hand. :(
1097		my $empty_result = &share({});
1098		for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1099		$test_results->[$idx] = $empty_result
1100		unless defined $test_results->[$idx];
1101		}
1102
1103		my $num_failed = grep !$_->{'ok'},
1104		@{$test_results}[0..$self->{Curr_Test}-1];
1105
1106		my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1107
1108		if( $num_extra < 0 ) {
1109		my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1110		$self->diag(<<"FAIL");
1111		Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1112		FAIL
1113		}
1114		elsif( $num_extra > 0 ) {
1115		my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1116		$self->diag(<<"FAIL");
1117		Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1118		FAIL
1119		}
1120
1121		if ( $num_failed ) {
1122		my $num_tests = $self->{Curr_Test};
1123		my $s = $num_failed == 1 ? '' : 's';
1124
1125		my $qualifier = $num_extra == 0 ? '' : ' run';
1126
1127		$self->diag(<<"FAIL");
1128		Looks like you failed $num_failed test$s of $num_tests$qualifier.
1129		FAIL
1130		}
1131
1132		if( $self->{Test_Died} ) {
1133		$self->diag(<<"FAIL");
1134		Looks like your test died just after $self->{Curr_Test}.
1135		FAIL
1136
1137		_my_exit( 255 ) && return;
1138		}
1139
1140		my $exit_code;
1141		if( $num_failed ) {
1142		$exit_code = $num_failed <= 254 ? $num_failed : 254;
1143		}
1144		elsif( $num_extra != 0 ) {
1145		$exit_code = 255;
1146		}
1147		else {
1148		$exit_code = 0;
1149		}
1150
1151		_my_exit( $exit_code ) && return;
1152		}
1153		elsif ( $self->{Skip_All} ) {
1154		_my_exit( 0 ) && return;
1155		}
1156		elsif ( $self->{Test_Died} ) {
1157		$self->diag(<<'FAIL');
1158		Looks like your test died before it could output anything.
1159		FAIL
1160		_my_exit( 255 ) && return;
1161		}
1162		else {
1163		$self->diag("No tests run!\n");
1164		_my_exit( 255 ) && return;
1165		}
1166		}
1167
1168		END {
1169		$Test->_ending if defined $Test and !$Test->no_ending;
1170		}
1171
1172		#line 1847
1173
1174		1;

-672

~~inc/Test/More.pm~~ less more

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

-2

lib/HTML/Selector/XPath.pm less more

0	0	package HTML::Selector::XPath;
1	1
2	2	use strict;
3		our $VERSION = '0.03';
	3	use 5.008_001;
	4	our $VERSION = '0.04';
4	5
5	6	require Exporter;
6	7	our @EXPORT_OK = qw(selector_to_xpath);

112	113	while ($rule =~ s/$reg->{pseudo}//) {
113	114	if ( $1 eq 'first-child') {
114	115	$parts[$#parts] = '*[1]/self::' . $parts[$#parts];
	116	} elsif ( $1 eq 'last-child') {
	117	push @parts, '[not(following-sibling::*)]';
115	118	} elsif ($1 =~ /^lang$([\w\-]+)$$/) {
116	119	push @parts, "[\@xml:lang='$1' or starts-with(\@xml:lang, '$1-')]";
117	120	} elsif ($1 =~ /^nth-child$(\d+)$$/) {

163	166	$selector->to_xpath; # //li[@id='main']
164	167
165	168	# functional interface
166		use HTML::Selector::Xpath 'selector_to_xpath';
	169	use HTML::Selector::XPath 'selector_to_xpath';
167	170	my $xpath = selector_to_xpath('div.foo');
168	171
169	172	=head1 DESCRIPTION

+20

-0

t/01_xpath.t less more

124	124	E:nth-child(1)
125	125	--- xpath
126	126	//E[count(preceding-sibling::*) = 0]
	127
	128	===
	129	--- selector
	130	E:last-child
	131	--- xpath
	132	//E[not(following-sibling::*)]
	133
	134
	135	===
	136	--- selector
	137	F E:last-child
	138	--- xpath
	139	//F//E[not(following-sibling::*)]
	140
	141	===
	142	--- selector
	143	F > E:last-child
	144	--- xpath
	145	//F/E[not(following-sibling::*)]
	146