http-webtest-commits

[Ilya M. <m_...@us...>]

Update of /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest
In directory usw-pr-cvs1:/tmp/cvs-serv19904/lib/HTTP/WebTest

Modified Files:
	Parser.pm 
Log Message:
Improve syntax error reporting in parser of wtscript files
Support for embeded Perl in wtscript files in parser


Index: Parser.pm
===================================================================
RCS file: /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest/Parser.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Parser.pm	2002/01/28 09:49:56	1.2
--- Parser.pm	2002/01/29 03:52:40	1.3
***************
*** 25,28 ****
--- 25,29 ----
  use IO::File;
  use Parse::RecDescent;
+ use Text::Balanced qw(extract_codeblock extract_delimited);
  
  use vars qw(@ERRORS);
***************
*** 33,37 ****
  # wtscript grammar
  my $parser = new Parse::RecDescent (q{
!     file: chunk(s) eofile { [ @{$item[1]} ] }
            | {
                  for my $error (@{$thisparser->{errors}}) {
--- 34,38 ----
  # wtscript grammar
  my $parser = new Parse::RecDescent (q{
!     file: chunk(s) eofile { [ @{$item{chunk}} ] }
            | {
                  for my $error (@{$thisparser->{errors}}) {
***************
*** 53,57 ****
  
      test: starttest testchunk(s) endtest
!         { [ 'test', [ [ 'param', 'test_name', $item[1] ], @{$item[2]} ] ] }
  
      testchunk: comment
--- 54,65 ----
  
      test: starttest testchunk(s) endtest
!         {
!           [ 'test',
!             [
!               [ 'param', 'test_name', $item{starttest} ],
!               @{$item{testchunk}}
!             ]
!           ]
!         }
  
      testchunk: comment
***************
*** 59,87 ****
               | <error: Test parameter or end of test block is expected near @{[$text =~ /(.*)/]}>
  
!     starttest: 'test_name' '=' scalar { $item[3] }
  
      endtest: 'end_test'
  
!     param: name '=' value { [ 'param', $item[1], $item[3] ] }
  
      name : /[a-zA-Z_]+/ { $item[1] eq 'test_name' ? undef : $item[1] }
  
!     value: '(' list ')' { $item[2] }
!          | scalar       { $item[1] }
  
!     list: listelem(s) { [ map ref($_) eq 'ARRAY' ? @$_ : $_, @{$item[1]} ] }
  
      listelem: scalar '=>' scalar { [$item[1], $item[3]] }
              | scalar
  
!     scalar: qscalar
            | uscalar
  
!     qscalar: /'([^\']*)'/ { $1 }
!            | /"([^\"]*)"/ { $1 }
  
      uscalar: <rulevar: $word_re = qr/ (?: [^=)\s] | [^)\s] (?!>) ) /x>
  
      uscalar: / (?: $word_re+ [ \t]+ )* $word_re+ /xo
  
      eofile: /^\Z/
--- 67,124 ----
               | <error: Test parameter or end of test block is expected near @{[$text =~ /(.*)/]}>
  
!     starttest: 'test_name' '=' scalar { $item{scalar} }
  
      endtest: 'end_test'
  
!     param: name '=' value { [ 'param', $item{name}, $item{value} ] }
  
      name : /[a-zA-Z_]+/ { $item[1] eq 'test_name' ? undef : $item[1] }
  
!     value: '(' <commit> list ')'  { $item{list} }
!          | <error?: Missing right bracket>
!          | scalar                 { $item{scalar} }
  
!     list: listelem(s) { [ map ref($_) eq 'ARRAY' ?
!                               @$_ :
!                               $_, @{$item{listelem}} ] }
  
      listelem: scalar '=>' scalar { [$item[1], $item[3]] }
              | scalar
  
!     scalar: <rulevar: $delim >
! 
!     scalar: /(?=')/ <commit> qscalar { $item{qscalar} }
!           | <error?: Can't find string terminator "'" anywhere before EOF>
!           | /(?=")/ <commit> qscalar { $item{qscalar} }
!           | <error?: Can't find string terminator """ anywhere before EOF>
!           | /(?=\{)/ <commit> eval
!           | <error?: Missing right curly>
            | uscalar
  
!     qscalar: <rulevar: $extracted >
! 
!     qscalar: { $extracted = extract_delimited($text) }
!              { substr $extracted, 1, length($extracted) - 2 }
  
      uscalar: <rulevar: $word_re = qr/ (?: [^=)\s] | [^)\s] (?!>) ) /x>
  
      uscalar: / (?: $word_re+ [ \t]+ )* $word_re+ /xo
+ 
+     eval: <rulevar: $extracted >
+ 
+     eval: <rulevar: $exception >
+ 
+     eval: {
+             $extracted = extract_codeblock($text);
+             defined $extracted ? 1 : undef;
+           }
+           <commit>
+           {
+             my $sub = eval "package HTTP::WebTest::PlayGround;\n" .
+                            "sub { $extracted }\n";
+             $exception = $@;
+             $sub;
+           }
+         | <error?: Eval error\n$exception\nnear @{[$text =~ /(.*)/]}>
  
      eofile: /^\Z/