[html-element-library.git] / t / misc.t

#!/usr/bin/perl -T
use lib '.';
use t::lib tests => 26;

##################################################
# Short tests based on mklol

sub mklol {
	HTML::Element->new_from_lol(
		['html',
		 ['head',
		  [ 'title', 'I like stuff!' ]],
		 ['body', {id => 'corpus'}, {'lang', 'en-JP'},
		  'stuff',
		  ['p', 'um, p < 4!', {'class' => 'par123'}],
		  ['div', {foo => 'bar'}, '123'],
		  ['div', {jack => 'olantern'}, '456']]]);
}

my $tree_replaced = \'<html><head><title>I like stuff!</title></head><body id="corpus" lang="en-JP">all gone!</body></html>';
my $tree;

$tree = mklol;
$tree->content_handler(corpus => 'all gone!');
isxml $tree, $tree_replaced, 'content_handler';

$tree = mklol;
$tree->set_child_content(id => 'corpus', 'all gone!');
isxml $tree, $tree_replaced, 'set_child_content';

$tree = mklol;
$tree->look_down('_tag' => 'body')->replace_content('all gone!');
isxml $tree, $tree_replaced, 'replace_content';

$tree = mklol;
my $p = $tree->look_down('_tag' => 'body')->look_down(_tag => 'p');
is $p->sibdex, 1, 'p tag has 1 as its index';

$tree = mklol;
my $div = $tree->look_down('_tag' => 'body')->look_down(_tag => 'p');
my @sibs = $div->siblings;
is $sibs[0], 'stuff', "first sibling is simple text";
is $sibs[2]->tag, 'div', "3rd tag is a div tag";
is scalar @sibs, 4, "4 siblings total";

$tree = mklol;
my $bold = HTML::Element->new('b', id => 'wrapper');
my $w = $tree->look_down(_tag => 'p');
$w->wrap_content($bold);
isxml $w, \'<p class="par123"><b id="wrapper">um, p &lt; 4!</b></p>', 'wrap_content';

##################################################
# Short tests

$tree = mktree 't/html/crunch.html';
$tree->crunch(look_down => [ class => 'imageElement' ], leave => 1);
isxml $tree, 't/html/crunch-exp.html', 'crunch';

$tree = mktree 't/html/defmap.html';
$tree->defmap(smap => {pause => 'arsenal rules'}, $ENV{TEST_VERBOSE});
isxml $tree, 't/html/defmap-exp.html', 'defmap';

$tree = mktree 't/html/fillinform.html';
isxml \($tree->fillinform({state => 'catatonic'})), 't/html/fillinform-exp.html', 'fillinform';

$tree = mktree 't/html/hashmap.html';
$tree->hash_map(
	hash      => {people_id => 888, phone => '444-4444', email => 'm@xml.com'},
	to_attr   => 'sid',
	excluding => ['email']
);
isxml $tree, 't/html/hashmap-exp.html', 'hash_map';

$tree = mktree 't/html/iter.html';
my $li = $tree->look_down(class => 'store_items');
$tree->iter($li, qw/bread butter vodka/);
isxml $tree, 't/html/iter-exp.html', 'iter';

my @list = map { [item => $_] } qw/bread butter beans/;
my $initial_lol = [ note => [ list => [ item => 'sample' ] ] ];
my ($new_lol) = HTML::Element::newchild($initial_lol, list => @list);
my $expected = [note => [list => [item => 'bread'], [item => 'butter'], [item => 'beans']]];
is_deeply $new_lol, $expected, 'newchild unrolling';

$tree = mktree 't/html/highlander2.html';
$tree->passover('under18');
isxml $tree, 't/html/highlander2-passover-exp.html', 'passover';

$tree = mktree 't/html/position.html';
my $found = $tree->look_down(id => 'findme');
my $pos = join ' ', $found->position;
is $pos, '-1 1 0 1 2', 'position';

$tree = mktree 't/html/prune.html';
$tree->prune;
isxml $tree, 't/html/prune-exp.html', 'prune';

##################################################
# Longer tests

$tree = mktree 't/html/dual_iter.html';

