#!/usr/bin/perl
#Copyright 2009-10 Arthur S Goldstein
BEGIN {$test_count = 1}
#BEGIN {$test_count = 112}
use Test::More tests => $test_count;
#use Devel::Profiler;
#Test cases from http://www.adp-gmbh.ch/perl/rec_descent.html
our $string_out;
our $preserve_string_out;
our $item_list2;
our $item_hash2;
our $i = 0;
our $x;
our $item_list;
our $item_hash;
our $rd_item_list;
our $rd_item_hash;
our $rd_item_list2;
our $rd_item_hash2;
is (1,1,'dummy test');
exit;
SKIP:
{
my $skip;
$skip = '1'; #too many versions of Parse:RecDescent out there
eval 'use Parse::Stallion::RD';
$skip .= $@;
eval 'use Parse::RecDescent 1.962';
$skip .= $@;
eval 'use Text::Balanced';
$skip .= $@;
if ($skip) {skip ("Need Parse RecDescent installed with Text::Balanced",
$test_count)};
use_ok('Parse::RecDescent');
my $rules=<<'END';
start : character character character(s)
{$::string_out .= "Found: ". $item[1]. $item[2]. join "", @{$item[3]}, "\n"; }
character: /\w/
END
#print STDERR "setxxx\n";
my $char_parser = new Parse::Stallion::RD($rules);
my $value = $char_parser->start('a b c');
is ($string_out, 'Found: abc
', '2 char 1 chars');
$string_out = '';
$value = $char_parser->start('abcdef'
);
is ($string_out, 'Found: abcdef
', '2 char 1 chars with more chars');
$string_out = '';
$rules=<<'END';
start : character character character(s /,/)
{$::string_out = "Found: ". $item[1]. $item[2]. join "", @{$item[3]}, "\n"; }
character: /\w/
END
my $xx_parser = new Parse::Stallion::RD($rules);
$value = $xx_parser->start('abc,d,e,f');
is ($string_out, 'Found: abcdef
', '2 char 1 chars comma');
$string_out = '';
$value = $xx_parser->start('abcdef');
is ($string_out, 'Found: abc
', '2 char 1 chars comma 2');
$string_out = '';
my $grammar = q {
start : seq_1 seq_2
seq_1 : 'A' 'B' 'C' 'D' { $::string_out .= "seq_1: " . join (" ", @item[1..$#item]) . "\n" }
| 'A' 'B' 'C' 'D' 'E' 'F' { $::string_out .= "seq_2: " . join (" ", @item[1..$#item]) . "\n" }
seq_2 : character(s)
character: /\w/ { $::string_out .= "scharacter: $item[1]\n" }
};
my $fpnl_parser = new Parse::Stallion::RD($grammar);
$fpnl_parser->start("A B C D E F G");
is ($string_out, 'seq_1: A B C D
scharacter: E
scharacter: F
scharacter: G
' , 'other sequences');
$string_out = '';
$grammar = q {
start: seq_1 seq_2
seq_1 : 'A' 'B' 'C' 'D' 'E' 'F'
{ $::string_out .= "f2seq_1: " . join (" ", @item[1..$#item]) . "\n" }
| 'A' 'B' 'C' 'D'
{ $::string_out .= "f22seq_1: " . join (" ", @item[1..$#item]) . "\n" }
seq_2 : character(s)
character: /\w/
{ $::string_out .= "f2character: $item[1]\n" }
};
my $fpnl2_parser = new Parse::Stallion::RD($grammar);
$fpnl2_parser->start("A B C D E F G");
is ($string_out, 'f2seq_1: A B C D E F
f2character: G
' , '2 char 1 chars comma f2');
$string_out = '';
$grammar = q {
start: seq
seq : char_1 char_2 char_3 char_4
{ $::string_out .= "ippi". join (" -- ", @item); }
char_1 : character
char_2 : character
char_3 : character
char_4 : character
character: /\w/
};
my $item_parser = new Parse::Stallion::RD($grammar);
$item_parser->start("A B C D");
is ($string_out, 'ippiseq -- A -- B -- C -- D', 'dashed sequences');
$string_out = '';
$grammar = q {
start: seq
seq : char_1 char_2 char_3 char_4
{ $::string_out .= join("",sort map {$_ . "=" . $item{$_} . "; "} keys %item)}
char_1 : character
char_2 : character
char_3 : character
char_4 : character
character: /\w/
};
my $hash_parser = new Parse::Stallion::RD($grammar);
$hash_parser->start("A B C D");
is ($string_out, '__RULE__=seq; char_1=A; char_2=B; char_3=C; char_4=D; ',
'hash of item');
$string_out = '';
$grammar = q {
start: character(?) { $::string_out = $item[1] }
character: /\w/
};
my $qm_parser = new Parse::Stallion::RD($grammar);
$qm_parser->start("A");
$preserve_string_out = $string_out;
$string_out = '';
my $qmrd_parser = new Parse::RecDescent($grammar);
$qmrd_parser->start("A");
is_deeply ( $preserve_string_out, $string_out,
'question mark parse with recdescent');
$string_out = '';
$grammar = q {
start: character(s?) { $::string_out .= join('',@{$item[1]}) }
character: /\w/
};
my $sqm_parser = new Parse::Stallion::RD($grammar);
$sqm_parser->start("BAC");
is ($string_out, 'BAC', 'question mark parse');
$string_out = '';
$grammar = q {
start: character(..3) { if ($item[1])
{$::string_out .= join('',@{$item[1]})} }
character: /\w/
};
my $sm3_parser = new Parse::Stallion::RD($grammar);
#print STDERR "sm3 parser set up\n";
$sm3_parser->start("BAC");
is ($string_out, 'BAC', 'sm3 parse');
$string_out = '';
$grammar = q {
start: character(..3)
character: /\w/
};
my $m3_parser = new Parse::Stallion::RD($grammar);
my $m3rd_parser = new Parse::RecDescent($grammar);
#print STDERR "m3rd parser set up\n";
my $rd_result;
my $r_result;
my $result;
#use Data::Dumper;
$r_result = $m3_parser->start("");
$rd_result = $m3rd_parser->start("");
is_deeply($r_result, $rd_result, "empty m3");
#print STDERR "m3 result 0".Dumper(\$r_result)."\n";
$r_result = $m3_parser->start("B");
$rd_result = $m3rd_parser->start("B");
is_deeply($r_result, $rd_result, "empty m3 1");
$r_result = $m3_parser->start("BA");
$rd_result = $m3rd_parser->start("BA");
is_deeply($r_result, $rd_result, "empty m3 2");
#print STDERR "m3 result 2".Dumper(\$r_result)."\n";
$r_result = $m3_parser->start("BAC");
$rd_result = $m3rd_parser->start("BAC");
is_deeply($r_result, $rd_result, "empty m3 3");
#print STDERR "m3 result 3".Dumper(\$r_result)."\n";
$r_result = $m3_parser->start("BACD");
$rd_result = $m3rd_parser->start("BACD");
is_deeply($r_result, $rd_result, "empty m3 4");
#print STDERR "m3 result 4".Dumper(\$r_result)."\n";
#print STDERR "m3 resultd 4".Dumper(\$rd_result)."\n";
$grammar = q {
start: character(2..3)
character: /\w/
};
#print STDERR "nm parser being set up\n";
my $nm_parser = new Parse::Stallion::RD($grammar);
my $nmrd_parser = new Parse::RecDescent($grammar);
$r_result = $nm_parser->start("BAC");
$rd_result = $nmrd_parser->start("BAC");
is_deeply($r_result, $rd_result, 'bac nm');
$r_result = $nm_parser->start("B");
$rd_result = $nmrd_parser->start("B");
is_deeply($r_result, $rd_result, 'b nm');
$r_result = $nm_parser->start("BACD");
$rd_result = $nmrd_parser->start("BACD");
is_deeply($r_result, $rd_result, 'bacd nm');
$x = 'BACD';
my $rx = 'BACD';
$nm_parser->start($x);
$nm_parser->start($rx);
is($x, $rx, 'no reference');
$nm_parser->start(\$x);
$nm_parser->start(\$rx);
is($x, $rx, 'some reference');
is($x, 'D', 'reference eaten');
$grammar = q {
start : "A"
};
$a_parser = new Parse::Stallion::RD($grammar);
$result = $a_parser->start("A");
is ($result, "A", "a parser 1");
$result = $a_parser->start("B");
is ($result, undef, "a parser 2");
$grammar = q {
st : "A" "$item[1]"
};
$aa_parser = new Parse::Stallion::RD($grammar);
$result = $aa_parser->st("AA");
is ($result, "A", "aa parser 1");
$aard_parser = new Parse::RecDescent($grammar);
$rd_result = $aard_parser->st("AA");
is ($result, $rd_result, "aa parser on rd");
$result = $aa_parser->st("AB");
is ($result, undef, "aa parser 2");
$grammar = q {
st : somechar somechar
somechar : character(..3) {$text .= 'A'; $item[1];}
character : /\w/
};
$txt_parser = new Parse::Stallion::RD($grammar);
$result = $txt_parser->st("BBBB");
$txt_rd_parser = new Parse::RecDescent($grammar);
$rd_result = $txt_rd_parser->st("BBBB");
is_deeply ($result, $rd_result, "txt parser 2");
$string_out = '';
$grammar = q {
start: line(s)
line : 'print_line' {$::string_out .= "print_line found on: $thisline\n"}
| /.*/
};
$tl_parser=Parse::Stallion::RD->new($grammar);
$tlrd_parser=Parse::RecDescent->new($grammar);
$tl_parser->start('
hello world
i want a print_line right
now
and
print_line
here again
print_line
');
is ($string_out, 'print_line found on: 6
print_line found on: 9
', 'thisline with now');
$preserve_string_out = $string_out;
$string_out = '';
$tl_parser->start('
hello world
i want a print_line right
now
and
print_line
here again
print_line
');
is ($preserve_string_out, $string_out, 'thisline confirmed with now');
$string_out = '';
$string_out = '';
$grammar = q {
start: line(s)
line : "print_line\n" {$::string_out .= "print_line found on: $thisline\n"}
| /.*/
};
$tl_parser=Parse::Stallion::RD->new($grammar);
$tlrd_parser=Parse::RecDescent->new($grammar);
$tl_parser->start('
hello world
i want a print_line right
now
and
print_line
here again
print_line
');
is ($string_out, 'print_line found on: 6
print_line found on: 9
', 'thisline with n');
$preserve_string_out = $string_out;
$string_out = '';
$tl_parser->start('
hello world
i want a print_line right
now
and
print_line
here again
print_line
');
is ($preserve_string_out, $string_out, 'thisline confirmed with n');
$string_out = '';
$::RD_AUTOACTION = q { [@item] };
$grammar = q {
start : seq
seq : char_1 char_2 number(s) thing(s)
char_1 : character
char_2 : character
character : /[A-Z]/
number : /\d+/
thing : '(' key_value_pair(s) ')'
key_value_pair: identifier "=" identifier
identifier : m([A-Za-z_]\w*)
};
my $auto_parser=Parse::RecDescent->new($grammar);
my $myauto_parser=Parse::Stallion::RD->new($grammar);
$rd_result = $myauto_parser->start("A B 42 29 5 ( foo = bar perl = cool hello = world )");
$result = $auto_parser->start("A B 42 29 5 ( foo = bar perl = cool hello = world )");
#print STDERR Dumper($rd_result);
#print STDERR Dumper($result);
is_deeply($rd_result, $result, "auto action");
$grammar = q {
start : seq
seq : (char_1 char_2)
char_1 : character
char_2 : character
character : /[A-Z]/
};
my $sbauto_parser=Parse::RecDescent->new($grammar);
my $mysbauto_parser=Parse::Stallion::RD->new($grammar);
$rd_result = $mysbauto_parser->start("A B");
$result = $sbauto_parser->start("A B");
#print STDERR Dumper($rd_result);
#print STDERR Dumper($result);
$rd_result->[1][1][0] = $result->[1][1][0]; #naming is not the same
is_deeply($rd_result, $result, "auto action with subrule");
$::RD_AUTOACTION = undef;
$grammar = q {
start: seq(s)
seq : 'A' 'B' ...'C'
{ $::string_out .= "A B eaten, C follows\n"}
| 'A' 'B' character
{ $::string_out .= "A B $item[3] eaten\n"}
| character character
{ $::string_out .= "two characters eaten: $item[1] and $item[2]\n" }
character: /\w/
};
$larrd_parser=Parse::RecDescent->new($grammar);
$la_parser=Parse::Stallion::RD->new($grammar);
$string_out = '';
$larrd_parser->start("A B Q P A B E A B C A B X");
is($string_out, 'A B Q eaten
two characters eaten: P and A
two characters eaten: B and E
A B eaten, C follows
two characters eaten: C and A
two characters eaten: B and X
', 'expected look ahead');
$string_out = '';
$la_parser->start("A B Q P A B E A B C A B X");
is($string_out, 'A B Q eaten
two characters eaten: P and A
two characters eaten: B and E
A B eaten, C follows
two characters eaten: C and A
two characters eaten: B and X
', 'stallion look ahead');
#print "start dq\n";
$grammar = q {
start: seq(s)
seq : 'A' 'B' ..."C"
{ $::string_out .= "A B eaten, C follows\n"}
| 'A' 'B' character
{ $::string_out .= "A B $item[3] eaten\n"}
| character character
{ $::string_out .= "two characters eaten: $item[1] and $item[2]\n" }
character: /\w/
};
$larrd_parser=Parse::RecDescent->new($grammar);
$la_parser=Parse::Stallion::RD->new($grammar);
$string_out = '';
$larrd_parser->start("A B Q P A B E A B C A B X");
$preserve_string_out = $string_out;
$string_out = '';
$la_parser->start("A B Q P A B E A B C A B X");
is($string_out, $preserve_string_out, 'stallion look ahead with double quote');
$grammar = q {
start: seq(s)
seq : 'A' 'B' ...!"C"
{ $::string_out .= "A B eaten, C does not follow\n"}
| 'A' 'B' character
{ $::string_out .= "A B $item[3] eaten\n"}
| character character
{ $::string_out .= "two characters eaten: $item[1] and $item[2]\n" }
character: /\w/
};
$larrd_parser=Parse::RecDescent->new($grammar);
$la_parser=Parse::Stallion::RD->new($grammar);
$string_out = '';
$larrd_parser->start("A B Q P A B E A B C A B X");
$preserve_string_out = $string_out;
$string_out = '';
$la_parser->start("A B Q P A B E A B C A B X");
is($string_out, $preserve_string_out, 'stallion not look ahead test');
#$::RD_HINT=1;
#
#$grammar = q {
#
# {my $x = 1}
#
# start: character(s) {print "x is $x\n"; }
#
# character: /\w/ {$x++;}
#};
#
#$variable_parser=Parse::RecDescent->new($grammar);
#$myvariable_parser=Parse::Stallion::RD->new($grammar);
#$variable_parser->start('abc');
#$myvariable_parser->start('abc');
#
$grammar = q {
{my %vars}
start: /\w/
};
#Parse::Stallion::RD->new($grammar);
$grammar = q {
{my %vars}
start: statements {$item[1]}
statements: statement ';' statements
| statement
statement: variable '=' statement {$vars {$item [1]} = $item [3]}
| expression {$item [1]}
expression: term '+' expression {$item [1] + $item [3]}
| term '-' expression {$item [1] - $item [3]}
| term
term: factor '*' term {$item [1] * $item [3]}
| factor '/' term {$item [1] / $item [3]}
| factor
factor: number
| variable {$vars {$item [1]} ||= 0 }
| '+' factor {$item [2]}
| '-' factor {$item [2] * -1}
| '(' statement ')' {$item [2]}
number: /\d+/ {$item [1]}
variable: /[a-z]+/i
};
my $calcrd_parser=Parse::RecDescent->new($grammar);
my $calc_parser=Parse::Stallion::RD->new($grammar);
$rd_result = $calcrd_parser->start("three=3;six=2*three;eight=three+5;2+eight*six+50");
$result = $calc_parser->start("three=3;six=2*three;eight=three+5;2+eight*six+50");
#print "\n";
#print "result is $result and rd results $rd_result\n";
is ($result, $rd_result, 'calculator with variables');
$string_out = '';
$grammar = q {
start: ('1') { $::string_out = $item[1] }
};
my $par_parser = Parse::Stallion::RD->new($grammar);
$par_parser->start('1');
is ($string_out, '1', 'parenthesized parser');
$string_out = '';
$par_parser->start('2');
is ($string_out, '', 'parenthesized parser on 2');
$string_out = '';
$grammar = q {
start: <leftop: '1' '2' '3' >
};
my $lord_parser=Parse::RecDescent->new($grammar);
$lp1 = $lord_parser->start('1232323');
$lp2 = $lord_parser->start('1');
$lp3 = $lord_parser->start('14');
$lp4 = $lord_parser->start('4');
my $lo_parser=Parse::Stallion::RD->new($grammar);
$mlp1 = $lo_parser->start('1232323');
$mlp2 = $lo_parser->start('1');
$mlp3 = $lo_parser->start('14');
$mlp4 = $lo_parser->start('4');
is_deeply($mlp1, $lp1, 'leftop 1');
is_deeply($mlp2, $lp2, 'leftop 2');
is_deeply($mlp3, $lp3, 'leftop 3');
is_deeply($mlp4, $lp4, 'leftop 4');
$grammar = q {
start: <rightop: '1' '2' '3' >
};
my $rord_parser=Parse::RecDescent->new($grammar);
$rlp1 = $rord_parser->start('1212123');
$rlp2 = $rord_parser->start('3');
$rlp3 = $rord_parser->start('34');
$rlp4 = $rord_parser->start('4');
my $ro_parser=Parse::Stallion::RD->new($grammar);
$rmlp1 = $ro_parser->start('1212123');
$rmlp2 = $ro_parser->start('3');
$rmlp3 = $ro_parser->start('34');
$rmlp4 = $ro_parser->start('4');
is_deeply ($rlp1, $rmlp1, 'rightop 1');
is_deeply ($rlp2, $rmlp2, 'rightop 2');
is_deeply ($rlp3, $rmlp3, 'rightop 3');
is_deeply ($rlp4, $rmlp4, 'rightop 4');
$grammar = q {
{my %vars}
start: statements {$item[1]}
statements: statement ';' statements
| statement
statement: <rightop: variable '=' expression>
{my $value = pop @{$item [1]};
while (@{$item [1]}) {
$vars {shift @{$item [1]}} = $value;
}
$value
}
expression: <leftop: term ('+' | '-') term>
{my $s = shift @{$item [1]};
while (@{$item [1]}) {
my ($op, $t) = splice @{$item [1]}, 0, 2;
if ($op eq '+') {$s += $t}
else {$s -= $t}
}
$s
}
term: <leftop: factor m{([*/])} factor>
{my $t = shift @{$item [1]};
while (@{$item [1]}) {
my ($op, $f) = splice @{$item [1]}, 0, 2;
if ($op eq '/') {$t /= $f}
else {$t *= $f}
}
$t
}
factor: number
| variable {$vars {$item [1]} ||= 0 }
| '+' factor {$item [2]}
| '-' factor {$item [2] * -1}
| '(' statement ')' {$item [2]}
number: /\d+/ {$item [1]}
variable: /[a-z]+/i
};
my $calclr_parser =Parse::RecDescent->new($grammar);
$rd_result = $calclr_parser->start("three=3;six=2*three;eight=three+5;2+eight*six+50");
my $calcrlr_parser =Parse::Stallion::RD->new($grammar);
$result = $calcrlr_parser->start("three=3;six=2*three;eight=three+5;2+eight*six+50");
#print "\n";
#print "result $result and rdr $rd_result\n";
is_deeply($result, $rd_result, 'leftop and rightop calculator');
#sqltest
# create_erd.pl
#
# Copyright (C) 2004 René Nyffenegger
#
# This source code is provided 'as-is', without any express or implied
# warranty. In no event will the authors be held liable for any damages
# arising from the use of this software.
#
# Permission is granted to anyone to use this software for any purpose,
# including commercial applications, and to alter it and redistribute it
# freely, subject to the following restrictions:
#
# 1. The origin of this source code must not be misrepresented; you must not
# claim that you wrote the original source code. If you use this source code
# in a product, an acknowledgment in the product documentation would be
# appreciated but is not required.
#
# 2. Altered source versions must be plainly marked as such, and must not be
# misrepresented as being the original source code.
#
# 3. This notice may not be removed or altered from any source distribution.
#
# René Nyffenegger rene.nyffenegger@adp-gmbh.ch
#
################################################################################
my $f=
"create table xxx (
xx varchar(3)
)";
my @f = split /\n/, $f;
my $create_table_grammar = q {
create_table_stmts : create_table_stmt(s?)
{ @item[1..$#item] }
create_table_stmt : /create/i /table/i table_name '(' rel_props ')' /;?/
{ {tab_nam => $item{table_name}, cols => $item{rel_props} } }
table_name : identifier
{$item[1]}
rel_props : columns #relational properties (according Oracle documentation)
{$item[1]}
columns : column ',' columns
{ if ($item[1]) { unshift @{$item[3]}, $item[1]} else {}; $item[3] }
| column
{ [ $item[1] ] }
column : out_of_line_constr
{ { col_nam=>'constraint' } }
| identifier reference_clause
{ $return = {col_nam=> $item{identifier}} ; @{$return}{keys %{$item{reference_clause}}} = values %{$item{reference_clause}} }
| identifier data_type primary_key(?) not_null(?) default(?)
{ {col_nam=>$item{identifier}, type=>$item{data_type}} }
out_of_line_constr : named_const constraint
| constraint
named_const : /constraint/i identifier
constraint : /check/i paranthesis
| /unique/i paranthesis
| /primary/i /key/i paranthesis
| /foreighn/i /key/i paranthesis
paranthesis : '(' in_paranthesis ')'
in_paranthesis : ( /[^()]+/ | paranthesis)(s)
reference_clause : /references/i identifier not_null(?)
{ { refd_table=>$item[2] } }
| data_type /references/i identifier not_null(?)
{ { type=>$item[1], refd_table=>$item[3] } }
default : /default/i sql_string
sql_string : /'([^']|'')*'/
primary_key : /primary/i /key/i
not_null : /not/i /null/i
data_type : dt_ident precision(?)
{$item[1]. $item[2][0] || "" }
precision : '(' number ')'
{$item[1].$item[2].$item[3]}
| '(' number ',' number ')'
{$item[1].$item[2].$item[3].$item[4].$item[5]}
dt_ident : /number/i {$item[1]}
| /int +identity/i {$item[1]}
| /int/i {$item[1]}
| /decimal/i {$item[1]}
| /smallint/i {$item[1]}
| /integer/i {$item[1]}
| /long raw/i {$item[1]}
| /long/i {$item[1]}
| /varchar2/i {$item[1]}
| /varchar/i {$item[1]}
| /char/i {$item[1]}
| /raw/i {$item[1]}
| /date/i {$item[1]}
| /smalldatetime/i {$item[1]}
| /blob/i {$item[1]}
| /clob/i {$item[1]}
| /nclob/i {$item[1]}
| /bit/i {$item[1]}
number : /\d+/
{ $item[1] }
identifier : m([A-Za-z_]\w*)
{$item[1]}
};
$sqlrd_parser=Parse::RecDescent->new($create_table_grammar);
$sql_parser=Parse::RecDescent->new($create_table_grammar);
my $in_comment=0;
my $l_temp;
LINE:
foreach my $l (@f) {
my $len = length $l;
$l_temp="";
my $first_quote =0; # only set when already $in_comment
my $asterik =0;
my $slash =0;
my $in_string =0;
my $hyphen =0;
for (my $i=0; $i<$len; $i++) {
my $c = substr($l, $i, 1);
if ($in_comment) {
if ($c eq "*") {
$asterik = 1;
}
elsif ($c eq "/") {
if ($asterik) {
$asterik = 0;
$slash = 0;
$in_comment = 0;
}
}
else {
$asterik = 0;
}
}
else {
if ($in_string) {
if ($c eq "'") {
if ($first_quote) {
$first_quote = 0;
$l_temp .= $c;
}
else {
$first_quote = 1;
$l_temp .= $c;
}
}
}
elsif ($c eq "/") {
if ($slash) {
$l_temp .= "/";
}
else {
$slash = 1;
}
}
elsif ($c eq "*") {
if ($slash) {
$in_comment = 1;
}
else {
$l_temp .= $c;
}
}
elsif ($c eq "-") {
if ($hyphen) {
$l_temp .= "\n";
next LINE;
}
else {
$hyphen = 1;
}
}
elsif ($hyphen) {
$hyphen = 0;
$l_temp .= "-$c";
}
elsif ($first_quote) {
$in_string = 0;
$first_quote = 0;
$l_temp .= $c;
}
else {
$l_temp .= $c;
}
}
}
}
continue {
$l = $l_temp;
}
# print join " ", @f;
$rd_result = $sqlrd_parser->create_table_stmts(join " ", @f);
$result = $sql_parser->create_table_stmts(join " ", @f);
#sqltest End: Copyright (C) 2004 René Nyffenegger
is_deeply($rd_result, $result, 'sql test');
$::RD_AUTOACTION = q { $::i++; };
$grammar = q {
start : char_1 char_2 char_3 { ; }
char_1 : character
char_2 : character
char_3 : character { $::i+=4 }
character: /\w/
};
my $myauto_parser2=Parse::Stallion::RD->new($grammar);
$myauto_parser2->start('abc');
is ($i, 9, 'auto action only on those without actions');
$::RD_AUTOACTION = '';
$i = 0;
$grammar = q {
{$::i++}
{$::i++}
start : char_1 char_2 char_3
char_1 : character
char_2 : character
char_3 : character
character: /\w/
};
my $preparser=Parse::Stallion::RD->new($grammar);
$preparser->start('abc');
is ($i, 2, 'multiple initial actions');
$grammar = q {
start : char_1 char_2 char_3
char_1 : character
char_2 : '9'
char_1 : '88'
char_3 : character
character: /\w/
};
my $orlparser=Parse::Stallion::RD->new($grammar);
my $rdorlparser=Parse::RecDescent->new($grammar);
$result = $orlparser->start('a9c');
is ($result, 'c', 'rule split over 2 lines 1');
$rd_result = $rdorlparser->start('a9c');
is ($rd_result, 'c', 'rule split over 2 lines 1 rd');
$result = $orlparser->start('889c');
#test case lost some meaning with match_once added
is ($result, undef, 'rule split over 2 lines 2');
$rd_result = $rdorlparser->start('889c');
is ($rd_result, undef, 'rule split over 2 lines 2');
$result = $orlparser->start('879c');
is ($result, undef, 'rule split over 2 lines 3');
$grammar = q {
start: seq(s)
seq : 'A' 'B' ...'C'
{ $::string_out .= "$item{__STRING1__} $item{__STRING2__} eaten, $item{__STRING3__} follows\n"}
| 'A' 'B' character
{ $::string_out .= "$item{__STRING1__} $item{__STRING2__} $item{character} eaten\n"}
| character character
{ $::string_out .= "two characters eaten: $item{character} and $item{character}\n" }
character: /\w/
};
$nlarrd_parser=Parse::RecDescent->new($grammar);
$nla_parser=Parse::Stallion::RD->new($grammar);
$string_out = '';
$nlarrd_parser->start("A B Q P A B E A B C A B X");
$preserve_string_out = $string_out;
$string_out = '';
$nla_parser->start("A B Q P A B E A B C A B X");
is($string_out, $preserve_string_out, 'hash names of items ');
$string_out = '';
$grammar = q {
start: seq(s)
seq : 'A' ('B' 'C' | 'E' 'F')
{ $::string_out .= join("..", %item) }
};
$rdsubrule_parser=Parse::RecDescent->new($grammar);
$rdsubrule_parser->start("A B C");
$preserve_string_out = $string_out;
#print "PString out is $string_out\n";
$string_out = '';
$subrule_parser=Parse::Stallion::RD->new($grammar);
$subrule_parser->start("A B C");
#print "String out is $string_out\n";
$grammar = q {
start: char char {undef} |
'1' '2' {3}
char: /\w/
};
$rdun_parser=Parse::RecDescent->new($grammar);
$un_parser=Parse::Stallion::RD->new($grammar);
$t = $rdun_parser->start('12');
$u = $un_parser->start('12');
is($u,$t, 'undef action');
$grammar = q {
start: char char <reject> |
'1' '2' {3}
char: /\w/
};
$rdrejun_parser=Parse::RecDescent->new($grammar);
$rejun_parser=Parse::Stallion::RD->new($grammar);
$t = $rdrejun_parser->start('12');
$u = $rejun_parser->start('12');
is($u,$t, 'undef action');
$grammar = q {
start: char char <reject:$::x> |
'1' '2' {3}
char: /\w/
};
$xrdrejun_parser=Parse::RecDescent->new($grammar);
$xrejun_parser=Parse::Stallion::RD->new($grammar);
$t = $xrdrejun_parser->start('12');
$u = $xrejun_parser->start('12');
is($u,$t, 'x undef action 1');
$x = 1;
$t = $xrdrejun_parser->start('12');
$u = $xrejun_parser->start('12');
is($u,$t, 'x undef action 2');
$grammar = q {
start: 'q' <commit> {$::x++} 'r' |
'q' {$::x++} 't'
};
$rdqr_parser=Parse::RecDescent->new($grammar);
$qr_parser=Parse::Stallion::RD->new($grammar);
$x = 0;
$t = $rdqr_parser->start('qu');
is ($x, 1, 'committed');
$x = 0;
$t = $qr_parser->start('qu');
is ($x, 1, 'committed stallion');
$grammar = q {
start: 'q' {$::x++} 'r' |
'q' {$::x++} 't'
};
$ncrdqr_parser=Parse::RecDescent->new($grammar);
$ncqr_parser=Parse::Stallion::RD->new($grammar);
$x = 0;
$t = $ncrdqr_parser->start('qu');
is ($x, 2, 'no committed');
$x = 0;
$t = $ncqr_parser->start('qu');
is ($x, 2, 'no committed stallion');
$grammar = q {
start: 'q' <commit> {$::x++} 'r' |
'q' {$::x++} 't' |
<uncommit> 'q' {$::x++} 'u'
};
$urdqr_parser=Parse::RecDescent->new($grammar);
$uqr_parser=Parse::Stallion::RD->new($grammar);
$x = 0;
$t = $urdqr_parser->start('qu');
is ($x, 2, 'uncommitted');
$x = 0;
$t = $uqr_parser->start('qu');
is ($x, 2, 'uncommitted stallion');
$grammar = q {
start: 'q' <commit> {$::x++} subrule |
'q' {$::x+=2} 't' |
<uncommit> 'q' {$::x+=4} frule |
'q' {$::x+=8} 'X'
subrule: 'r' {$::x+=128} |
<uncommit> 'f' {$::x+=16} 'h'
frule: 'f' <commit> {$::x+=32} 'i' |
'f' {$::x+=64} 'X'
};
$curdqr_parser=Parse::RecDescent->new($grammar);
$cuqr_parser=Parse::Stallion::RD->new($grammar);
$x = 0;
$t = $curdqr_parser->start('qfj');
is ($x, 61, 'commits and uncommitted');
$x = 0;
$t = $cuqr_parser->start('qfj');
is ($x, 61, 'commits and uncommitted stallion');
$grammar = q {
start: subrule
subrule: another_subrule
another_subrule: 'f'
};
$rd_three_parser=Parse::RecDescent->new($grammar);
$three_parser=Parse::Stallion::RD->new($grammar);
$t = $three_parser->start('f');
$u = $rd_three_parser->start('f');
is ($t, $u, 'three parser');
$grammar = q {
st : 'q' | 'r' | <error> | 'j'
};
#print "with i not j\n";
$err_parser = new Parse::Stallion::RD($grammar);
#print "err parser set\n";
open OLDERR, ">&", \*STDERR ;
close OLDERR; #to get rid of warning message that OLDERR is only used once
open OLDERR, ">&", \*STDERR ;
open (local *STDERR, '>', \($error_message));
$result = $err_parser->st("i");
like ($error_message, qr/ERROR \(line 1\): Invalid st: Was expecting 'q', or 'r'/, 'simple error');
open (local *STDERR, '>', \($error_message));
#$rderr_parser = new Parse::RecDescent($grammar);
#$result = $rderr_parser->st("i");
$result = $err_parser->st("j");
$error_message = '';
is ($error_message, '', 'simple error j');
#$result = $rderr_parser->st("j");
#print "just q and error\n";
$grammar = q {
st : 'q' | <error>
};
$sherr_parser = new Parse::Stallion::RD($grammar);
$error_message = '';
open (local *STDERR, '>', \($error_message));
$result = $sherr_parser->st("i");
like ($error_message, qr/ERROR \(line 1\): Invalid st: Was expecting 'q'/, 'just q error');
#$shrderr_parser = new Parse::RecDescent($grammar);
#$result = $shrderr_parser->st("i");
$grammar = q {
McCoy: curse ',' name ", I'm a doctor, not a" a_profession '!
'
| pronoun 'dead,' name '!'
| 'xxx'
| pronoun 'xxx'
| <error>
curse: 'darn'
name: 'Jim' | 'Spock'
pronoun: "He's" | "She's"
a_profession: 'Computer Programmer'
};
$mcerr_parser = new Parse::Stallion::RD($grammar);
#$rdmcerr_parser = new Parse::RecDescent($grammar);
open (local *STDERR, '>', \($error_message));
$result = $mcerr_parser->McCoy("Amen, Jim");
like ($error_message, qr/ERROR \(line 1\): Invalid McCoy: Was expecting curse, or pronoun, or 'xxx', or pronoun/, 'curse or pronoun or xxx');
#$result = $rdmcerr_parser->McCoy("Amen, Jim");
open (local *STDERR, '>', \($error_message));
$result = $mcerr_parser->McCoy("He's alive!");
like ($error_message, qr/Invalid McCoy: Was expecting 'dead,' but found "alive!" instead/, 'alive error');
#$result = $rdmcerr_parser->McCoy("He's alive!");
$grammar = q {
start2 : start | 'x'
start : sub_rule1 | sub_rule2 | sub_rule3
sub_rule1 : 'q' | 'b' | <error>
sub_rule2 : 'r' | 's' | <error>
sub_rule3 : 'u' | 't' | <error>
};
#print "with t\n";
$error_message = '';
$multierr_parser = new Parse::Stallion::RD($grammar);
open (local *STDERR, '>', \($error_message));
$result = $multierr_parser->start("t");
is ($error_message, '', 't on three error has no error');
#print "result is $result\n";
#$multirderr_parser = new Parse::RecDescent($grammar);
#$result = $multirderr_parser->start("t");
#print "result is $result\n";
#print "with v\n";
open (local *STDERR, '>', \($error_message));
$result = $multierr_parser->start("v");
is ($error_message, " ERROR (line 1): Invalid sub_rule1: Was expecting 'q', or 'b'
ERROR (line 1): Invalid sub_rule2: Was expecting 'r', or 's'
ERROR (line 1): Invalid sub_rule3: Was expecting 'u', or 't'
", "multi error on v");
#$result = $multirderr_parser->start("v");
#print "with x\n";
open (local *STDERR, '>', \($error_message));
$result = $multierr_parser->start2("x");
is ($error_message, "", 'x on multi err should work');
#print "result is $result\n";
#$result = $multirderr_parser->start2("x");
#print "result is $result\n";
$grammar = q {
start : 'do' <commit> something
| 'report' <commit> something
| <error?> <error:badbad>
something : 'something'
};
$commite_parser = new Parse::Stallion::RD($grammar);
#$commiterd_parser = new Parse::RecDescent($grammar);
#print "do commit\n";
open (local *STDERR, '>', \($error_message));
$result = $commite_parser->start('do x');
is ($error_message, " ERROR (line 1): Invalid start: Was expecting something but found \"x\" instead
", 'do on x');
#$result = $commiterd_parser->start('do x');
#print "undo commit\n";
open (local *STDERR, '>', \($error_message));
$result = $commite_parser->start('undo x');
is ($error_message, ' ERROR (line 1): badbad
', 'bad bad test');
#$result = $commiterd_parser->start('undo x');
#print "em is $error_message\n";
$grammar = q {
lines_then_st: 'g' st
st: 'q' | 'r' | <error> | 'j'
};
#$rdline_err_parser = new Parse::RecDescent($grammar);
#$results = $rdline_err_parser->lines_then_st("
#gf");
#print "results is $results\n";
#print "error message $error_message\n";
open (local *STDERR, '>', \($error_message));
$line_err_parser = new Parse::Stallion::RD($grammar);
$result = $line_err_parser->lines_then_st("
gf");
#print "results is $results\n";
#print "error message $error_message\n";
is ($error_message, " ERROR (line 6): Invalid st: Was expecting 'q', or 'r'
", 'line 6 error');
$grammar = q {
sentence: noun trans noun
| noun intrans
noun: 'the dog'
<defer: $::string_out .= "$item[1]\t(noun)\n" >
| 'the meat'
<defer: $::string_out .= "$item[1]\t(noun)\n" >
trans: 'ate'
<defer: $::string_out .= "$item[1]\t(transitive)\n" >
intrans: 'ate'
<defer: $::string_out .= "$item[1]\t(intransitive)\n" >
| 'barked'
<defer: $::string_out .= "$item[1]\t(intransitive)\n" >
};
open STDERR, ">&OLDERR";
$nti_parser = new Parse::Stallion::RD($grammar);
$string_out = '';
$result = $nti_parser->sentence("the dog ate");
$preserve_string_out = $string_out;
$string_out = '';
$rdnti_parser = new Parse::RecDescent($grammar);
$result = $rdnti_parser->sentence("the dog ate");
is ($preserve_string_out, $string_out, 'deferred action');
$grammar = q {
start: <leftop: '1' char '3' > { my @items = @item;
$::item_list = \@items;
my %itemh = %item;
$::item_hash = \%itemh;
1;}
char: /\w/
};
my $rd_lftopchar_parser=Parse::RecDescent->new($grammar);
$rd_lftopchar_parser->start("1232323");
$rd_item_list = $item_list;
$rd_item_hash = $item_hash;
delete $rd_item_hash->{__STRING1__};
delete $rd_item_hash->{__STRING2__};
delete $rd_item_hash->{char};
my $lftopchar_parser=Parse::Stallion::RD->new($grammar);
$lftopchar_parser->start("1232323");
is($#{$item_list->[1]}, 6, 'item list count of leftop');
is_deeply($item_list, $rd_item_list, 'item list of leftop');
is_deeply($item_hash, $rd_item_hash, 'item hash of leftop');
$grammar = q {
start: char(?) chas(0..1) chat(1..1) chau(0..) chav(..1) { my @items = @item;
$::item_list = \@items;
my %itemh = %item;
$::item_hash = \%itemh;
1;}
char: '1'
chas: '2'
chat: '3'
chau: '4'
chav: '5'
};
my $rd_rep_parser = new Parse::RecDescent($grammar);
my $rep_parser = new Parse::Stallion::RD($grammar);
$rd_rep_parser->start("12345");
$rd_item_list = $item_list;
$rd_item_hash = $item_hash;
$rep_parser->start("12345");
is($#{$item_list}, 5, 'item list count of rep');
is_deeply($item_list, $rd_item_list, 'item list of rep');
is_deeply($item_hash, $rd_item_hash, 'item hash of rep');
$grammar = q {
start: 'a' 'b' <defer: my @items = @item;
$::item_list = \@items;
my %itemh = %item;
$::item_hash = \%itemh;> 'c' 'd'
};
my $rd_defil_parser = new Parse::RecDescent($grammar);
my $defil_parser = new Parse::Stallion::RD($grammar);
$rd_defil_parser->start("abcd");
$rd_item_list = $item_list;
$rd_item_hash = $item_hash;
$defil_parser->start("abcd");
is($#{$item_list}, 5, 'item list count of deferred');
is_deeply($item_list, $rd_item_list, 'item list of deferred');
is_deeply($item_hash, $rd_item_hash, 'item hash of deferred');
$grammar = q {
start: char char <defer: my @items = @item;
$::item_list = \@items;
my %itemh = %item;
$::item_hash = \%itemh;> 'x' { my @items = @item;
$::item_list2 = \@items;
my %itemh = %item;
$::item_hash2 = \%itemh;} char char
char: /\w/
};
my $rd_defactil_parser = new Parse::RecDescent($grammar);
my $defactil_parser = new Parse::Stallion::RD($grammar);
$rd_defactil_parser->start("abxcd");
$rd_item_list = $item_list;
$rd_item_hash = $item_hash;
$rd_item_list2 = $item_list2;
$rd_item_hash2 = $item_hash2;
$item_list = undef;
$item_list2 = undef;
$item_hash = undef;
$item_hash2 = undef;
$defactil_parser->start("abxcd");
#print "rdih ".Dumper($rd_item_hash)."\n";
#print "ih ".Dumper($item_hash)."\n";
#print "rdih2 ".Dumper($rd_item_hash2)."\n";
#print "ih2 ".Dumper($item_hash2)."\n";
delete $item_hash2->{__ACTION1__}; # misbehavior?
delete $item_hash->{__ACTION1__}; # Parse::RecDescent preserves the list at
# a certain state but not the hash
delete $rd_item_hash2->{__ACTION1__}; # Some Parse::RecDescents have this
delete $rd_item_hash->{__ACTION1__}; # Some Parse::RecDescents have this
is($#{$item_list}, 7, 'item list count of deferred and action');
is($#{$item_list2}, 4, 'item list count of deferred and action');
is_deeply($item_list, $rd_item_list, 'item list of deferred and action');
is_deeply($item_hash, $rd_item_hash, 'item hash of deferred and action');
is_deeply($item_list2, $rd_item_list2, 'item list 2 of deferred and action');
is_deeply($item_hash2, $rd_item_hash2, 'item hash 2 of deferred and action');
$grammar = q {
start: char char <defer: my @items = @item;
$::item_list = \@items;
my %itemh = %item;
$itemh{'goof'} = 'x';
$::item_hash = \%itemh;> { my @items = @item;
$::item_list2 = \@items;
my %itemh = %item;
$::item_hash2 = \%itemh;} char char
char: /\w/
};
my $rd_xdefactil_parser = new Parse::RecDescent($grammar);
my $xdefactil_parser = new Parse::Stallion::RD($grammar);
$rd_xdefactil_parser->start("abcd");
$rd_item_list = $item_list;
$rd_item_hash = $item_hash;
$rd_item_list2 = $item_list2;
$rd_item_hash2 = $item_hash2;
$xdefactil_parser->start("abcd");
#print "rdih ".Dumper($rd_item_hash)."\n";
#print "ih ".Dumper($item_hash)."\n";
#print "rdih2 ".Dumper($rd_item_hash2)."\n";
#print "ih2 ".Dumper($item_hash2)."\n";
delete $item_hash2->{__ACTION1__}; #see comment below
delete $item_hash->{__ACTION1__}; # Parse::RecDescent preserves the list at
# a certain state but not the hash in this case, not sure why. out of date??
delete $rd_item_hash2->{__ACTION1__}; # Some Parse::RecDescents have this
delete $rd_item_hash->{__ACTION1__}; # Some Parse::RecDescents have this
is($item_hash->{goof}, 'x', 'item hash of goof');
is($#{$item_list}, 6, 'item list count of deferred and action no x');
is($#{$item_list2}, 3, 'item list count of deferred and action no x');
is_deeply($item_list, $rd_item_list, 'item list of deferred and action no x');
is_deeply($item_hash, $rd_item_hash, 'item hash of deferred and action no x');
is_deeply($item_list2, $rd_item_list2,
'item list 2 of deferred and action no x');
is_deeply($item_hash2, $rd_item_hash2,
'item hash 2 of deferred and action no x');
$pre_rd = $Parse::RecDescent::skip;
$Parse::RecDescent::skip = 'x';
$pre = $Parse::Stallion::RD::skip;
$Parse::Stallion::RD::skip = 'x';
$grammar = q {
start: 'a' 'b' {1; } 'c'
};
my $parser_rd_xxx = new Parse::RecDescent($grammar);
my $parser_xxx = new Parse::Stallion::RD($grammar);
$c = $parser_rd_xxx->start("xaxbxcx");
$d = $parser_xxx->start("xaxbxcx");
is ($c, $d, "skip with x");
is ($c, 'c', "skip with cx");
$Parse::RecDescent::skip = $pre_rd;
$Parse::Stallion::RD::skip = $pre;
$grammar = q {
start: <skip:","> csv(s) <skip:$item[1]> 'g' 't'
csv: 'r'
};
my $parser_rd_skipping = new Parse::RecDescent($grammar);
my $parser_skipping = new Parse::Stallion::RD($grammar);
$c = $parser_rd_skipping->start(",r,r,r,r g t");
$d = $parser_skipping->start(",r,r,r,r g t");
is ($d, $c, "skipping set");
is ($c, 't', "skipping sett");
#print "skip c is $c\n";
$grammar = q {
check : start
start : seq_1 seq_2 | seq_1 seq_3
seq_1 : 'A' 'B'
| 'A' 'B' 'C'
seq_2 : 'D' 'E' | 'E' 'F' | 'G' 'H'
seq_3 : 'Z' 'Y' | 'X' 'V'
};
my $chc_parser = new Parse::Stallion::RD($grammar);
my $rd_chc_parser = new Parse::RecDescent($grammar);
$result = $chc_parser->check('ABCXV'); #parses
$rd_result = $rd_chc_parser->check('ABCXV'); #does not parse
is_deeply($result, $rd_result, 'different no more');
}
print "All done\n";