lib/Config/Any/WTScript.pm

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