$tree->iter2(
	wrapper_data => [
		['the pros' => 'never have to worry about service again'],
		['the cons' => 'upfront extra charge on purchase'],
		['our choice' => 'go with the extended service plan']
	],
	wrapper_proc => sub {
		my ($container) = @_;
		# only keep the last 2 dts and dds
		my @content_list = $container->content_list;
		$container->splice_content(0, @content_list - 2);
	},
	splice       => sub {
		my ($container, @item_elems) = @_;
		$container->unshift_content(@item_elems);
	},
	debug        => $ENV{TEST_VERBOSE},
);

isxml $tree, 't/html/dual_iter-exp.html', 'dual_iter';

###

for my $age (qw/5 15 50/) {
	$tree = mktree 't/html/highlander.html';
	$tree->highlander(
		age_dialog => [
			under10 => sub { $_[0] < 10 },
			under18 => sub { $_[0] < 18 },
			welcome => sub { 1 }
		],
		$age
	);
	isxml $tree, "t/html/highlander-$age-exp.html", "highlander for $age";
}

###

sub replace_age {
	my ($branch, $age) = @_;
	$branch->look_down(id => 'age')->replace_content($age);
}

for my $age (qw/5 15 27/) {
	$tree = mktree 't/html/highlander2.html';
	my $if_then = $tree->look_down(id => 'age_dialog')->highlander2(
		cond => [
			under10 => [ sub { $_[0] < 10 }, \&replace_age ],
			under18 => [ sub { $_[0] < 18 }, \&replace_age ],
			welcome => [ sub { 1          }, \&replace_age ]
		],
		cond_arg => [ $age ]
	);

	isxml ($tree, "t/html/highlander2-$age-exp.html", "highlander2 for age $age");
}

###

$tree = mktree 't/html/iter2.html';

$tree->iter2(
	# default wrapper_ld ok
	wrapper_data => [
		[ Programmer => 'one who likes Perl and Seamstress' ],
		[ DBA        => 'one who does business as' ],
		[ Admin      => 'one who plays Tetris all day' ]
	],
	wrapper_proc => sub {
		my ($container) = @_;

		# only keep the last 2 dts and dds
		my @content_list = $container->content_list;
		$container->splice_content(0, @content_list - 2);
	},
	# default item_ld is k00l
	# default item_data is phrEsh
	# default item_proc will do w0rk
	splice       => sub {
		my ($container, @item_elems) = @_;
		$container->unshift_content(@item_elems);
	},

	debug => $ENV{TEST_VERBOSE},
);

isxml $tree, 't/html/iter2-exp.html', 'iter2';

###

my @data = (
	{ clan_name => 'janglers',    clan_id => 12, selected => 1 },
	{ clan_name => 'thugknights', clan_id => 14 },
	{ clan_name => 'cavaliers' ,  clan_id => 13 }
);
$tree = mktree 't/html/unroll_select.html';

$tree->unroll_select(
	select_label     => 'clan_list',
	option_value     => sub { my $row = shift; $row->{clan_id} },
	option_content   => sub { my $row = shift; $row->{clan_name} },
	option_selected  => sub { my $row = shift; $row->{selected} },
	data             => \@data,
	data_iter        => sub { my $data = shift; shift @$data });

