[Http-webtest-commits] CVS: HTTP-WebTest/lib/HTTP/WebTest ReportPlugin.pm,1.1.1.1,1.2 Plugin.pm,1.2,1.3 API.pm,1.3,1.4

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

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

Modified Files:
	ReportPlugin.pm Plugin.pm API.pm 
Log Message:
Test parameters validation API have been changed. All plugins have
been fixed to conform new API. This change is required for proper
support of embeded Perl in wtscript files.


Index: ReportPlugin.pm
===================================================================
RCS file: /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest/ReportPlugin.pm,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -C2 -d -r1.1.1.1 -r1.2
*** ReportPlugin.pm	2002/01/24 12:26:28	1.1.1.1
--- ReportPlugin.pm	2002/02/02 04:08:19	1.2
***************
*** 113,122 ****
  # declare some supported test params
  sub param_types {
!     return { qw(output_ref     stringref
!                 fh_out         anything
!                 mail_addresses list
!                 mail           string
!                 mail_server    string
!                 mail_from      string) };
  }
  
--- 113,123 ----
  # declare some supported test params
  sub param_types {
!     return q(output_ref     stringref
!              fh_out         anything
!              mail_addresses list('scalar','...')
!              mail           scalar
!              mail_server    scalar
!              mail_from      scalar
!              test_name      scalar);
  }
  
***************
*** 148,151 ****
--- 149,154 ----
      my $self = shift;
  
+     $self->global_validate_params(qw(output_ref fh_out));
+ 
      my $output_ref = $self->global_test_param('output_ref');
      my $fh_out     = $self->global_test_param('fh_out');
***************
*** 213,216 ****
--- 216,222 ----
  sub end_tests {
      my $self = shift;
+ 
+     $self->global_validate_params(qw(mail_addresses mail
+                                      mail_server mail_from));
  
      my $mail_addresses = $self->global_test_param('mail_addresses');

Index: Plugin.pm
===================================================================
RCS file: /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest/Plugin.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Plugin.pm	2002/01/28 06:32:02	1.2
--- Plugin.pm	2002/02/02 04:08:19	1.3
***************
*** 77,82 ****
      my $value = $self->webtest->global_test_param($param);
  
!     return $default unless defined $value;
!     return $value;
  }
  
--- 77,83 ----
      my $value = $self->webtest->global_test_param($param);
  
!     my $ret = defined $value ? $value : $default;
! 
!     return $self->canonic_value($ret);
  }
  
***************
*** 107,112 ****
      }
  
!     return $default unless defined $value;
!     return $value;
  }
  
--- 108,114 ----
      }
  
!     my $ret = defined $value ? $value : $default;
! 
!     return $self->canonic_value($ret);
  }
  
***************
*** 157,161 ****
  }
  
! =head2 merge_params ($param, $value, $global_value)
  
  Merges test parameter value with global test parameter value.
--- 159,163 ----
  }
  
! =head2 merge_params ($value, $global_value)
  
  Merges test parameter value with global test parameter value.
***************
*** 175,178 ****
--- 177,201 ----
  }
  
+ =head2 canonic_value ($value)
+ 
+ =head3 Returns
+ 
+ If C<$value> is a reference on subroutine then calls this subroutine
+ and returns value returned by subroutine. Otherwise just returns
+ C<$value>.
+ 
+ =cut
+ 
+ sub canonic_value {
+     my $self = shift;
+     my $value = shift;
+ 
+     if(ref($value) eq 'CODE') {
+ 	$value = $value->();
+     }
+ 
+     return $value;
+ }
+ 
  =head2 test_result ($ok, $comment)
  
***************
*** 197,230 ****
  }
  
! =head2 validate_params ($params)
  
! Checks test parameters.
  
! =head3 Returns
  
