1$DEBUG=0; 2$|=1; 3 4@tests=( 5 [ #1 Basic test 6<<'EOT' 7%{ my $out; %} 8%% 9S: A { return($out) } ; 10A: 'a' 'b' 'c' D { $out=$_[1].$_[2].$_[3].$_[4]; undef } ; 11D: 'd' ; 12%% 13EOT 14, [ 'a','b','c','d' ], "abcd" 15],[ #2 In rule actions 16<<'EOT' 17%{ my $out; %} 18%% 19S: A { return($out) } ; 20A: 'a' { $out=$_[1] } 'b' { $out.=$_[3]} 'c' { $out.=$_[5]} 21 D { $out.=$_[7].$_[5].$_[3].$_[1] } ; 22D: 'd' ; 23%% 24EOT 25, [ 'a', 'b', 'c', 'd' ], "abcdcba" 26],[ #3 YYSemval > 0 27<<'EOT' 28%{ my $out; %} 29%% 30S: A { return($out) } ; 31A: 'a' 'b' 'c' D { $out.=$_[0]->YYSemval(1). 32 $_[0]->YYSemval(2). 33 $_[0]->YYSemval(3). 34 $_[0]->YYSemval(4); 35 undef 36 } 37; 38D: 'd' ; 39%% 40EOT 41, [ 'a', 'b', 'c', 'd' ], "abcd" 42],[ #4 YYSemval < 0 43<<'EOT' 44%{ my $out; %} 45%% 46S: A { return($out) } ; 47A: 'a' 'b' X ; 48X: 'c' 'd' { $out=$_[0]->YYSemval(-1).$_[0]->YYSemval(0).$_[1].$_[2] }; 49%% 50EOT 51, [ 'a', 'b', 'c', 'd' ], "abcd" 52],[ #5 Left assoc 53<<'EOT' 54%{ my $out; %} 55%left '*' 56%% 57S: A { return($out) } ; 58A: A '*' A { $out="($_[1]$_[2]$_[3])" } 59 | B 60; 61B: 'a' | 'b' | 'c' | 'd' ; 62%% 63EOT 64, [ 'a', '*', 'b', '*', 'c', '*', 'd' ], "(((a*b)*c)*d)" 65],[ #6 Right assoc 66<<'EOT' 67%{ my $out; %} 68%right '*' 69%% 70S: A { return($out) } ; 71A: A '*' A { $out="($_[1]$_[2]$_[3])" } 72 | B 73; 74B: 'a' | 'b' | 'c' | 'd' ; 75%% 76EOT 77, [ 'a', '*', 'b', '*', 'c', '*', 'd' ], "(a*(b*(c*d)))" 78], 79[ #7 nonassoc 80<<'EOT' 81%{ my $out; %} 82%nonassoc '+' 83#%left '+' 84%% 85S: S '+' S { $out } 86 | 'a' 87 | error { $out="nonassoc" } 88 ; 89%% 90EOT 91, [ 'a' , '+', 'a', '+', 'a' ], "nonassoc" 92], 93[ #8 Left assoc with '\\' 94<<'EOT' 95%{ my $out; %} 96%left '\\' 97%% 98S: A { return($out) } ; 99A: A '\\' A { $out="($_[1]$_[2]$_[3])" } 100 | B 101; 102B: 'a' | 'b' | 'c' | 'd' ; 103%% 104EOT 105, [ 'a', '\\', 'b', '\\', 'c', '\\', 'd' ], '(((a\b)\c)\d)' 106], 107); 108 109use Parse::Yapp; 110 111my($count)=0; 112 113sub TestIt { 114 my($g,$in,$chk)=@_; 115 116 my($lex) = sub { 117 my($t)=shift(@$in); 118 119 defined($t) 120 or $t=''; 121 return($t,$t); 122 }; 123 124 ++$count; 125 126 my($p)=new Parse::Yapp(input => $g); 127 $p=$p->Output(classname => 'Test'); 128 129 $DEBUG 130 and print $p; 131 132 eval $p; 133 $@ 134 and do { 135 print "$@\n"; 136 print "not ok $count\n"; 137 return; 138 }; 139 140 $p=new Test(yylex => $lex, yyerror => sub {}); 141 142 $out=$p->YYParse; 143 undef $p; 144 145 $out eq $chk 146 or do { 147 print "Got '$out' instead of '$chk'\n"; 148 print 'not '; 149 }; 150 print 'ok'," $count\n"; 151 undef(&Test::new); 152} 153 154print '1..'.@tests."\n"; 155 156for (@tests) { 157 TestIt(@$_); 158} 159