isxml $tree, 't/html/unroll_select-exp.html', 'unroll_select';
Commit	Line	Data
c337c404 MG	1	#!/usr/bin/perl -T
	2	use lib '.';
	3	use t::lib tests => 26;
	4
	5	##################################################
	6	# Short tests based on mklol
	7
	8	sub mklol {
	9	HTML::Element->new_from_lol(
	10	['html',
	11	['head',
	12	[ 'title', 'I like stuff!' ]],
	13	['body', {id => 'corpus'}, {'lang', 'en-JP'},
	14	'stuff',
	15	['p', 'um, p < 4!', {'class' => 'par123'}],
	16	['div', {foo => 'bar'}, '123'],
	17	['div', {jack => 'olantern'}, '456']]]);
	18	}
	19
	20	my $tree_replaced = \'<html><head><title>I like stuff!</title></head><body id="corpus" lang="en-JP">all gone!</body></html>';
	21	my $tree;
	22
	23	$tree = mklol;
	24	$tree->content_handler(corpus => 'all gone!');
	25	isxml $tree, $tree_replaced, 'content_handler';
	26
	27	$tree = mklol;
	28	$tree->set_child_content(id => 'corpus', 'all gone!');
	29	isxml $tree, $tree_replaced, 'set_child_content';
	30
	31	$tree = mklol;
	32	$tree->look_down('_tag' => 'body')->replace_content('all gone!');
	33	isxml $tree, $tree_replaced, 'replace_content';
	34
	35	$tree = mklol;
	36	my $p = $tree->look_down('_tag' => 'body')->look_down(_tag => 'p');
	37	is $p->sibdex, 1, 'p tag has 1 as its index';
	38
	39	$tree = mklol;
	40	my $div = $tree->look_down('_tag' => 'body')->look_down(_tag => 'p');
	41	my @sibs = $div->siblings;
	42	is $sibs[0], 'stuff', "first sibling is simple text";
	43	is $sibs[2]->tag, 'div', "3rd tag is a div tag";
	44	is scalar @sibs, 4, "4 siblings total";
	45
	46	$tree = mklol;
	47	my $bold = HTML::Element->new('b', id => 'wrapper');
	48	my $w = $tree->look_down(_tag => 'p');
	49	$w->wrap_content($bold);
	50	isxml $w, \'<p class="par123"><b id="wrapper">um, p < 4!</b></p>', 'wrap_content';
	51
	52	##################################################
	53	# Short tests
	54
	55	$tree = mktree 't/html/crunch.html';
	56	$tree->crunch(look_down => [ class => 'imageElement' ], leave => 1);
7c5af9fc	57	isxml $tree, 't/html/crunch-exp.html', 'crunch';
c337c404 MG	58
	59	$tree = mktree 't/html/defmap.html';
	60	$tree->defmap(smap => {pause => 'arsenal rules'}, $ENV{TEST_VERBOSE});
7c5af9fc	61	isxml $tree, 't/html/defmap-exp.html', 'defmap';
c337c404 MG	62
c337c404 MG	63	$tree = mktree 't/html/fillinform.html';
7c5af9fc	64	isxml \($tree->fillinform({state => 'catatonic'})), 't/html/fillinform-exp.html', 'fillinform';
c337c404 MG	65
	66	$tree = mktree 't/html/hashmap.html';
	67	$tree->hash_map(
	68	hash => {people_id => 888, phone => '444-4444', email => 'm@xml.com'},
	69	to_attr => 'sid',
	70	excluding => ['email']
	71	);
7c5af9fc	72	isxml $tree, 't/html/hashmap-exp.html', 'hash_map';
c337c404 MG	73
	74	$tree = mktree 't/html/iter.html';
	75	my $li = $tree->look_down(class => 'store_items');
	76	$tree->iter($li, qw/bread butter vodka/);
7c5af9fc	77	isxml $tree, 't/html/iter-exp.html', 'iter';
c337c404 MG	78
	79	my @list = map { [item => $_] } qw/bread butter beans/;
	80	my $initial_lol = [ note => [ list => [ item => 'sample' ] ] ];
	81	my ($new_lol) = HTML::Element::newchild($initial_lol, list => @list);
	82	my $expected = [note => [list => [item => 'bread'], [item => 'butter'], [item => 'beans']]];
	83	is_deeply $new_lol, $expected, 'newchild unrolling';
	84
	85	$tree = mktree 't/html/highlander2.html';
	86	$tree->passover('under18');
7c5af9fc	87	isxml $tree, 't/html/highlander2-passover-exp.html', 'passover';
c337c404 MG	88
	89	$tree = mktree 't/html/position.html';
	90	my $found = $tree->look_down(id => 'findme');
	91	my $pos = join ' ', $found->position;
	92	is $pos, '-1 1 0 1 2', 'position';
	93
	94	$tree = mktree 't/html/prune.html';
	95	$tree->prune;