! A hash. The keys are the test parameters and the values are
! L<HTTP::WebTest::TestResult|HTTP::WebTest::TestResult> objects.
  
  =cut
  
  sub validate_params {
      my $self = shift;
!     my $params = shift;
  
!     my %param_types = %{$self->param_types};
  
!     my %checks = ();
!     while(my($param, $type) = each %param_types) {
! 	my $method = 'check_' . $type;
! 	my $value = $params->{$param};
! 	next unless defined $value;
! 	my $ok = $self->$method($value);
! 	my $message = "Parameter $param should be of $type type.";
! 	$checks{$param} = $self->test_result($ok, $message);
      }
  
!     return %checks;
  }
  
  =head2 param_types ()
  
--- 220,311 ----
  }
  
! # helper method used by validate_params and by global_validate_params
! # to validate values of test parameters
! sub _validate_params {
!     my $self = shift;
!     my %params = @_;
  
!     my %param_types = grep $_ =~ /\S/, split /\s+/, $self->param_types;
  
!     while(my($param, $value) = each %params) {
! 	next unless defined $value;
  
! 	my $type = $param_types{$param};
! 	die "HTTP::WebTest: unknown test parameter '$param'"
! 	    unless defined $type;
! 
! 	$self->validate_value($param, $value, $type);
!     }
! }
! 
! =head2 validate_params (@params)
  
+ Checks test parameters listed in C<@params>. Throws exception if any
+ of them are invalid.
+ 
  =cut
  
  sub validate_params {
      my $self = shift;
!     my @params = @_;
  
!     my %params = ();
!     for my $param (@params) {
! 	$params{$param} = $self->test_param($param);
!     }
  
!     $self->_validate_params(%params);
! }
! 
! =head2 global_validate_params (@params)
! 
! Checks global test parameters listed in C<@params>. Throws exception
! if any of them are invalid.
! 
! =cut
! 
! sub global_validate_params {
!     my $self = shift;
!     my @params = @_;
! 
!     my %params = ();
!     for my $param (@params) {
! 	$params{$param} = $self->global_test_param($param);
      }
  
!     $self->_validate_params(%params);
  }
  
+ =head2 validate_value($param, $value, $type)
+ 
+ Checks if C<$value> of test parameter C<$param> has type <$type>.
+ 
+ =head3 Exceptions
+ 
+ Dies if check is not successful.
+ 
+ =cut
+ 
+ sub validate_value {
+     my $self = shift;
+     my $param = shift;
+     my $value = shift;
+     my $type = shift;
+ 
+     # parse param type specification
+     my($method, $args) = $type =~ /^ (\w+) (?: \( (.*?) \) )? $/x;
+     die "HTTP::WebTest: bad type specification '$type'"
+ 	unless defined $method;
+     $method = 'check_' . $method;
+ 
+     # get additional arguments for type validation sub
+     $args = '' unless defined $args;
+     my @args = eval " ( $args ) ";
+     die "HTTP::WebTest: can't eval args '$args': $@"
+ 	if $@;
+ 
+     $self->$method($param, $self->canonic_value($value), @args);
+ }
+ 
  =head2 param_types ()
  
***************
*** 235,244 ****
  =head3 Returns
  
! An hash reference. Keys are names of test parameters which are
! supported by plugin. Values are their type.
  
  =cut
  
! sub param_types { {} }
  
  =head2 check_anything ($value)
--- 316,329 ----
  =head3 Returns
  
! A string which looks like:
! 
!     'param1 type1
!      param2 type2
!      param3 type3(optional,args)
!      param4 type4'
  
  =cut
  
! sub param_types { '' }
  
  =head2 check_anything ($value)
***************
*** 247,253 ****
  type.
  
! =head3 Returns
! 
! Always true.
  
  =cut
--- 332,336 ----
  type.
  
! This is NOOP operation.
  
  =cut
***************
*** 255,302 ****
  sub check_anything { 1 }
  
! =head2 check_list ($value)
  
  Method which checks test parameter if it is value is of C<list>
! type.
  
! =head3 Returns
  
! True if C<$value> is an array reference. False otherwise.
  
  =cut
  
  sub check_list {
      my $self = shift;
      my $value = shift;
  
!     return ref($value) eq 'ARRAY';
  }
  
! =head2 check_string ($value)
  
