289 lines
7.5 KiB
Perl
Executable File
289 lines
7.5 KiB
Perl
Executable File
# Before `make install' is performed this script should be runnable with
|
|
# `make test'. After `make install' it should work as `perl test.pl'
|
|
|
|
######################### We start with some black magic to print on failure.
|
|
|
|
# Change 1..1 below to 1..last_test_to_print .
|
|
# (It may become useful if the test is moved to ./t subdirectory.)
|
|
|
|
BEGIN { $| = 1; print "1..32\n"; }
|
|
END {print "not ok 1\n" unless $loaded;}
|
|
use Parse::RecDescent;
|
|
$loaded = 1;
|
|
print "ok 1\n";
|
|
|
|
sub debug { $D || $D || 0 }
|
|
|
|
my $count = 2;
|
|
sub ok($;$)
|
|
{
|
|
my $ok = ((@_==2) ? ($_[0] eq $_[1]) : $_[0]);
|
|
print "\texp=[$_[1]]\n\tres=[$_[0]]\n" if debug && @_==2;
|
|
print "not " unless $ok;
|
|
print "ok $count\n";
|
|
$count++;
|
|
return $ok;
|
|
}
|
|
|
|
######################### End of black magic.
|
|
|
|
do { $RD_TRACE = 1; $RD_HINT = 1; } if debug > 1;
|
|
|
|
$data1 = '(the 1st teeeeeest are easy easy easyeasy';
|
|
$expect1 = '[1st|teeeeeest|are|easy:easy:easy:easy]';
|
|
|
|
$data2 = '(the 2nd test is';
|
|
$expect2 = '[2nd|test|is|]';
|
|
|
|
$data3 = 'the cat';
|
|
$expect3a = 'fluffy';
|
|
$expect3b = 'not fluffy';
|
|
|
|
$data4 = 'a dog';
|
|
$expect4 = 'rover';
|
|
|
|
$data5 = 'type a is int; type b is a; var x holds b; type c is d;';
|
|
$expect5 = 'typedef=>a, typedef=>b, defn=>x, baddef, baddef';
|
|
|
|
require './t/util.pl';
|
|
|
|
##################################################################
|
|
|
|
$parser_A = new Parse::RecDescent q
|
|
{
|
|
test1: "(" 'the' "$::first" /te+st/ is ('easy')(s?)
|
|
{ "[$item[3]|$item[4]|$item[5]|" .
|
|
join(':', @{$item[6]}) .
|
|
']' }
|
|
|
|
is: 'is' | 'are'
|
|
|
|
#================================================================#
|
|
|
|
test2: <matchrule:$arg{article}>
|
|
<matchrule:$arg[3]>[$arg{sound}]
|
|
|
|
the: 'the'
|
|
a: 'a'
|
|
|
|
cat: <reject: $arg[0] ne 'meows'> 'cat'
|
|
{ "fluffy" }
|
|
| { "not fluffy" }
|
|
|
|
dog: 'dog'
|
|
{ "rover" }
|
|
|
|
#================================================================#
|
|
|
|
test3: (defn | typedef | fail)(5..10)
|
|
{ join ', ', @{$item[1]}; }
|
|
|
|
typedef: 'type' id 'is' typename ';'
|
|
{ $return = "$item[0]=>$item[2]";
|
|
$thisparser->Extend("typename: '$item[2]'"); }
|
|
|
|
fail: { 'baddef' }
|
|
|
|
defn: 'var' id 'holds' typename ';'
|
|
{ "$item[0]=>$item[2]" }
|
|
|
|
id: /[a-z] # LEADING ALPHABETIC
|
|
\w* # FOLLOWED BY ALPHAS, DIGITS, OR UNDERSCORES
|
|
/ix # CASE INSENSITIVE
|
|
|
|
typename: 'int'
|
|
|
|
#================================================================#
|
|
|
|
test4: 'a' b /c/
|
|
{ "$itempos[1]{offset}{from}:$itempos[2]{offset}{from}:$itempos[3]{offset}{from}" }
|
|
|
|
b: "b"
|
|
|
|
#================================================================#
|
|
|
|
test5: ...!name notname | name
|
|
|
|
notname: /[a-z]\w*/i { 'notname' }
|
|
|
|
name: 'fred' { 'name' }
|
|
|
|
#================================================================#
|
|
|
|
test6: <rulevar: $test6 = 1>
|
|
test6: 'a' <commit> 'b' <uncommit> 'c' <reject: $test6 && $text>
|
|
{ 'prod 1' }
|
|
| 'a'
|
|
{ 'prod 2' }
|
|
| <uncommit>
|
|
{ 'prod 3' }
|
|
|
|
#================================================================#
|
|
|
|
test7: 'x' <resync> /y+/
|
|
{ $return = $item[3] }
|
|
|
|
#================================================================#
|
|
|
|
test8: 'a' b /c+/ 'dddd' e 'f'
|
|
{ &::make_itempos_text(\@item, \@itempos); }
|
|
|
|
e: /ee/
|
|
|
|
#================================================================#
|
|
|
|
test9: 'a' d(s) /c/
|
|
{ &::make_itempos_text(\@item, \@itempos); }
|
|
|
|
d: 'd' 'd' 'd'
|
|
|
|
};
|
|
|
|
ok ($parser_A) or exit;
|
|
|
|
|
|
|
|
##################################################################
|
|
$first = "1st";
|
|
$res = $parser_A->test1($data1);
|
|
ok($res,$expect1);
|
|
|
|
##################################################################
|
|
$first = "2nd";
|
|
$res = $parser_A->test1($data2);
|
|
ok($res,$expect2);
|
|
|
|
##################################################################
|
|
$res = $parser_A->test2($data3,undef,
|
|
article=>'the', animal=>'cat', sound=>'meows');
|
|
ok($res,$expect3a);
|
|
|
|
##################################################################
|
|
$res = $parser_A->test2($data3,undef,
|
|
article=>'the', animal=>'cat', sound=>'purrs');
|
|
ok ($res,$expect3b);
|
|
|
|
##################################################################
|
|
$res = $parser_A->test2($data4,undef,
|
|
article=>'a', animal=>'dog', sound=>'barks');
|
|
ok($res,$expect4);
|
|
|
|
##################################################################
|
|
$res = $parser_A->test3($data5);
|
|
ok($res,$expect5);
|
|
|
|
##################################################################
|
|
$res = $parser_A->test4("a b c");
|
|
ok($res, "0:3:7");
|
|
|
|
##################################################################
|
|
$res = $parser_A->test5("fred");
|
|
ok($res, "name");
|
|
|
|
$res = $parser_A->test5("fled");
|
|
ok($res, "notname");
|
|
|
|
##################################################################
|
|
$res = $parser_A->test6("a b d");
|
|
ok($res, "prod 2");
|
|
|
|
$res = $parser_A->test6("a c d");
|
|
ok($res, "prod 3");
|
|
|
|
$res = $parser_A->test6("a b c");
|
|
ok($res, "prod 1");
|
|
|
|
$res = $parser_A->test6("a b c d");
|
|
ok($res, "prod 2");
|
|
|
|
##################################################################
|
|
$res = $parser_A->test7("x yyy \n y");
|
|
ok($res, "y");
|
|
|
|
##################################################################
|
|
|
|
$res = $parser_A->test8("a\n b\n cccccccccc\ndddd ee\n f");
|
|
ok($res,'
|
|
a offset.from= 0 offset.to= 0 line.from= 1 line.to= 1 column.from= 1 column.to= 1
|
|
b offset.from= 3 offset.to= 3 line.from= 2 line.to= 2 column.from= 2 column.to= 2
|
|
cccccccccc offset.from= 7 offset.to= 16 line.from= 3 line.to= 3 column.from= 3 column.to= 12
|
|
dddd offset.from= 18 offset.to= 21 line.from= 4 line.to= 4 column.from= 1 column.to= 4
|
|
ee offset.from= 26 offset.to= 27 line.from= 4 line.to= 4 column.from= 9 column.to= 10
|
|
f offset.from= 32 offset.to= 32 line.from= 5 line.to= 5 column.from= 4 column.to= 4
|
|
');
|
|
|
|
##################################################################
|
|
$res = $parser_A->test9("a\n d d \n d d d d \n d d d\nc\n");
|
|
ok($res,'
|
|
a offset.from= 0 offset.to= 0 line.from= 1 line.to= 1 column.from= 1 column.to= 1
|
|
_REF_ offset.from= 3 offset.to= 23 line.from= 2 line.to= 4 column.from= 2 column.to= 6
|
|
c offset.from= 25 offset.to= 25 line.from= 5 line.to= 5 column.from= 1 column.to= 1
|
|
');
|
|
|
|
##################################################################
|
|
|
|
|
|
package Derived;
|
|
|
|
@ISA = qw { Parse::RecDescent };
|
|
sub method($$) { reverse $_[1] }
|
|
|
|
package main;
|
|
|
|
$parser_B = new Derived q
|
|
{
|
|
test1: /[a-z]+/i
|
|
{ reverse $item[1] }
|
|
{ $thisparser->method($item[2]) }
|
|
};
|
|
|
|
ok ($parser_B) or exit;
|
|
##################################################################
|
|
$res = $parser_B->test1("literal string");
|
|
ok($res, "literal");
|
|
|
|
#################################################################
|
|
$res = $parser_A->Extend("extended : 'some extension'");
|
|
ok(@{"$parser_A->{namespace}::ISA"} == 1);
|
|
|
|
#################################################################
|
|
package main;
|
|
|
|
# Ensure that regex modifiers (like /x below) get interpreted
|
|
$parser = new Parse::RecDescent q
|
|
{
|
|
test : /\. # a literal period
|
|
(Test)?
|
|
/x
|
|
};
|
|
ok($parser) or exit;
|
|
ok($parser->test("."));
|
|
ok($parser->test(".Test"));
|
|
ok($parser->test(".Test"));
|
|
|
|
|
|
#################################################################
|
|
$parser = new Parse::RecDescent q
|
|
{
|
|
whatever : /\\\\/ | /whatever/
|
|
};
|
|
ok ($parser) or exit;
|
|
|
|
ok($parser->whatever(" \\ "));
|
|
ok($parser->whatever(" whatever "));
|
|
|
|
|
|
#################################################################
|
|
# Check that changing some Data::Dumper variables don't break the
|
|
# parsers
|
|
foreach my $terse (0..1) {
|
|
local $Data::Dumper::Terse = $terse;
|
|
$parser = new Parse::RecDescent q{
|
|
startrule : string
|
|
string : "hello"
|
|
};
|
|
|
|
ok ($parser) or exit;
|
|
ok($parser->startrule("hello"));
|
|
}
|