1 package Config
::Any
::WTScript
;
3 # ABSTRACT: Parse wtscript files.
7 use Config::Any::WTScript;
9 my $tests = Config::Any::WTScript->parse($data);
13 Parses a wtscript file and converts it to a set of test objects.
20 use vars
qw($VERSION @extensions);
22 use base 'Config::Any::Base';
24 use Text::Balanced qw(extract_codeblock extract_delimited);
25 use File
::Slurp
qw(read_file);
27 use constant ST_FILE
=> 0;
28 use constant ST_TEST_BLOCK
=> 1;
32 # horizontal space regexp
34 # sequence of any chars which doesn't contain ')', space chars and '=>'
35 my $reWORD = qr/(?: (?: [^=)\s] | [^)\s] (?!>) )+ )/x;
37 my $reCOMMENT = qr/(?: \s*? ^ \s* \# .* )+/mx;
39 =method extensions
(;@extensions)
41 When list of extensions to
accept given, replace current list with
given list
.
43 Return an array of valid extensions
(default: C
<wts
>, C
<wtscript
>).
47 @extensions = qw(wts wtscript);
51 my ( $class, @new_ext ) = @_;
52 @new_ext and @extensions = @new_ext;
58 Parses wtscript text data passed
in a
scalar variable C
<$data>.
62 A list of two elements - a reference to an array that contains test
63 objects and a reference to a hash that contains test parameters.
72 my $data = read_file
($filename);
74 my ( $tests, $opts ) = eval { _parse
($data) };
81 my $parse_pos = pos($data) || 0;
83 # find reminder of string near error (without surrounding
85 $data =~ /\G $reHS* (.*?) $reHS* $/gmx;
89 $near = 'at the end of line';
93 $near = "near '$near'";
97 my $line_num = () = substr( $data, 0, $parse_pos ) =~ m
|$|gmx
;
98 pos($data) = $parse_pos;
99 $line_num-- if $data =~ /\G \z/gx;
102 Config::WebTest: wtscript parsing error
103 Line $line_num $near: $exc
108 foreach my $test_item (@
$tests)
110 my %test = %$test_item;
116 check
=> { response
=> 200, },
118 my $agent_cfg = $cfg{request
}->{agent
};
120 defined( $test{user_agent
} ) and $agent_cfg->{agent
} = delete $test{user_agent
};
121 defined( $test{handle_redirects
} )
122 and $agent_cfg->{requests_redirectable
} = delete $test{handle_redirects
};
123 defined( $test{proxies
} ) and $agent_cfg->{proxy
} = { @
{ delete $test{proxies
} } };
124 defined( $agent_cfg->{requests_redirectable
} )
125 and looks_like_number
( $agent_cfg->{requests_redirectable
} )
126 and $agent_cfg->{requests_redirectable
} = [qw(GET POST)];
128 $cfg{request
}->{uri
} = delete $test{url
};
129 defined $test{method
} and $cfg{request
}->{method
} = lc delete $test{method
};
130 defined $test{http_headers
}
131 and $cfg{request
}->{http_headers
} = { @
{ delete $test{http_headers
} } };
133 $cfg{check
} = \
%test;
136 push( \
@configs, \
%cfg );
142 sub _eval_in_playground
147 package Config::WebTest::PlayGround;
150 local \$^W; # aka no warnings in new perls
156 sub _make_sub_in_playground
160 return _eval_in_playground
("sub { local \$^W; $code }");
175 # eat whitespace and comments
176 $data =~ /\G $reCOMMENT /gcx;
179 $data =~ /\G \s+/gcx;
181 if ( $state == ST_FILE
)
183 if ( $data =~ /\G \z/gcx )
188 elsif ( $data =~ /\G test_name (?=\W)/gcx )
190 # found new test block start
192 $state = ST_TEST_BLOCK
;
194 # find test block name
195 if ( $data =~ /\G $reHS* = $reHS* (?: \n $reHS*)?/gcx )
197 $test->{test_name
} = _parse_scalar
($data);
199 die "Test name is missing\n"
200 unless defined $test->{test_name
};
205 # expect global test parameter
206 my ( $name, $value ) = _parse_param
($data);
210 _set_test_param
( $opts, $name, $value );
214 die "Global test parameter or test block is expected\n";
218 elsif ( $state == ST_TEST_BLOCK
)
220 if ( $data =~ /\G end_test (?=\W)/gcx )
227 # expect test parameter
228 my ( $name, $value ) = _parse_param
($data);
232 _set_test_param
( $test, $name, $value );
236 die "Test parameter or end_test is expected\n";
242 die "Unknown state\n";
246 return ( $tests, $opts );
255 if ( exists $href->{$name} )
257 $href->{$name} = [ $href->{$name} ]
258 if ref( $href->{$name} )
259 and ref( $href->{$name} ) eq 'ARRAY';
260 push @
{ $href->{$name} }, $value;
264 $href->{$name} = $value;
273 $_[0] =~ /\G
([a
-zA
-Z_
]+) # param name
274 $reHS* = $reHS* (?
: \n $reHS*)?
# = (and optional space chars)
285 my $value = _parse_value
( $_[0] );
286 return unless defined $value;
288 return ( $name, $value );
293 if ( $_[0] =~ /\G \(/gcx )
309 # eat whitespace and comments
310 $_[0] =~ /\G $reCOMMENT /gcx;
313 $_[0] =~ /\G \s+/gcx;
315 # exit loop on closing bracket
316 last if $_[0] =~ /\G \)/gcx;
318 my $value = _parse_value
( $_[0] );
320 die "Missing right bracket\n"
321 unless defined $value;
325 if ( $_[0] =~ /\G $reHS* => $reHS* /gcx )
327 # handles second part of scalar => scalar syntax
328 my $value = _parse_value
( $_[0] );
330 die "Missing right bracket\n"
331 unless defined $value;
342 return _parse_scalar
( $_[0] );
348 my $parse_pos = pos $_[0];
350 if ( $_[0] =~ /\G (['"])/gcx )
354 pos( $_[0] ) = $parse_pos;
355 my ($extracted) = extract_delimited
( $_[0] );
356 die "Can't find string terminator \"$delim\"\n"
359 if ( $delim eq "'" or $extracted !~ /[\$\@\%]/ )
361 # variable interpolation impossible - just evalute string
362 # to get rid of escape chars
363 my $ret = _eval_in_playground
($extracted);
366 die "Eval error\n$@\n" if $@
;
372 # variable interpolation possible - evaluate as subroutine
373 # which will be used as callback
374 my $ret = _make_sub_in_playground
($extracted);
377 die "Eval error\n$@\n" if $@
;
382 elsif ( $_[0] =~ /\G \{/gcx )
384 pos( $_[0] ) = $parse_pos;
385 my ($extracted) = extract_codeblock
( $_[0] );
386 die "Missing right curly bracket\n"
389 my $ret = _make_sub_in_playground
($extracted);
392 die "Eval error\n$@\n" if $@
;
398 $_[0] =~ /\G ((?: $reWORD $reHS+ )* $reWORD )/gcxo;
406 =head1 ACKNOWLEDGEMENTS
408 The original parsing code is from L<HTTP::WebTest::Parser>, written by
415 L<HTTP::WebTest::Parser>