! Method which checks test parameter if it is value is of C<string>
! type.
  
! =head3 Returns
  
! True if C<$value> is a string. False otherwise.
  
  =cut
  
! sub check_string {
      my $self = shift;
      my $value = shift;
  
!     return not ref($value);
  }
  
! =head2 check_stringref ($value)
  
  Method which checks test parameter if it is value is of C<stringref>
! type.
  
! =head3 Returns
  
! True if C<$value> is a string reference. False otherwise.
  
  =cut
--- 338,446 ----
  sub check_anything { 1 }
  
! =head2 check_list ($param, $value, @optional_spec)
  
  Method which checks test parameter if it is value is of C<list>
! type. That is it is a reference on an array.
  
! Optional list C<@optional_spec> can define specification on allowed
! elements of list. It can be either
  
!     ('TYPE_1', 'TYPE_2', ..., 'TYPE_N')
  
+ or
+ 
+     ('TYPE_1', 'TYPE_2', ..., 'TYPE_M', '...')
+ 
+ First specification requires list value of test parameter to contain
+ C<N> elements. First element of list should be of should C<TYPE_1>
+ type, second element of list should of C<TYPE_2> type, ..., N-th
+ element of list should be of C<TYPE_N> type.
+ 
+ Second specification requires list value of test parameter to contain
+ at least C<N> elements.  First element of list should be of should
+ C<TYPE_1> type, second element of list should of C<TYPE_2> type, ...,
+ M-th element of list should be of C<TYPE_M> type, all following
+ elements should be of C<TYPE_M> type.
+ 
+ =head3 Exceptions
+ 
+ Dies if checks is not successful.
+ 
  =cut
  
  sub check_list {
      my $self = shift;
+     my $param = shift;
      my $value = shift;
+     my @spec = @_;
  
!     die "HTTP::WebTest: parameter '$param' is not a list"
! 	unless ref($value) eq 'ARRAY';
! 
!     return unless @spec;
! 
!     my @list = @$value;
!     my $prev_type = undef;
!     for my $i (0 .. @list - 1) {
! 	my $type = shift @spec;
! 
! 	die "HTTP::WebTest: too many elements in list parameter '$param'"
! 	    unless defined $type;
! 
! 	if($type eq '...') {
! 	    $type = $prev_type;
! 	    push @spec, '...';
! 	}
! 
! 	my $elem = $list[$i];
! 
! 	$self->validate_value("$param\[$i\]", $elem, $type);
! 
! 	$prev_type = $type;
!     }
! 
!     shift @spec if defined $spec[1] and $spec[1] eq '...';
! 
!     die "HTTP::WebTest: too few elements in list parameter '$param'"
! 	if @spec;
  }
  
! =head2 check_scalar ($param, $value, $optional_regexp)
  
! Method which checks test parameter if it is value is of C<scalar>
! type. That is it is usual Perl scalar and is not a reference.
  
! If C<$optional_regexp> is specified also checks value of parameter
! using this regual expression.
  
! =head3 Exceptions
! 
! Dies if check is not successful.
  
  =cut
  
! sub check_scalar {
      my $self = shift;
+     my $param = shift;
      my $value = shift;
+     my $optional_regexp = shift;
  
!     die "HTTP::WebTest: parameter '$param' is not a scalar"
! 	unless not ref($value);
! 
!     return unless defined $optional_regexp;
! 
!     die "HTTP::WebTest: parameter '$param' doesn't match regexp '$optional_regexp'"
! 	unless $value =~ /$optional_regexp/i;
  }
  
! =head2 check_stringref ($param, $value)
  
  Method which checks test parameter if it is value is of C<stringref>
! type. That is it is a reference on scalar.
  
! =head3 Exceptions
  
! Dies if check is not successful.
  
  =cut
***************
*** 304,320 ****
  sub check_stringref {
      my $self = shift;
      my $value = shift;
  
!     return ref($value) eq 'SCALAR';
  }
  
! =head2 check_uri ($value)
  
  Method which checks test parameter if it is value is of C<uri>
