#!/usr/bin/perl -w # -*- mode: perl; coding: utf-8 -*- use strict; use warnings FATAL => qw(all); use Test::More qw(no_plan); use FindBin; use lib "$FindBin::Bin/.."; use YATT; use YATT::Test; use YATT::LRXML::Node qw(TEXT_TYPE); require YATT::Test; use Data::Dumper; require_ok('YATT::LRXML::Parser'); YATT::break_parser; my $example = 0; { my $parser = new YATT::LRXML::Parser(namespace => [qw(yatt perl)]); is_deeply(scalar $parser->parse_entities('foo&perl:var.bar;baz', 0) , [TEXT_TYPE, undef ,'foo' , $parser->create_node(entity => [qw(perl var bar)]) , 'baz'] , 'attvalue'); is_deeply(scalar $parser->parse_entities('foo&perl(:var.bar);baz', 0) , [TEXT_TYPE, undef ,'foo' , $parser->create_node(entity => undef, 'perl(:var.bar)') , 'baz'] , 'call only'); is_deeply(scalar $parser->parse_entities('foo&perl:var.bar{$baz+};baz', 0) , [TEXT_TYPE, undef , 'foo' , $parser->create_node(entity => [qw(perl var)], '.bar{$baz+}') , 'baz' ] , 'attvalue: with dot/curly subscript'); is_deeply(scalar $parser->parse_entities('q=&perl:_[1].param(q);
', 0) , [TEXT_TYPE, undef , 'q=' , $parser->create_node(entity => [qw(perl)], ':_[1].param(q)') , '
'] , 'attvalue: with bracket/funcall subscript'); is_deeply(scalar $parser->parse_entities('&perl:bar;', 0) , $parser->create_node(entity => [qw(perl bar)]) , 'attvalue: entity only'); is_deeply(scalar $parser->parse_entities('&perl:bar;baz', 0) , [TEXT_TYPE, undef , $parser->create_node(entity => [qw(perl bar)]) , 'baz', ] , 'attvalue: missing leading text'); my $src = q(

Welcom &perl:user;

); $parser = YATT::LRXML::Parser->new(namespace => [qw(yatt perl)]); { use Carp; local $SIG{__DIE__} = sub { confess(@_); }; $parser->parse_string($src); } is $parser->tokens->[1] , '' , "ex$example. Parser. pi"; # XXX: readable でない (open していない、current が無い)状態なので、 # node_type_name が delegate されない。 # is $parser->tree->node_type_name # , 'root', "ex$example. \$tree is root"; is $parser->tree->stringify, $src, "ex$example. round trip"; # XXX: linenum の検査を. #---------------------------------------- $example++; $src = <<'END';

Welcom &perl:user;