7c5af9fc	96	isxml $tree, 't/html/prune-exp.html', 'prune';
c337c404 MG	97
	98	##################################################
	99	# Longer tests
	100
	101	$tree = mktree 't/html/dual_iter.html';
	102
	103	$tree->iter2(
	104	wrapper_data => [
	105	['the pros' => 'never have to worry about service again'],
	106	['the cons' => 'upfront extra charge on purchase'],
	107	['our choice' => 'go with the extended service plan']
	108	],
	109	wrapper_proc => sub {
	110	my ($container) = @_;
	111	# only keep the last 2 dts and dds
	112	my @content_list = $container->content_list;
	113	$container->splice_content(0, @content_list - 2);
	114	},
	115	splice => sub {
	116	my ($container, @item_elems) = @_;
	117	$container->unshift_content(@item_elems);
	118	},
	119	debug => $ENV{TEST_VERBOSE},
	120	);
	121
7c5af9fc	122	isxml $tree, 't/html/dual_iter-exp.html', 'dual_iter';
c337c404 MG	123
	124	###
	125
	126	for my $age (qw/5 15 50/) {
	127	$tree = mktree 't/html/highlander.html';
	128	$tree->highlander(
	129	age_dialog => [
	130	under10 => sub { $_[0] < 10 },
	131	under18 => sub { $_[0] < 18 },
	132	welcome => sub { 1 }
	133	],
	134	$age
	135	);
7c5af9fc	136	isxml $tree, "t/html/highlander-$age-exp.html", "highlander for $age";
c337c404 MG	137	}
	138
	139	###
	140
	141	sub replace_age {
	142	my ($branch, $age) = @_;
	143	$branch->look_down(id => 'age')->replace_content($age);
	144	}
	145
	146	for my $age (qw/5 15 27/) {
	147	$tree = mktree 't/html/highlander2.html';
	148	my $if_then = $tree->look_down(id => 'age_dialog')->highlander2(
	149	cond => [
	150	under10 => [ sub { $_[0] < 10 }, \&replace_age ],
	151	under18 => [ sub { $_[0] < 18 }, \&replace_age ],
	152	welcome => [ sub { 1 }, \&replace_age ]
	153	],
	154	cond_arg => [ $age ]
	155	);
	156
7c5af9fc	157	isxml ($tree, "t/html/highlander2-$age-exp.html", "highlander2 for age $age");
c337c404 MG	158	}
	159
	160	###
	161
	162	$tree = mktree 't/html/iter2.html';
	163
	164	$tree->iter2(
	165	# default wrapper_ld ok
	166	wrapper_data => [
	167	[ Programmer => 'one who likes Perl and Seamstress' ],
	168	[ DBA => 'one who does business as' ],
	169	[ Admin => 'one who plays Tetris all day' ]
	170	],
	171	wrapper_proc => sub {
	172	my ($container) = @_;
	173
	174	# only keep the last 2 dts and dds
	175	my @content_list = $container->content_list;
	176	$container->splice_content(0, @content_list - 2);
	177	},
	178	# default item_ld is k00l
	179	# default item_data is phrEsh
	180	# default item_proc will do w0rk
	181	splice => sub {
	182	my ($container, @item_elems) = @_;
	183	$container->unshift_content(@item_elems);
	184	},
	185
	186	debug => $ENV{TEST_VERBOSE},
	187	);
	188
7c5af9fc	189	isxml $tree, 't/html/iter2-exp.html', 'iter2';
c337c404 MG	190
	191	###
	192
	193	my @data = (
	194	{ clan_name => 'janglers', clan_id => 12, selected => 1 },
	195	{ clan_name => 'thugknights', clan_id => 14 },
	196	{ clan_name => 'cavaliers' , clan_id => 13 }
	197	);
	198	$tree = mktree 't/html/unroll_select.html';
	199
	200	$tree->unroll_select(
	201	select_label => 'clan_list',
	202	option_value => sub { my $row = shift; $row->{clan_id} },
	203	option_content => sub { my $row = shift; $row->{clan_name} },
	204	option_selected => sub { my $row = shift; $row->{selected} },
	205	data => \@data,
	206	data_iter => sub { my $data = shift; shift @$data });
	207
7c5af9fc	208	isxml $tree, 't/html/unroll_select-exp.html', 'unroll_select';