! type.
  
! =head3 Returns
  
! True if C<$value> is an URI. False otherwise.
  
  =cut
--- 448,466 ----
  sub check_stringref {
      my $self = shift;
+     my $param = shift;
      my $value = shift;
  
!     die "HTTP::WebTest: parameter '$param' is not a scalar reference"
! 	unless ref($value) eq 'SCALAR';
  }
  
! =head2 check_uri ($param, $value)
  
  Method which checks test parameter if it is value is of C<uri>
! type. That is it either scalar or L<URI|URI> object.
  
! =head3 Exceptions
  
! Dies if check is not successful.
  
  =cut
***************
*** 322,342 ****
  sub check_uri {
      my $self = shift;
      my $value = shift;
  
!     my $check = $self->check_string($value);
!     $check ||= (defined ref($value) and UNIVERSAL::isa($value, 'URI'));
  
!     return $check;
  }
  
! =head2 check_hashlist ($value)
  
  Method which checks test parameter if it is value is of C<hashlist>
! type.
  
! =head3 Returns
  
! True if C<$value> is a hash reference or an array reference which
! points to array containing even number of elements. False otherwise.
  
  =cut
--- 468,494 ----
  sub check_uri {
      my $self = shift;
+     my $param = shift;
      my $value = shift;
  
!     my $ok = 1;
!     eval { $self->check_scalar($param, $value) };
!     if($@) {
! 	$ok = 0
! 	    unless defined ref($value) and UNIVERSAL::isa($value, 'URI');
!     }
  
!     die "HTTP::WebTest: parameter '$param' is not a URI"
! 	unless $ok;
  }
  
! =head2 check_hashlist ($param, $value)
  
  Method which checks test parameter if it is value is of C<hashlist>
! type. That is it is either a hash reference or an array reference
! which points to array containing even number of elements.
  
! =head3 Exceptions
  
! Dies if check is not successful.
  
  =cut
***************
*** 344,350 ****
  sub check_hashlist {
      my $self = shift;
      my $value = shift;
  
!     my $check = $self->check_list($value);
      $check &&= ((@$value % 2) == 0);
      $check ||= ref($value) eq 'HASH';
--- 496,516 ----
  sub check_hashlist {
      my $self = shift;
+     my $param = shift;
      my $value = shift;
  
!     my $ok = 1;
!     eval { $self->check_list($param, $value) };
!     if($@) {
! 	$ok = 0
! 	    unless ref($value) eq 'HASH';
!     } else {
! 	$ok = 0
! 	    unless (@$value % 2) == 0;
!     }
! 
!     die "HTTP::WebTest: parameter '$param' is neither a hash nor a list with even number of elements"
! 	unless $ok;
! 
!     my $check = $self->check_list($param, $value);
      $check &&= ((@$value % 2) == 0);
      $check ||= ref($value) eq 'HASH';
***************
*** 352,364 ****
      return $check;
  }
- 
- =head2 check_yesno ($value)
  
! Method which checks test parameter if it is value is of C<yesno>
! type.
  
! =head3 Returns
  
! True if C<$value> is either C<yes> or C<no>. False otherwise.
  
  =cut
--- 518,527 ----
      return $check;
  }
  
! =head2 check_yesno ($param, $value)
  
! Same as
  
!     check_scalar($param, $value, '^(?:yes|no)$');
  
  =cut
***************
*** 366,372 ****
  sub check_yesno {
      my $self = shift;
      my $value = shift;
  
!     return $value =~ /^(?:yes|no)$/i;
  }
  
--- 529,536 ----
  sub check_yesno {
      my $self = shift;
+     my $param = shift;
      my $value = shift;
  
!     check_scalar($param, $value, '^(?:yes|no)$');
  }
  

Index: API.pm
===================================================================
RCS file: /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest/API.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** API.pm	2002/01/28 07:11:05	1.3
--- API.pm	2002/02/02 04:08:19	1.4
***************
*** 103,119 ****
      $self->_global_test_params($params);
  
