lib/Config/Any/WTScript.pm

   1 package Config::Any::WTScript;
   2
   3 # ABSTRACT: Parse wtscript files.
   4
   5 =head1 SYNOPSIS
   6
   7     use Config::Any::WTScript;
   8
   9     my $tests = Config::Any::WTScript->parse($data);
  10
  11 =head1 DESCRIPTION
  12
  13 Parses a wtscript file and converts it to a set of test objects.
  14
  15 =cut
  16
  17 use strict;
  18 use warnings;
  19
  20 use vars qw($VERSION @extensions);
  21
  22 use base 'Config::Any::Base';
  23
  24 use Text::Balanced qw(extract_codeblock extract_delimited);
  25 use File::Slurp qw(read_file);
  26
  27 use constant ST_FILE       => 0;
  28 use constant ST_TEST_BLOCK => 1;
  29
  30 $VERSION = '0.001_003';
  31
  32 # horizontal space regexp
  33 my $reHS = qr/[\t ]/;
  34 # sequence of any chars which doesn't contain ')', space chars and '=>'
  35 my $reWORD = qr/(?: (?: [^=)\s] | [^)\s] (?!>) )+ )/x;
  36 # eat comments regexp
  37 my $reCOMMENT = qr/(?: \s*? ^ \s* \# .* )+/mx;
  38
  39 =method extensions(;@extensions)
  40
  41 When list of extensions to accept given, replace current list with given list.
  42
  43 Return an array of valid extensions (default: C<wts>, C<wtscript>).
  44
  45 =cut
  46
  47 @extensions = qw(wts wtscript);
  48
  49 sub extensions
  50 {
  51     my ( $class, @new_ext ) = @_;
  52     @new_ext and @extensions = @new_ext;
  53     return @extensions;
  54 }
  55
  56 =method load( $file )
  57
  58 Parses wtscript text data passed in a scalar variable C<$data>.
  59
  60 =head3 Returns
  61
  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.
  64
  65 =cut
  66
  67 sub load
  68 {
  69     my $class    = shift;
  70     my $filename = shift;
  71
  72     my $data = read_file($filename);
  73
  74     my ( $tests, $opts ) = eval { _parse($data) };
  75
  76     if ($@)
  77     {
  78         my $exc = $@;
  79         chomp $exc;
  80
  81         my $parse_pos = pos($data) || 0;
  82
  83         # find reminder of string near error (without surrounding
  84         # whitespace)
  85         $data =~ /\G $reHS* (.*?) $reHS* $/gmx;
  86         my $near = $1;
  87         if ( $near eq '' )
  88         {
  89             $near = 'at the end of line';
  90         }
  91         else
  92         {
  93             $near = "near '$near'";
  94         }
  95
  96         # count lines
  97         my $line_num = () = substr( $data, 0, $parse_pos ) =~ m|$|gmx;
  98         pos($data) = $parse_pos;
  99         $line_num-- if $data =~ /\G \z/gx;
 100
 101         die <<MSG;
 102 Config::WebTest: wtscript parsing error
 103 Line $line_num $near: $exc
 104 MSG
 105     }
 106
 107     my @configs;
 108     foreach my $test_item (@$tests)
 109     {
 110         my %test = %$test_item;
 111         my %cfg = (
 112                     request => {
 113                                  agent  => {},
 114                                  method => 'get',
 115                                },
 116                     check => { response => 200, },
 117                   );
 118         my $agent_cfg = $cfg{request}->{agent};
 119         # convert params
 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)];
 127
 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} } };
 132
 133         $cfg{check} = \%test;
 134         $cfg{opts}  = $opts;
 135
 136         push( \@configs, \%cfg );
 137     }
 138
 139     return \@configs;
 140 }
 141
 142 sub eval_in_playground
 143 {
 144     my $code = shift;
 145
 146     return eval <<CODE;
 147 package Config::WebTest::PlayGround;
 148
 149 no strict;
 150 local \$^W; # aka no warnings in new perls
 151
 152 $code
 153 CODE
 154 }
 155
 156 sub make_sub_in_playground
 157 {
 158     my $code = shift;
 159
 160     return eval_in_playground("sub { local \$^W; $code }");
 161 }
 162
 163 sub _parse
 164 {
 165     my $data = shift;
 166
 167     my $state = ST_FILE;
 168     my $opts  = {};
 169     my $tests = [];
 170     my $test  = undef;
 171
 172   PARSER:
 173     while (1)
 174     {
 175         # eat whitespace and comments
 176         $data =~ /\G $reCOMMENT /gcx;
 177
 178         # eat whitespace
 179         $data =~ /\G \s+/gcx;
 180
 181         if ( $state == ST_FILE )
 182         {
 183             if ( $data =~ /\G \z/gcx )
 184             {
 185                 # end of file
 186                 last PARSER;
 187             }
 188             elsif ( $data =~ /\G test_name (?=\W)/gcx )
 189             {
 190                 # found new test block start
 191                 $test  = {};
 192                 $state = ST_TEST_BLOCK;
 193
 194                 # find test block name
 195                 if ( $data =~ /\G $reHS* = $reHS* (?: \n $reHS*)?/gcx )
 196                 {
 197                     $test->{test_name} = _parse_scalar($data);
 198
 199                     die "Test name is missing\n"
 200                       unless defined $test->{test_name};
 201                 }
 202             }
 203             else
 204             {
 205                 # expect global test parameter
 206                 my ( $name, $value ) = _parse_param($data);
 207
 208                 if ( defined $name )
 209                 {
 210                     _set_test_param( $opts, $name, $value );
 211                 }
 212                 else
 213                 {
 214                     die "Global test parameter or test block is expected\n";
 215                 }
 216             }
 217         }
 218         elsif ( $state == ST_TEST_BLOCK )
 219         {
 220             if ( $data =~ /\G end_test (?=\W)/gcx )
 221             {
 222                 push @$tests, $test;
 223                 $state = ST_FILE;
 224             }
 225             else
 226             {
 227                 # expect test parameter
 228                 my ( $name, $value ) = _parse_param($data);
 229
 230                 if ( defined $name )
 231                 {
 232                     _set_test_param( $test, $name, $value );
 233                 }
 234                 else
 235                 {
 236                     die "Test parameter or end_test is expected\n";
 237                 }
 238             }
 239         }
 240         else
 241         {
 242             die "Unknown state\n";
 243         }
 244     }
 245
 246     return ( $tests, $opts );
 247 }
 248
 249 sub _set_test_param
 250 {
 251     my $href  = shift;
 252     my $name  = shift;
 253     my $value = shift;
 254
 255     if ( exists $href->{$name} )
 256     {
 257         $href->{$name} = [ $href->{$name} ]
 258           if ref( $href->{$name} )
 259           and ref( $href->{$name} ) eq 'ARRAY';
 260         push @{ $href->{$name} }, $value;
 261     }
 262     else
 263     {
 264         $href->{$name} = $value;
 265     }
 266 }
 267
 268 sub _parse_param
 269 {
 270     my $name;
 271
 272     if (
 273         $_[0] =~ /\G ([a-zA-Z_]+)                 # param name
 274                  $reHS* = $reHS* (?: \n $reHS*)? # = (and optional space chars)
 275                 /gcx
 276        )
 277     {
 278         $name = $1;
 279     }
 280     else
 281     {
 282         return;
 283     }
 284
 285     my $value = _parse_value( $_[0] );
 286     return unless defined $value;
 287
 288     return ( $name, $value );
 289 }
 290
 291 sub _parse_value
 292 {
 293     if ( $_[0] =~ /\G \(/gcx )
 294     {
 295         # list elem
 296         #
 297         # ( scalar
 298         #   ...
 299         #   scalar )
 300         #
 301         # ( scalar => scalar
 302         #   ...
 303         #   scalar => scalar )
 304
 305         my @list = ();
 306
 307         while (1)
 308         {
 309             # eat whitespace and comments
 310             $_[0] =~ /\G $reCOMMENT /gcx;
 311
 312             # eat whitespace
 313             $_[0] =~ /\G \s+/gcx;
 314
 315             # exit loop on closing bracket
 316             last if $_[0] =~ /\G \)/gcx;
 317
 318             my $value = _parse_value( $_[0] );
 319
 320             die "Missing right bracket\n"
 321               unless defined $value;
 322
 323             push @list, $value;
 324
 325             if ( $_[0] =~ /\G $reHS* => $reHS* /gcx )
 326             {
 327                 # handles second part of scalar => scalar syntax
 328                 my $value = _parse_value( $_[0] );
 329
 330                 die "Missing right bracket\n"
 331                   unless defined $value;
 332
 333                 push @list, $value;
 334             }
 335         }
 336
 337         return \@list;
 338     }
 339     else
 340     {
 341         # may return undef
 342         return _parse_scalar( $_[0] );
 343     }
 344 }
 345
 346 sub _parse_scalar
 347 {
 348     my $parse_pos = pos $_[0];
 349
 350     if ( $_[0] =~ /\G (['"])/gcx )
 351     {
 352         my $delim = $1;
 353
 354         pos( $_[0] ) = $parse_pos;
 355         my ($extracted) = extract_delimited( $_[0] );
 356         die "Can't find string terminator \"$delim\"\n"
 357           if $extracted eq '';
 358
 359         if ( $delim eq "'" or $extracted !~ /[\$\@\%]/ )
 360         {
 361             # variable interpolation impossible - just evalute string
 362             # to get rid of escape chars
 363             my $ret = eval_in_playground($extracted);
 364
 365             chomp $@;
 366             die "Eval error\n$@\n" if $@;
 367
 368             return $ret;
 369         }
 370         else
 371         {
 372             # variable interpolation possible - evaluate as subroutine
 373             # which will be used as callback
 374             my $ret = make_sub_in_playground($extracted);
 375
 376             chomp $@;
 377             die "Eval error\n$@\n" if $@;
 378
 379             return $ret;
 380         }
 381     }
 382     elsif ( $_[0] =~ /\G \{/gcx )
 383     {
 384         pos( $_[0] ) = $parse_pos;
 385         my ($extracted) = extract_codeblock( $_[0] );
 386         die "Missing right curly bracket\n"
 387           if $extracted eq '';
 388
 389         my $ret = make_sub_in_playground($extracted);
 390
 391         chomp $@;
 392         die "Eval error\n$@\n" if $@;
 393
 394         return $ret;
 395     }
 396     else
 397     {
 398         $_[0] =~ /\G ((?: $reWORD $reHS+ )* $reWORD )/gcxo;
 399         my $extracted = $1;
 400
 401         # may return undef
 402         return $extracted;
 403     }
 404 }
 405
 406 =head1 ACKNOWLEDGEMENTS
 407
 408 The original parsing code is from L<HTTP::WebTest::Parser>, written by
 409 Ilya Martynov.
 410
 411 =head1 SEE ALSO
 412
 413 L<HTTP::WebTest>
 414
 415 L<HTTP::WebTest::Parser>
 416
 417 =cut
 418
 419 1;