END $parser->parse_string($src); my $tree = $parser->tree; print "tokens == \n", Dumper(scalar $parser->tokens), "\n" if $ENV{VERBOSE}; print "tree == \n", Dumper($tree), "\n" if $ENV{VERBOSE}; { my $scan = $parser->scanner(undef); my ($i, @lines, @list, @nols) = (0); while ($scan->readable) { push @lines, $scan->linenum; push @list, $scan->read; push @nols, $scan->last_nol; $i++; } is $i, 7, "ex$example. number of feedable feeds."; is_deeply \@list, [' ','',' ','','

Welcom ','&perl:user;','

'], "ex$example. token structure"; is_deeply \@lines, [qw(1 3 3 4 6 8 8)], "ex$example. token lines"; is_deeply \@nols, [qw(2 0 1 2 2 0 3)], "ex$example. token nols"; } is $tree->size, 7, "ex$example. size of parsed tree"; is $tree->stringify, $src, "ex$example. round trip"; #---------------------------------------- $example++; $src = <<'END'; ...

Welcom &perlZZ:user;

END $parser->parse_string($src); $tree = $parser->tree; print "tokens == \n", Dumper(scalar $parser->tokens), "\n" if $ENV{VERBOSE}; print "tree == \n", Dumper($tree), "\n" if $ENV{VERBOSE}; is $tree->size, 1, "ex$example. size of parsed tree"; is $tree->stringify, $src, "ex$example. round trip"; #---------------------------------------- is $parser->parse_string('')->stringify , q(), q(); #---------------------------------------- $example++; $src = <<'END'; header
<:perl:join />と
&perl:var:col;
footer END $parser->parse_string($src); $tree = $parser->tree; print "tokens == \n", Dumper(scalar $parser->tokens), "\n" if $ENV{VERBOSE}; print "tree == \n", Dumper($tree), "\n" if $ENV{VERBOSE}; { my $scan = $parser->scanner(undef); my ($i, @lines, @list, @nols) = (0); while ($scan->readable) { push @lines, $scan->linenum; push @list, $scan->read; push @nols, $scan->last_nol; $i++; } is $i, 19, "ex$example. number of feedable feeds."; is_deeply \@list, ['header ', '
', ' ', q||, ' ', q||, ' ', '', ' ', '<:perl:join />', 'と', '', '
', q||,' ', '&perl:var:col;', '
', '
', ' footer '], "ex$example. token structure"; is_deeply \@lines, [qw(1 2 2 4 4 6 6 7 7 7 7 8 8 10 10 10 10 12 12)] , "ex$example. token lines"; is_deeply \@nols, [qw(1 0 2 0 2 0 1 0 0 0 1 0 2 0 0 0 2 0 2)] , "ex$example. token nols"; } is $tree->size, 3, "ex$example. size of parsed tree"; eq_or_diff($tree->stringify, $src, "ex$example. round trip"); # タグの対応エラーを検出し、その行番号が一致していることを確認せよ。 # foo='\'' を確認せよ #---------------------------------------- $example++; $src = <<'END'; header
foo <:perl:else var=q value=2 />bar <:perl:else var=q value=3 />baz <:perl:else />bang
footer END $parser->parse_string($src); $tree = $parser->tree; print "tokens == \n", Dumper(scalar $parser->tokens), "\n" if $ENV{VERBOSE}; print "tree == \n", Dumper($tree), "\n" if $ENV{VERBOSE}; is $tree->size, 3, "ex$example. size of parsed tree"; is $tree->stringify, $src, "ex$example. round trip."; #---------------------------------------- my $elem = $parser->parse_string('
'); is($elem->open->node_type_name, 'html' , 'is html'); is($elem->open->node_name, 'form', 'is
'); is($elem->open->open->node_name, 'input', 'is '); } { $example++; my $parser = YATT::LRXML::Parser->new(namespace => [qw(yatt perl)] , debug => $ENV{DEBUG} ? 1 : 0); # stringify は通常 \s+ を ' ' にするので、一致検査のための前処理が必要。 my $tree = $parser->parse_string(map {s/\\\n\s*/ /g; $_} my $src = <<'END'); body END is $tree->open->size, 14, "ex$example. size of decl of 'foo1'"; is $tree->stringify, (map { # s/\n//g; s/\s+\]/\]/g; s/\[\s+/\[/g; s/\s*=\s*/=/g; # s/\s+--(.*?)--\s+/ --$1-- /gs; $_ } $src)[0], "ex$example. round trip."; } my $src1 = <<'END';

&yatt:title;

&yatt:x;-&yatt:y;

&yatt:z;-&yatt:w;

END { my $tree = read_string YATT::LRXML($src1, filename => $0); print Dumper($tree) if $ENV{DEBUG}; is $tree->size, 17, 'LRXML is correctly parsed'; eq_or_diff $tree->stringify, $src1, 'LRXML round trip'; } { my $parser = new YATT::LRXML::Parser; my $html = q{<:yatt:baz>BAZbang}; # XXX: Currently, \n in tag is not preserved. $html =~ s{\n}{ }g; my $elem = $parser->parse_string($html)->open; is_deeply [$elem->node_name, $elem->node_path], [qw(foo yatt foo)] , 'name of elem'; eq_or_diff $elem->stringify, $html, "round trip of my"; my $att = $elem->open; is_deeply [scalar $att->node_name, do { my $body = $att->open; ($body->size, $body->node_type_name, [$body->node_path]) }], [undef, 0, 'entity', ['yatt', 'var']] , 'unnamed bare att'; $att->next; is_deeply [[$att->node_path], $att->node_body], [[qw(my foo)], undef] , 'bare nsname attname'; $att->next; is_deeply [[$att->node_path], $att->node_body], [[qw(my bar)], 'BAR'] , 'nsname attname = value'; $att->next; is join("=", $att->node_name, $att->node_body) , "baz=BAZ", 'element attr'; } if (0) { print YATT::Translator::Perl->from_string($src1, filename => $0) ->translate_as_subs_to(qw(print index)); # print YATT::Translator::JavaScript->new($tree) # ->translate_as_function('index'); } { my $src3 = <<'END';

&yatt:file(=@$_);

END my $tree = read_string YATT::LRXML($src3, filename => $0); print Dumper($tree) if $ENV{DEBUG}; is $tree->size, 3, 'LRXML is correctly parsed'; eq_or_diff $tree->stringify, $src3, 'LRXML round trip'; } { # missing close tag. my $parser = new YATT::LRXML::Parser; my $html = q{bar}; YATT::Test::raises([$parser => parse_string => $html] , qr{^Missing close tag 'foo'}, "missing close tag"); }