-     # validate global test parameters
-     my %checks = $self->validate_params($params);
-     # be sure that checks are sorted by param name
-     my @broken = grep { not $_->ok } map $checks{$_}, sort keys %checks;
- 
-     # is is hard to report errors nicely (i.e. via report plugins)
-     # here because plugins are not initialized yet. Just die right now
-     # if there are any bad global test parameters
-     if(@broken) {
- 	my $die = join "\n", 'HTTP::WebTest:', map $_->comment, @broken;
- 	die $die;
-     }
- 
      # start tests hook
      for my $plugin (@{$self->plugins}) {
--- 103,106 ----
***************
*** 515,567 ****
      $self->_global_test_params($params);
  
!     # validate test params
!     my %checks = ($self->validate_params($test->params),
! 		  $self->validate_params($params));
!     # be sure that checks are sorted by param name
!     my @broken = grep { not $_->ok } map $checks{$_}, sort keys %checks;
! 
!     if(@broken) {
! 	$self->last_test->reset;
! 	$self->last_results([ [ 'Test parameters error', @broken ] ]);
!     } else {
! 
! 	# create request (note that actual url is more likely to be
! 	# set in plugins)
! 	my $request = HTTP::Request->new('GET' => 'http://localhost/');
! 	$self->last_request($request);
  
! 	# set request object with plugins
! 	for my $plugin (@{$self->plugins}) {
! 	    if($plugin->can('prepare_request')) {
! 		$plugin->prepare_request;
! 	    }
  	}
  
! 	# measure current time
! 	my $time1 = time;
  
! 	# get response
! 	my $response = $self->user_agent->request($request);
! 	$self->last_response($response);
  
! 	# measure current time
! 	my $time2 = time;
  
! 	# calculate response time
! 	$self->last_response_time($time2 - $time1);
  
! 	# init results
! 	my @results = ();
  
! 	# check response with plugins
! 	for my $plugin (@{$self->plugins}) {
! 	    if($plugin->can('check_response')) {
! 		push @results, $plugin->check_response;
! 	    }
  	}
- 
- 	$self->last_results(\@results);
      }
  
      # report test results
      for my $plugin (@{$self->plugins}) {
--- 502,542 ----
      $self->_global_test_params($params);
  
!     # create request (note that actual url is more likely to be
!     # set in plugins)
!     my $request = HTTP::Request->new('GET' => 'http://localhost/');
!     $self->last_request($request);
  
!     # set request object with plugins
!     for my $plugin (@{$self->plugins}) {
! 	if($plugin->can('prepare_request')) {
! 	    $plugin->prepare_request;
  	}
+     }
  
!     # measure current time
!     my $time1 = time;
  
!     # get response
!     my $response = $self->user_agent->request($request);
!     $self->last_response($response);
  
!     # measure current time
!     my $time2 = time;
  
!     # calculate response time
!     $self->last_response_time($time2 - $time1);
  
!     # init results
!     my @results = ();
  
!     # check response with plugins
!     for my $plugin (@{$self->plugins}) {
! 	if($plugin->can('check_response')) {
! 	    push @results, $plugin->check_response;
  	}
      }
  
+     $self->last_results(\@results);
+ 
      # report test results
      for my $plugin (@{$self->plugins}) {
***************
*** 593,625 ****
  
      return wantarray ? @conv : $conv[0];
- }
- 
- =head2 validate_params ($params)
- 
- Validates test parameters.
- 
- =head3 Returns
- 
- A hash with results of checks. The keys are the test parameters and
- the values are L<HTTP::WebTest::TestResult|HTTP::WebTest::TestResult>
- objects.
- 
- =cut
- 
- sub validate_params {
-     my $self = shift;
-     my $params = shift;
- 
-     my %checks = ();
- 
-      # check params with all plugins
-      for my $plugin (@{$self->plugins}) {
-  	if(my $validate_params = $plugin->can('validate_params')) {
-  	    %checks = (%checks,
-  		       $plugin->$validate_params($params));
-  	}
-      }
- 
-     return %checks;
  }
  
--- 568,571 ----