#!/usr/local/bin/perl
#  File: HTTPtestS.pl
#
#  Author: G. Wade Johnson
#
#  Copyright 2001 by Telescan, Inc.
#  Released under the same license as Perl.
#  
#  Warning: This program is under construction.
#  It may be changed at any time.

use FindBin;
use LWP::UserAgent;
use XML::Parser;
use URI::Escape;
use Getopt::Std;
use File::Spec;

$VERSION = 0.68;

my $CompileMsg = '';
BEGIN
 {
  $^W = 1;

  if($^O eq 'MSWin32')
   {
    # Windows does not expand wildcards on the command line
    # So we expand wildcards if we find them.
    # However, in 5.6, glob fails to expand wildcards that include a
    # UNC, such as \\server\share\dir\*.*
    my @files;
    @ARGV = map { /[\*\?]/ && (@files = glob $_) ? @files : $_ } @ARGV
                                                                if $] > 5.00307;
   }

  #-----------------------------------------------------------------
  # Attempt to 'use' the Time::HiRes module. If it is not available,
  # we continue. The module is not necessary, it just gives better
  # resolution if we have it.
  eval { require Time::HiRes; Time::HiRes->import( 'time' ); };
  $CompileMsg .= "HiRes Timing not available.\n" if $@;
 }

use strict;
use vars qw/%opts %Options $VERSION/;

getopts( 'vwqVlo:I:f:', \%opts ) || usage();

if($opts{V})
 {
  print "$0: Version $VERSION\n";
  exit( 0 );
 }

my $ResponseTime  = 0;
my $DefaultLibDir = "$FindBin::Bin/lib";
my %Params        = ();
my %CodeLibIDs    = ();
my %CmdLine       = ();
my $ScriptStart   = time;

extract_cmd_line();
expand_list_file();

usage() unless @ARGV;

print STDERR $CompileMsg if $CompileMsg and 'verbose' eq $Options{msgs};

my $parser = new XML::Parser( Style=>'Objects', Pkg=>'tst' );
XMLdata::set_package( 'tst' );

my $ua = new LWP::UserAgent;
die "Unable to create user agent.\n" unless $ua;

#-----------------------------------------------
# Define handling of top-level elements
my %TSElement =
 (
  param   => sub { },  # already handled
  test    => sub { run_test( $ua, @_ ); },
  session => \&execute_a_session,
  codelib => \&compile_lib,
  include => sub { },  # already handled
  option  => sub { die "An option element found out of place.\n"; }
 );
XMLdata::DeclareElements( qw/testset param test session codelib
                             include inclusion option/ );

#-----------------------------------------------
# Define handling of test criteria elements
my %Tests =
 (  # general
  'not'	  => \&validate_not,
  'or'	  => \&validate_or,
  'and'	  => \&validate_and,
    # protocol-specific
  status  => \&validate_status,
  header  => \&validate_header,
  content => \&validate_content,
  'time'  => \&validate_time,
  code    => \&validate_code,
  msg     => \&send_msg,
 );
XMLdata::DeclareElements( qw/request response body not or and status header
                             content time code msg/ );

my ($tots, $tot, $sets) = (0, 0, 0, 0);

#-----------------------------------------------
# Main file processing loop.
#  invariant: @ARGV contains testset filenames to process.
while(@ARGV)
 {
  my $testfile = shift;
  my $doc = $parser->parsefile( $testfile ) or die "Unable to read tests file \'$testfile\'.\n";
  my $testset = XMLdata::root( $doc ) or die "Unable to read tests file \'$testfile\'.\n";

  # Extract options
  extract_options( $testset );
  add_command_line_overrides();
  open_logfile();

  # Expand includes at this point.
  expand_includes( $testset );
  my $err = invalid_testset( $testset );
  die "Testset \"$testfile\" has errors: $err\n" if $err;

  %Params = ();

  my $succ  = 0;
  my $tests = count_tests( $testset );

  printlog( '# ', $testset->{label}, "\n" );
  printlogv( "1..$tests\n" );

  setup_params( $testset );

  eval
   {
    $succ += process_testset( $testset->get_children() );
   };

  if($@)
   {
    die $@ if $@ ne "msg-stop\n";
    print "\n";
   }
  else
   {
    if($succ != $tests)
     {
      printlog( "Failed ", ($tests-$succ), "/$tests\n" );
     }
   }

  $tots += $succ;
  $tot  += $tests;
  ++$sets;
  close_logfile();
 }

my $ScriptTime = time - $ScriptStart;

if($tots == $tot)
 {
  if(1 < $sets)
   {
    printlog( "All tests successful.\nFiles=$sets, Tests=$tot.\n" );
   }
  else
   {
    printlog( "All tests successful.\nTests=$tot.\n" );
   }
 }
else
 {
  printlog( "FAILED tests\n\tFailed ", ($tot-$tots), "/$tot\n" );
 }
printlog( sprintf "# Elapsed time: %.2f seconds\n", $ScriptTime );


#--------------------------------------------------------
#  Count the test elements in the supplied testset
#
#  Input:  $testset  - the testset object to count
#
#  Output: number of test elements found in testset
sub   count_tests
 {
  my $testset = shift;

  return scalar( @{$testset->get_descendents_by_tag( 'test' )} );
 }

#--------------------------------------------------------
#  Process several tests
#
#  Input:   A list of top-level elements to process.
#
#  Output: the number of successful tests
sub  process_testset
 {
  my ($Succ, $numTest) = process_set_of_tests( 0, @_ );

  $Succ;
 }


#--------------------------------------------------------
#  Process several tests
#
#  Input:   $numTest  - current test number
#           A list of top-level elements to process.
#
#  Output: a list containing the number of successful tests
#          and the current test number.
sub    process_set_of_tests
 {
  my $Succ    = 0;
  my $numTest = shift;
  
  # invariant: @_ contains the remaining top-level test elements
  foreach my $el (@_)
   {
    next unless $el->is_element();

    my $tag = $el->tagname();

    if(exists $TSElement{$tag})
     {
      $TSElement{$tag}->( $el, $numTest, $Succ );
     }
    else
     {
      die "Unrecognized element '$tag'.\n";
     }
   }

  ($Succ, $numTest)
 }
  
  
#--------------------------------------------------------
# Initialize Options variables
sub   initialize_options
 {
  %Options = ( incpath => [],
               logging => 0,
               logfile => 'HTTPtest.log',
               msgs    => '',
             );
 }

#--------------------------------------------------------
#  Extract the option elements, setting the appropriate
#  internal variables
#
#  Input:  reference to the testset object
#
#  Currently supported options
#    incpath   - include path                   (;-separated list)
#    logging   - turn logging on/off            (yes|no)
#    logfile   - define file to log output
#    msgs      - specify how verbose the output (verbose|quiet)?
sub  extract_options
 {
  my $testset = shift;
  my $children = $testset->get_children();

  initialize_options();   # reset options variables for each new file

  while(@{$children})
   {
    my $child = shift @{$children};

    next   unless $child->is_element();

    if('option' ne $child->tagname())
     {
      unshift @{$children}, $child;
      return;
     }

    # need to drive this with a data structure.
    if('incpath' eq $child->{name})
     {
      push @{$Options{$child->{name}}}, split( ';', $child->{value} );
     }
    elsif('logging' eq $child->{name})
     {
      $Options{$child->{name}} = ('yes' eq $child->{value});
     }
    else
     {
      $Options{$child->{name}} = $child->{value};
     }
   }

  push @{$Options{incpath}}, $DefaultLibDir;
 }


#--------------------------------------------------------
#  Override the internal options based on the command line
#  options.
sub   add_command_line_overrides
 {
  $Options{msgs} = ''        if defined $opts{w};
  $Options{msgs} = 'verbose' if defined $opts{v};
  $Options{msgs} = 'quiet'   if defined $opts{q};

  $Options{logging} = defined $opts{l} || defined $opts{o};
  $Options{logfile} = $opts{o} if defined $opts{o};

  # Reverse needed to keep search order intact.
  unshift @{$Options{incpath}}, split( ';', $opts{I} ) if defined $opts{I};
 }




#--------------------------------------------------------
#  Perform one test from the testset and report on
#  results
#
#  Input:  $ua   - reference to an LWP::UserAgent object
#          $test - reference to a test object to execute
#          numTests - current test number
#          succ     - number of successful tests
#
#  Output: boolean, true if test succeeded, false otherwise
sub   run_test
 {
  my $ua    = shift;
  my $test  = shift;
  my $label = $test->{label} ? " - $test->{label}" : '';
  $_[0]++;  # modify numTests directly
      
  if(evaluate_test( $ua, $test ))
   {
    printlogv( "ok $_[0]$label\n" );
    $_[1]++;
   }
  else
   {
    printlogv( "not ok $_[0]$label\n" );
   }
 }


#--------------------------------------------------------
#  Perform one test from the testset
#
#  Input:  $ua   - reference to an LWP::UserAgent object
#          $test - reference to a test object to execute
#
#  Output: boolean, true if test succeeded, false otherwise
sub  evaluate_test
 {
  my $ua     = shift;
  my $test   = shift;
  my $treq   = $test->get_child_by_tag( 'request', 0 );

  my $url    = resolve_params( $treq->{url} );
  my $method = $treq->{method} || "GET";
  my $req;

  printlogvv( "\n  $method $url\n" );

  my $hdr   = new HTTP::Headers;

  my @headers = $treq->get_children_by_tag( 'header' );
  foreach my $h (@headers)
   {
    $hdr->header( $h->{name} => $h->{value} ) if $h->{name};
   }

  if($method eq 'POST')
   {
    my ($body, $type) = extract_body_from_request( $treq );
    $hdr->header( 'Content-Type' => $type ) if $type;

    $req  = new HTTP::Request( $method, $url, $hdr,	$body );
   }
  else
   {
    $req  = new HTTP::Request( $method, $url, $hdr );
   }

  my $StartTime = time;
  my $resp = $ua->request( $req );
  $ResponseTime = time - $StartTime;

  my $bValid = validate_response( $test, $resp );

  $bValid;
 }


#--------------------------------------------------
#  Extract the text from the <body/> elements of the
#  supplied request and return a string which is used
#  as the content of the request.
#
#  Input:  $treq  - the request element
#
#  Output: string representing the content of the request
sub    extract_body_from_request
 {
  my $treq = shift;
  # ??? need to modify to deal with multiple body elements
  my @belem = $treq->get_children_by_tag( 'body' );

  return ('', '') unless @belem;
  
  my $body = '';
  my $type = '';

  # ??? change into loop and deal with boundaries
  $body = resolve_params( $belem[0]->get_text_content() );
  $type = $belem[0]->{type} if $belem[0]->{type};

  # ??? need to test for the standard encoding
  if(exists $belem[0]->{encode} and 'yes' eq $belem[0]->{encode})
   {
    $body = uri_escape( $body );
    $body = s/ /\+/g;
   }
  
  ($body, $type);
 }

#--------------------------------------------------
#  Validate the HTTP response
#
#  Input:  $test   - reference to the test to execute
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: boolean, true if test is successful, false otherwise
sub  validate_response
 {
  my $test  = shift;
  my $resp  = shift;
  my $tresp = $test->get_child_by_tag( 'response', 0 );

  my $result = validate_and( $tresp, $resp, 'response' );

  unless($result->{success})
   {
    printlogvv( "failed, $result->{'short'}.\n" );
    printlogvv( $result->{'long'}, "\n" )   if $result->{'long'};

    return 0;
   }

  $result->{'success'};
 }


#--------------------------------------------------
sub  is_regex_match
 {
  my $elem = shift;

  defined $elem and (exists $elem->{match} and 'regexp' eq $elem->{match});
 }


#--------------------------------------------------
sub  is_exist_match
 {
  my $elem = shift;

  defined $elem and (!exists $elem->{match} or 'exist' eq $elem->{match});
 }


#--------------------------------------------------
sub  is_nonexist_match
 {
  my $elem = shift;

  defined $elem and (exists $elem->{match} and 'nonexist' eq $elem->{match});
 }


#--------------------------------------------------
#  Validate a single content test
#
#  Input:  $ct     - reference to a content test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   validate_content
 {
  my $ct      = shift;
  my $resp    = shift;
  my $content = '';
  my %result  = ( success => 1, short => 'content matches', long => '' );

  $content = resolve_params( $ct->get_text_content() ) || '';

  unless(string_matches( $ct, $resp->content, $content ))
   {
    $result{'short'}   = "content does not match";
    $result{'long'}    = "Expected:\n$content\nReturned:\n" . $resp->content;
    $result{'success'} = 0;
   }

  \%result;
 }


#--------------------------------------------------
#  Perform a string test for a test criterion object
#
#  Input:  $ct       - reference to a test criterion object
#          $returned - value of a response header
#          $expected - string content expected
#
#  Output: true if match, false otherwise
sub   string_matches
 {
  my $ct       = shift;
  my $returned = shift;
  my $expected = shift;

  (is_regex_match($ct) ? ($returned =~ m/$expected/sm) : ($returned eq $expected));
 }


#--------------------------------------------------
#  Validate a single HTTP header test
#
#  Input:  $hdr    - reference to a header test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   validate_header
 {
  my $hdr    = shift;
  my $resp   = shift;
  my %result = ( success => 1, short => 'header matches', long => '' );

  my $name   = $hdr->{name};
  my $value  = $hdr->{value};
  my $rethdr = $resp->header( $name );

  if(!defined $rethdr)
   {
    $result{short} = "header \'$name\' is not present";
    $result{success} = 0 unless is_nonexist_match( $hdr );

    return \%result;
   }

  return \%result if is_exist_match( $hdr );

  unless(string_matches( $hdr, $rethdr, $value ))
   {
    $result{'success'} = 0;
    $result{'short'}   = "header mismatch";
    $result{'long'}    = "expected \'$value\', received \'$rethdr\'";
   }

  \%result;
 }



#--------------------------------------------------
#  Validate a HTTP status code test
#
#  Input:  $st     - reference to a status code test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   validate_status
 {
  my $st     = shift;
  my $resp   = shift;
  my %result = ( success => 1, short => 'status code matches', long => '' );

  my $code = $st->{code};

  unless(string_matches( $st, $resp->code, $code))
   {
    $result{'success'} = 0;
    $result{'short'}   = 'status code mismatch';
    $result{'long'}    = "expected \'$code\', received \'" . $resp->code . "\'";
   }

  \%result;
 }



#--------------------------------------------------
#  handle group of tests that must all succeed for success
#
#  Input:  $cond   - reference to an and test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   validate_and
 {
  my $cond   = shift;
  my $resp   = shift;
  my $result = { success => 1, short => 'tests successful', long => '' };

  foreach my $tst ($cond->get_children())
   {
    next unless $tst->is_element();
    my $res = perform_test( $tst, $resp );

    $result->{'long'} .= "\n -- and --\n"  if $result->{'long'};
    $result->{'long'} .= $res->{'short'};
    $result->{'long'} .= "\n".$res->{'long'} if $res->{'long'};

    return $res unless $res->{'success'};
   }

  $result;
 }



#--------------------------------------------------
#  handle group of tests that one must succeed for success
#
#  Input:  $cond   - reference to an or test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   validate_or
 {
  my $cond   = shift;
  my $resp   = shift;
  my $result = { success => 0, short => 'tests failed', long => '' };

  foreach my $tst ($cond->get_children())
   {
    next unless $tst->is_element();
    my $res = perform_test( $tst, $resp );

    $result->{'long'} .= "\n -- or --\n" if $result->{'long'};
    $result->{'long'} .= $res->{'short'};
    $result->{'long'} .= "\n".$res->{'long'} if $res->{'long'};

    return $res if $res->{'success'};
   }

  $result;
 }



#--------------------------------------------------
#  handle a test that must fail for success
#
#  Input:  $not    - reference to a not test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   validate_not
 {
  my $not    = shift;
  my $resp   = shift;
  my $result = undef;

  my $tst = (grep { $_->is_element() } $not->get_children())[0];

  $result = perform_test( $tst, $resp );
  $result->{'long'}    = "not ($result->{'long'})" if $result->{'long'};
  $result->{'short'}   = "not ($result->{'short'})";
  $result->{'success'} = !$result->{'success'};

  $result;
 }


#--------------------------------------------------
#  test response time of the request
#
#  Input:  $tst    - reference to a time test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub  validate_time
 {
  my $tst     = shift;
  my $resp    = shift;
  my %result  = ( success => 1, short => 'response time in range', long => '' );

  if(exists $tst->{min} and $tst->{min} and $ResponseTime < $tst->{min})
   {
    $result{'short'}   = "response time shorter than expected";
    $result{'long'}    = "Expected: $tst->{min} secs, returned: $ResponseTime secs";
    $result{'success'} = 0;
   }

  if(exists $tst->{max} and $tst->{max} and $ResponseTime > $tst->{max})
   {
    $result{'short'}   = "response time longer than expected";
    $result{'long'}    = "Expected: $tst->{max} secs, returned: $ResponseTime secs";
    $result{'success'} = 0;
   }

  \%result;
 }



#--------------------------------------------------
#  execute code to test response
#
#  Input:  $tst    - reference to a code test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub  validate_code
 {
  my $tst     = shift;
  my $resp    = shift;
  my $label   = $tst->{label} || '';
  my %result  = ( success => 1, short => "code test '$label' successful", long => '' );
  my @ret     = (1, '', '');

  my $code = resolve_params(  $tst->get_text_content() ) || '';

  {
   local $SIG{__WARN__} = sub
    {
     my $m = shift;
     $m =~ s/at \(eval \d+\)/in code test '$label' at/g;
     warn $m;
    };

   $code =~ s/&lt;/</gsm;
   $code =~ s/&gt;/>/gsm;
   $code =~ s/&apos;/'/gsm;
   @ret = eval $code;
  }

  if($@)
   {
    $@ =~ s/\(eval \d+\) //g;
    die "Code($label) failed: $@\n";
   }

  $result{success} = $ret[0];
  $result{short}   = $ret[1] || ($ret[0]
                                  ? "code test '$label' successful"
                                  : "code test '$label' failed"
                                 );
  $result{long}    = $ret[2] || '';

  \%result;
 }



#--------------------------------------------------
#  pseudo-test criterion for sending messages or aborting
#  on a really critical error.
#
#  Input:  $tst    - reference to a msg pseudo-test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub   send_msg
 {
  my $tst     = shift;
  my $resp    = shift;
  my %result  = ( success => exists $tst->{fail} ? 'no' eq $tst->{fail} : 0,
                  short => 'msg encountered',
                  long  => '' );

  $result{success} = msg( $tst->get_text_content(),
                          $tst->{print}, $tst->{action}
                        );
                        
  \%result;
 }




#--------------------------------------------------
#  Supply the actual function of the msg pseudo-test criterion.
#  Print the supplied message under the appropriate condition, and
#  take the supplied action.
#
#  Input:  $msg    - message to display
#          $print  - specify conditions under which to print
#          $action - specify action to take after printing
#
#  Output: a boolean telling if the action was success or fail
sub msg
 {
  my $msg    = shift || '';
  my $print  = shift || 'normal';
  my $action = shift || 'fail';
  
  $msg = resolve_params( $msg );
  $msg =~ s/[ \t]+$//s;

  PRINT:
   {
    'always'  eq $print && do { printlog( $msg );   last PRINT; };
    'normal'  eq $print && do { printlogv( $msg );  last PRINT; };
    'verbose' eq $print && do { printlogvv( $msg ); last PRINT; };
   };

  ACTION:
   {
    'success' eq $action && do { return 1;          };
    'fail'    eq $action && do { return 0;          };
    'stop'    eq $action && do { die "msg-stop\n";  };
    'exit'    eq $action && do { exit( 1 );         };
   };
 }




#--------------------------------------------------
#  Vector to the correct kind of test
#
#  Input:  $test   - reference to a test criterion object
#          $resp   - reference to an HTTP::Response object resulting
#                    from an HTTP request
#
#  Output: reference to a hash containing the result information
sub  perform_test
 {
  my $test = shift;
  my $resp = shift;
  my $tag  = $test->tagname();
  my $label = $test->{label} || $tag;

  printlogvv( "Test: $label\n" );

  $Tests{$tag}->( $test, $resp );
 }


#--------------------------------------------------
#  Read parameters from the testset and
#   command line
#
#   Input:  $ts  - reference to a testset object
sub  setup_params
 {
  my $ts = shift;
  my $param;

  foreach $param ($ts->get_children_by_tag( 'param' ))
   {
    my $name  = $param->{name};
    die "Invalid param name \'$name\'.\n" unless $name =~ /^\w+$/;

    my $value = $param->{value};

    $value = $CmdLine{$name} if exists $CmdLine{$name};

    $Params{$name} = resolve_params( $value );
   }

  foreach $param (keys %CmdLine)
   {
    $Params{$param} = $CmdLine{$param};
   }
 }


#--------------------------------------------------
#  Replace all parameters found in the supplied
#   string with the value of those parameters.
#
#   Input:   $str  - string possibly containing replaceable parameters
#
#   Output:  string with replaceable parameters resolved
sub  resolve_params
 {
  my $str = shift;

  if($str)
   {   # If param replace with param value, otherwise exec Perl expr.
    $str =~ s/{{([^}]+)}}/expand_a_param( $1 )/smeg;
   }

  $str;
 }


#-------------------------------------------------
#  Take a potential parameter reference and expand
#  it either as the value of the parameter or as a
#  Perl expression.
#  
#  Input:  $parmref  - a suspected parameter reference
#  
#  Output: the expanded text of the parameter or
#          result of the Perl expression
sub   expand_a_param
 {
  my $parmref = shift;

  unless($parmref =~ /^\w+$/)      # doesn't appear to be a parameter
   {
    return eval $parmref;
   }
  elsif(exists $Params{$parmref})  # the parameter exists
   {
    return $Params{$parmref};
   }
  else                             # looks like a parameter, it's not
   {
    die "Reference of unknown parameter \'$parmref\'\n";
   }
 }

#--------------------------------------------------
#  Extract parameters of the form 'name=value' from
#   the command line.
sub   extract_cmd_line
 {
  my @args=();

  foreach(@ARGV)
   {
    if(/^([^=]+)=([^=]*)$/)
     {
      $CmdLine{$1} = $2;
     }
    else
     {
      push @args, $_;
     }
   }

  @ARGV = @args;
 }



#--------------------------------------------------
#  If the -f command line option has been used to
#  supply a file listing testsets, expand that file
#  onto the command line.
sub    expand_list_file
 {
  return unless defined $opts{f} and -e $opts{f};

  local *L;
  local $_;
  open( L, $opts{f} ) or die "Unable to open list file '$opts{f}'.\n";
  my @testsets = ();
  while(<L>)
   {
    s/#.*//;
    next if /^\s*$/;

    push @testsets, split( /\s+/, $_ );
   }
  close( L );

  unshift @ARGV, @testsets;
 }




#---------------------------------------------------
#  Compile library code which may be used elsewhere
#  in a test.
#
#  Input:  $code    - reference to a codelib to compile
#          numTests - current test number
#          Succ     - number of successful tests
sub   execute_a_session
 {
  my $session = shift;
  my $label   = $session->{label} || 'unlabeled session';

  printlogv( "# Starting '$label'\n" );
  # Startup a session

  my ($Succ, $numTest) = process_set_of_tests( $_[0], 
                                                $session->get_children()
                                             );

  $_[0]  = $numTest;
  $_[1] += $Succ;
  
  # Cleanup the session
  printlogv( "# Ending '$label'\n" );
 }


#---------------------------------------------------
#  Compile library code which may be used elsewhere
#  in a test.
#
#  Input:  $code  - reference to a codelib to compile
sub   compile_lib
 {
  my $code  = shift;
  my $label = $code->{label};

  printlogvv( "Compile codelib ", ($code->{label} || 'unkown'),
              (exists $code->{id} ? "($code->{id})\n" : "\n")
            );

  if(exists $code->{id})
   {
    my $id = $code->{id};

    if(exists $CodeLibIDs{$id})
     {
      printlogvv( "codelib ($id) already compiled\n" );
      return 1;
     }

    $CodeLibIDs{$id} = 1;
   }

  {
   # signal handler to clean up compile warnings
   local $SIG{__WARN__} = sub
    {
     my $m = shift;
     $m =~ s/at \(eval \d+\)/in codelib '$label' at/g;
     warn $m;
    };

   my $content = resolve_params( $code->get_text_content() );
   $content =~ s/&lt;/</gsm;
   $content =~ s/&gt;/>/gsm;
   $content =~ s/&apos;/'/gsm;
   eval $content;
  }

  if($@)
   {
    $@ =~ s/\(eval \d+\) //g;
    die "Code($label) failed: $@\n" ;
   }
 }



#--------------------------------------------------------
#  Search the current directory and include path to find
#  an include file
#
#  Input:  $file   - name of file to find
#
#  Output: filename qualified with the appropriate path.
#          If the filename is not found, the original name
#          is returned
sub   find_include_file
 {
  my $file = shift;

  return $file if File::Spec->file_name_is_absolute( $file ) or -e $file;

  foreach my $dir (@{$Options{incpath}})
   {
    my $f = File::Spec->catfile( $dir, $file );

    return $f if -e $f;
   }

  return $file;
 }



#---------------------------------------------------------------
#  Return the content of the root element in the file referenced
#  by the supplied include element. Recursively expand includes
#  in the children.
#
#  Input:   $inc  - reference to an include object
#
#  Output:  one or more xml objects to replace the include object
sub   expand_an_include
 {
  my $inc  = shift;
  my $file = find_include_file( $inc->{file} );

  printlogvv( "Including ", ($inc->{label} || $file || 'unkown'), "\n" );
  die "Missing or empty file attribute.\n" unless $file;

  if(exists $inc->{parse} and 'text' eq $inc->{parse})
   {
    local *I;
    local $/ = undef;
    open( I, $file ) or die "Unable to open include file '$file'.\n";
    my $content = <I>;
    close( I );
    XMLdata::make_text( $content );
   }
  else
   {
    my $content = $parser->parsefile( $file );
    die "Invalid include file.\n" unless defined $content;

    my $root = XMLdata::root( $content );
    die "Invalid include file.\n" unless defined $root;
    warn "Include file root not an inclusion element.\n"
                                 unless 'inclusion' eq  $root->tagname();

    expand_includes( $root );

    $root->get_children();
   }
 }


#---------------------------------------------------------------
#  Walk the supplied container element, replacing all include
#  elements with their contents.
#
#  Input:  $contain   - a container object in which we will expand
#                       include elements
sub   expand_includes
 {
  my $contain = shift;

  $contain->{Kids} = [ map { 'include' eq  $_->tagname() ?
                                  expand_an_include( $_ ) : ($_ )
                           }
                       @{$contain->{Kids}}
                     ];
 }



#----------------------------------------------------------------
#  Check the test set for validity.
#
#  Input:  $testset  - reference to a testset object
#
#  Output: false if valid, a string describing the problem if not
sub   invalid_testset
 {
  my $testset = shift;
  my %LegalTags = map { $_ => 1 } qw/testset param include option test codelib
                                     request response status header content code
                                     body time msg not and or session/;

  return "Invalid root element." unless 'testset' eq $testset->tagname();

  my $is_valid = sub { my $el = shift;
                       die $el->tagname()."\n" 
                                    unless !$el->is_element() or
                                    $LegalTags{$el->tagname()};
                     };

  eval
   {
     XMLdata::visit_elements( $testset, $is_valid );
   };

  if($@)
   {
    chomp( $@ );
    return "Unrecognized element type \'$@\'";
   }
  else
   {
    return 0;
   }
 }


#---------------------------------------------------
#  Open the logging file, if necessary
sub   open_logfile
 {
  if($Options{logging})
   {
    open( LOG, ">>$Options{logfile}" ) or die "Unable to open log file '$Options{logfile}'.\n";
   }
 }



#---------------------------------------------------
#  Close the logging file, if necessary
sub  close_logfile
 {
  close( LOG ) if $Options{logging};
 }



#---------------------------------------------------
#  Print normal messages and add to log.
#
#  Input:  A list of messages to print
sub    printlog
 {
  print @_;
  print LOG @_ if $Options{logging};
 }



#---------------------------------------------------
#  Print normal verbose messages and add to log.
#
#  Input:  A list of messages to print
sub    printlogv
 {
  print @_     if $Options{msgs} ne 'quiet';
  print LOG @_ if $Options{logging};
 }



#---------------------------------------------------
#  Print extra verbose messages and add to log.
#
#  Input:  A list of messages to print
sub  printlogvv
 {
  print @_     if 'verbose' eq $Options{msgs};
  print LOG @_ if $Options{logging};
 }



#--------------------------------------------------
#  Usage message
sub  usage
 {
  die <<"EOU";
Usage: $0 [-vwqVl] [-o logfile] [-I incpath] [-f list] [name=value ...] test.files ...

Where:  -v   verbose output
        -w   normal output, default
        -q   quiet output
        -V   print version information
        -l   log results to HTTPtest.log
        -o   send results to specified logfile
        -I   semicolon-separated path to check for include files
        -f   supply a file listing the test files to use

name=value pairs override parameters in the test files

test.files is a list of files that contain the tests to run
EOU
 }

#---------------------------------------------------------------------
#  Code merged from other libraries to make standalone script version.
#---------------------------------------------------------------------
{
package XMLdata;

use strict;
use vars qw/$xlf $Pkg %convert/;

$Pkg = 'obj';

#-------------------------------------------------------------------
# For character conversions
%convert = ( '&'=>'&amp;', '<'=>'&lt;', '>'=>'&gt;', '"'=>'&quot;' );

$xlf = make_text( "\n" );  # used for formatting



#--------------------------------------------------------------------
#   Set the current package name and setup the Characters class
#
#   Input:   $pkg  -  package name to use
sub   set_package
 {
  $Pkg = shift;
 }



#---------------------------------------------------------------
#  Create an XMLdata character string
#
#  Input:  a character string
#
#  Return: a Characters object containing the text
sub   make_text
 {
  my $str  = shift;

  bless { Text=>$str }, $Pkg."::Characters";
 }




#----------------------------------------------------------------
#  Extract the root element from the reference returned by the
#  Object style of XML::Parser
#
#  Input:   return value from XML::Parser->parse()
#
#  Return:  the xml object representing the root element of the
#           XML document
sub   root
 {
  (grep { (ref $_) !~ /::Characters$/ } @{$_[0]})[0];
 }

#-----------------------------------------------------------------
#  Execute the supplied function on the supplied object and all of
#  its children.
#
#  Input:  $obj  - an xml object
#          $exec - a code reference to execute on $obj and all of
#                  its descendents
sub   visit_elements
 {
  my $obj  = shift;
  my $exec = shift;

  $exec->( $obj, @_ );

  return unless $obj->is_element();

  foreach($obj->get_children())
   {
    visit_elements( $_, $exec, @_ );
   }
 }


#-----------------------------------------------------------------
#  Make package associated with supplied element name a derived
#  class of XMLdata::Element
#
#  Inputs:  $name   - name of an element class to derive from
#                     XMLdata::Element
sub   DeclareElement
 {
  no strict "refs";
  my $name = shift;

  $name = $XMLdata::Pkg.qq{::$name} unless $name =~ /::/; 

  push @{$name.'::ISA'}, "XMLdata::Element";
 }



#-----------------------------------------------------------------
#  Make packages associated with supplied element names derived
#  classes of XMLdata::Element
#
#  Inputs:  @_   - list of names of element classes to derive from
#                  XMLdata::Element
sub   DeclareElements
 {
  foreach (@_)
   {
    DeclareElement( $_ );
   }
 }
}

{
package tst::Characters;

use strict;

#---------------------------------------------------------------
#  Return a recognizable string for character data
#
#  Return:  tag name as a string
sub   tagname  { '#PCDATA'; }


#----------------------------------------------------------------
#  Return the text contained in a ::Characters node.
#
#  Input:  an xml Characters object
sub   get_text  { $_[0]->{Text}; }


#----------------------------------------------------------------
#  Return a boolean stating that this is not an Element
sub   is_element  { 0; }


#----------------------------------------------------------------
#  Returns true if the supplied object is a text object
#
#  Input:  an xml object
#
#  Return: true if the xml object is a text object, false otherwise
sub   is_text  { 1; }
}

{
package XMLdata::Element;

use strict;


#---------------------------------------------------------------
#  Return the tag name from an xml object (w/o the package)
#
#  Return:  tag name as a string
sub   tagname
 {
  my $self = shift;
  my $tag = ref $self;

  $tag =~ /([^:]+)$/;

  $1;
 }

#----------------------------------------------------------------
#  Returns the number of children in the element
#
#  Return: the count of the number of children of the element
sub   count_children
 {
  my $self = shift;

  defined $self->{Kids} ? scalar @{$self->{Kids}} : 0;
 }



#----------------------------------------------------------------
#  Returns true if the object has no children.
#
#  Return: true if the element has no children, false otherwise
sub   is_empty
 {
  my $self = shift;

  (0 == $self->count_children());
 }




#---------------------------------------------------------------
#  Return a list (or a reference to a list) of children for the
#  object.
#
#  Return: a list (or reference to a list in scalar context) of
#          xml objects
sub   get_children
 {
  my $self = shift;

  if(exists $self->{Kids})
   {
    wantarray ? @{$self->{Kids}} : $self->{Kids};
   }
  else
   {
    wantarray ? () : [];
   }
 }


#---------------------------------------------------------------
#  Return a list (or a reference to a list) of children of the
#  given type from the object.
#
#  Input:  $tag  - a tag name
#
#  Return: a list (or reference to a list in scalar context) of
#          xml objects
sub   get_children_by_tag
 {
  my $self = shift;
  my $tag  = shift;

  $tag = $XMLdata::Pkg."::$tag" unless $tag =~ /::/;

  my @children = grep { $tag eq ref $_ } $self->get_children();

  wantarray ? @children : \@children;
 }


#---------------------------------------------------------------
#  Return a list (or a reference to a list) of descendents of the
#  given type from the object.
#
#  Input:  an xml object
#          $tag  - a tag name
#
#  Return: a list (or reference to a list in scalar context) of
#          xml objects
sub   get_descendents_by_tag
 {
  my $self = shift;
  my $tag  = shift;

  $tag = $XMLdata::Pkg."::$tag" unless $tag =~ /::/;

  my @descend = ();

  foreach my $child ($self->get_children())
   {
    push @descend, $child if $tag eq ref $child;
    push @descend, $child->get_descendents_by_tag( $tag )
                    unless !$child->isa('XMLdata::Element') or $child->is_empty();
   } 

  wantarray ? @descend : \@descend;
 }


#----------------------------------------------------------------
#  Return a particular child by index of the object.
#
#  Input:  $n    - an optional index
#
#  Return: an xml objects
sub   get_child
 {
  my $self = shift;
  my $n    = shift || 0;

  $self->get_children()->[$n];
 }


#----------------------------------------------------------------
#  Return a particular child of the given type by index of the
#  object.
#
#  Input:  $tag  - a tag name
#          $n    - an optional index
#
#  Return: an xml objects
sub   get_child_by_tag
 {
  my $self = shift;
  my $tag  = shift;
  my $n    = shift || 0;

  $self->get_children_by_tag( $tag )->[$n];
 }

#----------------------------------------------------------------
#  Return the text contained in a given element
#
#  Input:  an xml object with containing text
#
#  Return: the text string from the content
sub   get_text_content
 {
  $_[0]->get_child( 0 )->get_text();
 }



#----------------------------------------------------------------
#  Return a boolean stating that this is an Element
sub   is_element
 {
  1;
 }


#----------------------------------------------------------------
#  Returns true if the supplied object is a text object
#
#  Input:  an xml object
#
#  Return: true if the xml object is a text object, false otherwise
sub   is_text
 {
  0;
 }
}

__END__

=head1 NAME

HTTPtestS.pl

=head1 Purpose

B<HTTPtest> is a generalized HTTP request test program. It allows for
efficient regressions testing of any HTTP-based server. B<HTTPtestS> is
a version of the script modified to run standalone. Anywhere the name
B<HTTPtest> is used in the documentation, B<HTTPtestS> can be used as
well.

B<Warning:> This program is under construction, so the documentation is
subject to change.

=head1 SCRIPT CATEGORIES

HTTP - suggested

=head1 PREREQUISITES

This script depends on both the C<strict> and C<vars> pragmas. The script also uses
the C<FindBin> C<LWP::UserAgent>, C<URI::Escape>, C<XML::Parser>, C<Getopt::Std>,
and C<File::Spec> modules.

=head1 COREQUISITES

If the C<Time::HiRes> module is available, it is used to generate higher-resolution
timings on the time test criterion and the script timing.

=head1 OSNAMES

any. Tested on MSWin32 and linux.

=head1 Description

The B<HTTPtest> program uses a testset file to describe a series of tests
to perform using the HTTP protocol. In general, a set of tests are aimed
at a single server or service. Like HTTP itself, the tests are defined
in terms of a request and a response. The testset file describes the tests
in an XML-based format, described below.

B<HTTPtest> reads each test in the testset file, performs the specified request,
and evaluates the response based on the criteria described in the test. If
all criteria are met, the test is successful. Otherwise, the test fails.

=head1 Usage

B<HTTPtest> is executed as follows:

 perl HTTPtest.pl [-vwqVl] [-o logfile] [-I incpath] [-f list] [name=value ...] test.files ...

   Where:  -v   verbose output
           -w   normal output, default
           -q   quiet output
           -V   print version information
           -l   log results to HTTPtest.log
           -o   send results to specified logfile
           -I   semicolon-separated path to check for include files
           -f   supply a file listing the test files to use

   name=value pairs override parameters in the test files

   test.files is a list of files that contain the tests to run

If run with a bad option or no test files, the above message is printed.

=head1 Testset File

The testset file contains a C<testset> root element. The C<testset> may
contain C<include> elements to include information from other files,
C<param> elements which factor out reused parameters, and C<test> elements
which describe the tests to run.

Each C<test> consist of a C<request>, which describes the HTTP request, and
a C<response> which describes the criteria for evaluating the HTTP response.
A C<request> specifies the URL to call including any query parameters, an
HTTP method such as I<GET> or I<POST>, and an optional request body.

A C<response> contains a series of evaluation criteria which include the
ability to test:

=over 4

=item status

The response status code for the response. Reasonable values include I<200>
and I<404>.

=item header

Tests for the existence or value of particular MIME-headers in the response.
Useful for verifying redirections and testing returned cookies.

=item content

Evaluation criteria for the content of response.

=item time

Compare the response time of the URL request against a minimum and maximum
timespan in seconds.

=item code

Execute arbitrary Perl code on the response to evaluate the response.

=item msg

This pseudo-criterion displays a message to the user and optionally aborts
the current testset or program run.

=back

By default all of the evaluations in the C<response> must succeed in order
for the C<test> to succeed. However, three other elements are supported to
allow for arbitrary logical combinations of the evaluations.

=over 4

=item and

All of the evaluation criteria contained in the C<and> element must succeed
in order for the C<and> to succeed. Any unsuccessful evaluation causes the
C<and> to fail without executing any remaining children.

=item or

One of the evaluation criteria contained in the C<or> element must succeed
in order for the C<or> to succeed. Any successful evaluation causes the
C<or> to succeed without executing any remaining children.

=item not

The sense of the evaluation criterion contained in the C<not> element is
reversed, so that a failure becomes a success.

=back

=head1 Element List

=head2 and

The C<and> element is used to combine a set of evaluation criteria
in a logical I<and> relationship. The C<and> element can contain any
of the evaluation elements or the logical elements. The C<and> element
has one optional attribute I<label> which is a displayable description
of the set of criteria contained in the C<and>. It may be used in logging
and failure reporting.

B<HTTPtest> evaluates the response based on each of the children of the
C<and> in turn. When an evaluation criterion fails, no more children
are tested and the C<and> evaluation fails.

=head2 body

The C<body> element supplies the content for an HTTP request. It is currently
only supported for the I<POST> HTTP method. The content of this element is
used as the body of the request by B<HTTPtest>. Since this content resides in
an XML document, it may be necessary to wrap the content in a CDATA section
in order for the file to remain well-formed.

The C<body> element has two optional attributes. The C<type> attribute specifies
the MIME type of the content. By default, the type is I<application/x-www-form-urlencoded>,
which is the type used by browsers on HTML forms. The C<encode> attribute specifies
whether the content needs to be URL-encoded. The default value is I<no>. If you
have already encoded the data, the correct answer is I<no>.

=head2 code

The C<code> element specifies a piece of Perl code to execute in order to evaluate
the HTTP response. The C<code> element has one optional attribute. The C<label>
attribute provides a displayable description of this element that can be used in
error reporting and logging.

The content of this element is raw Perl code. Since Perl code can easily violate the
well-formedness criteria, it is recommended that the whole content of this element be
placed in a CDATA section.

The Perl code is executed with a set of variables that are accessible. These variables
can be used to determine how to perform the tests or communicate with other pieces
of code. The variables of interest are:

=over 4

=item $resp

This is a reference to an HTTP::Response object containing the current response. This
is a C<my> variable, and therefore only available directly inside the C<code> element.

=item $label

This string is the value of the I<label> attribute for the current test. This is a C<my>
variable, and therefore only available directly inside the C<code> element.

=item %Params

This is a global hash matching all of the parameter names to their current values. The
Perl code is allowed to modify values in this hash to pass data to other tests.

=item $parser

This is a global reference to an XML::Parser object configured with the I<Objects> style.
This object may be used to parse XML from the response to simplify testing. See the
XMLobj.pm library file for tools that can manipulate this structure.

=item $ResponseTime

This global variable contains the time in seconds for the HTTPresponse to return.

=back

The Perl code should return a list of scalars. The first item in the list is the
only required item. It is true if the test was successful, and false otherwise. The
second item in the list is a short string describing the result of the test. The third
and final item is a long string giving a verbose description of the result of the test.
If either the second or third items is missing, a generic answer is used in each case.

=head2 codelib

The C<codelib> element declares Perl code that is to be compiled into the test script
for use in later tests. This is a good place to use modules or define routines that
are needed by C<code> criteria defined later in the file. The content of this element
is raw Perl code. Since Perl code can easily violate the well-formedness criteria, it
is recommended that the whole content of this element be placed in a CDATA section.

The C<codelib> element has one required attribute and one optional attribute. The I<label>
attribute provides a displayable description of this element that can be used in error
reporting and logging. The optional I<id> attribute is used to uniquely identify a
C<codelib>. This helps B<HTTPtest> to recognize if a C<codelib> is encountered more than
once. (For example through the use of C<include> elements.) If a C<codelib> I<id> is
encountered a second time, that C<codelib> is not evaluated the second or subsequent times.
If a C<codelib> does not contain an I<id> and it is encountered more than once, it is
evaluated each time it is encountered.

B<WARNING:> This element has not been thoroughly tested at this time.

=head2 content

The C<content> element specifies evaluation criteria for the body of the HTTP response.
The C<content> element has one optional attribute. If the I<match> attribute is missing
or has a value of I<exact>, the body of the HTTP response must match the content of the
C<content> element exactly. If the I<match> attribute has a value of I<regexp>, the
content of the element is treated as a regular expression to be matched against the
HTTP response content.

B<WARNING:> There is a limit to the size of a regular expression in Perl. It is better to
break a complicated test into several smaller tests.

=head2 header

The C<header> element specifies a MIME header in either a C<request> or a
C<response>. It has three attributes that are treated slightly differently
depending on whether the element is contained in a C<request> or a C<response>.
In both cases, the I<name> attribute is required and supplies the name of
the MIME header of interest.

The I<value> attribute specifies the value of that MIME header. In the case of
a C<request>, this attribute is required and specifies the literal text of the
value of the header. In the case of a C<response>, the I<value> attribute is
interpreted as described by the I<match> attribute.

The I<match> attribute is specifies the interpretation of the I<value> attribute
on a C<header> in a C<response>. The default value of the I<match> attribute
is I<exact>. The valid values for I<match> are

=over 4

=item exact

The value of the MIME header must exactly match the I<value> of the C<header>.

=item regexp

The I<value> of the C<header> is treated as a regular expression to match the value
of the specified MIME header.

=item exist

The MIME header must exist in the HTTP response. The I<value> attribute is ignored.

=item nonexist

The MIME header must not exist in the HTTP response. The I<value> attribute is ignored.

=back

=head2 include

The C<include> element allows portions of a C<testset> to be factored into separate
files. This supports sharing of information between testset files and can simplify
maintenance of test sets.

The C<include> element has one required attribute (I<file>) and two optional attributes
(I<label> and I<parse>). The I<file> attribute specifies the file to be included.
B<HTTPtest> looks for the file as it is specified, relative to the current directory, first.
If the file is not found and the filename is not an absolute path, B<HTTPtest> then attempts
to find the file by appending the I<file> attribute to each path in the include path.
I<label> attribute is a displayable description only used for logging and error reporting.

The I<parse> attribute tells B<HTTPtest> how to treat the data from the included file. If
the I<parse> attribute is missing or if its value is I<xml>, the contents of the included
file are parsed and all children of the root element replace the C<include> element. If the
value of the I<parse> attribute is I<text>, the contents of the file are treated as a text
node that replaces the C<include> element. Since this data is not handled directly by the
XML parser, there is no need to use character entities such as C<&lt;> and C<&amp;>.

One extra constraint on the C<include> is that the test set file should still be a valid
document after the C<include> elements are replaced by the content of their files.

=head2 inclusion

The C<inclusion> element is the root element of any included I<xml>-parsed file. Its purpose
is to provide a well-formed XML document for the included file.

=head2 msg

The C<msg> element is used to report unusual problems to the user and optionally to
abort a test run. The C<msg> element has two optional attributes and contains text
to display. The I<print> attribute determines when the message is printed. Possible
values are:

=over 4

=item always

Always print the message when the C<msg> element is encountered.

=item normal

Print the message when the C<msg> element is encountered and the B<-w> or B<-v> switches
are active. This is the default printing behavior.

=item verbose

Print the message when the C<msg> element is encountered and the B<-v> switch
is active.

=back

The I<action> attribute determines the effect of this pseudo-criterion on the test
in progress. The possible values are:

=over 4

=item success

Treat the C<msg> element as a successful test criterion.

=item fail

Treat the C<msg> element as a failed test criterion. This is the default action.

=item stop

Stop the current testset, but continue processing any testset files remaining on
the command line.

=item exit

Exit the HTTPtest.pl script, altogether.

=back

The C<msg> element is best used as part of an C<or> or C<and> condition. This
allows an earlier test criterion to determine whether or not the C<msg> element is
processed at all.

=head2 not

The C<not> element is used to logically reverse the outcome of an evaluation criterion.
The C<or> element can contain any one of the evaluation elements or the logical elements.
The C<not> element has one optional attribute I<label> which is a displayable description.
It may be used in logging and failure reporting.

=head2 option

The C<option> element configures default processing options for B<HTTPtest>. All of the
options configurable through the C<option> element are also available through command
line parameters. The command line parameters override whatever C<option>s are in the test
set file. All of the C<option> elements must come before any other elements in the C<testset>.

The C<option> element has two required attributes, I<name> and I<value>. The I<value>
attributes will be interpreted differently depending on option they are applied to. The
allowable options are:

=over 4

=item incpath

The I<value> attribute for this option is a semicolon-separated list of paths to use in finding
include files. Unlike the other options, the command line switch does not override this option.
Instead the paths supplied by the B<-I> switch are prepended to the include path.

=item logging

The I<value> for this option is either I<yes> (enable logging) or I<no> (disable logging). This
is equivalent to the B<-l> switch.

=item logfile

The I<value> for this option is the name of a file into which the logging information is written.
This is equivalent to the B<-o> switch.

=item msgs

The I<value> for this option is either an empty string (normal output), I<quiet> (quiet mode),
or I<verbose> (verbose mode). This modes are equivalent to the I<-w>, I<-q>, and I<-v> switches.

=back

=head2 or

The C<or> element is used to combine a set of evaluation criteria
in a logical I<or> relationship. The C<or> element can contain any
of the evaluation elements or the logical elements. The C<or> element
has one optional attribute I<label> which is a displayable description
of the set of criteria contained in the C<or>. It may be used in logging
and failure reporting.

B<HTTPtest> evaluates the response based on each of the children of the
C<or> in turn. When an evaluation criterion succeeds, no more children
are tested and the C<or> evaluation succeeds.

=head2 param

The C<param> element is an empty element which gives a name to a piece of text
which is expected to be reused many times in the test set. A good example would
be the name of the server undergoing test. For example,

  E<lt>param name="server" value="testserver.telescan.com"/>

Using a C<param> in this way simplifies pointing the test to a new server. The
C<param> is then referenced in any text or attribute in the test set file using
the form I<{{server}}>.

In addition, the value of a C<param> may be changed from the B<HTTPtest> command
line using the syntax: I<name=value>. To run this C<testset> on the server
I<live.telescan.com>, you would add I<server=live.telescan.com> to the command
line before the name of the testset file.

The C<param> element has two required attributes. The I<name> attribute specifies
the name by which this parameter is referenced. The I<value> attribute specifies
the replacement text.

=head2 request

The C<request> element describes a complete HTTP request to be used in the test.
The C<request> has a required attribute, I<url>, which specifies the URL to
which the request is made. This URL may contain a query string. Because of the
requirements of XML, this query string will need to be modified if it contains
the ampersand character E<amp>. The ampersand must be replaced by "E<amp>amp;"
in the I<url> attribute. This string will be converted back to its proper form
before it is requested.

The C<request> element also has an optional I<method> attribute, which defaults
to I<GET>. Currently, B<HTTPtest> supports values of I<GET> and I<POST> for this
attribute. At some point, the program may be extended to support all of the HTTP
request methods.

The C<request> element can contain zero or more C<header> elements followed by
zero or more C<body> elements. In addition, C<include> elements may optionally
occur anywhere in the C<request> content. The C<header> elements allow you to
specify MIME headers to apply to the request. The C<body> element is used to
contain the content of a I<POST> request. At this time, only one C<body> element
is supported in a request. However, at a future date, this will be extended to
multiple C<body> elements for support of the I<multipart> Content types.

=head2 response

The C<response> element defines the evaluation criteria to be met for the current
test. After the HTTP request has been made and an HTTP response is returned,
B<HTTPtest> walks the children of the C<response> element and attempts to verify
the response.

The C<response> element has one optional attribute. The I<label> attribute defines
a displayable description of this response set that may be used in error messages
or logging.

The content of the C<response> response element must include one or more of the
following elements:

=over 4

=item *

status

=item *

header

=item *

time

=item *

content

=item *

code

=item *

and

=item *

or

=item *

not

=back

The C<response> element may also contain C<include> elements. After the
C<include> is resolved, the only child elements allowed in a C<response> are
the ones listed above.

=head2 status

The C<status> element specifies values to match for the HTTP Response status
code. The element has one required attribute and one optional attribute. The
required I<code> attribute specifies a value to use in the comparison. This
value is interpreted based on the value of the optional I<match> attribute.
If the value of the I<match> attribute is I<exact> or the attribute is missing,
the code must match the response exactly. If the value of the I<match> attribute
is I<regexp>, the value of I<code> is treated as a regular expression.

=head2 test

The C<test> element describes a particular test to be run. The C<test> contains only
two children, a C<request> and a C<response>. The C<test> also has one required
attribute I<label>, which is a displayable description of the test which is used in
failure reporting.

=head2 testset

The C<testset> is the root element of the testset file. It can contain zero
or more C<param> elements, followed by zero or more C<codelib> elements, followed
by zero or more C<test> elements. In addition, C<include> elements may occur
anywhere in the C<testset> element.

The C<testset> has one required attribute, I<label> which is a short displayable
description of the test set.

=head2 time

The C<time> element specifies the expected time limits for an HTTP response. The
C<time> element has two optional attributes, I<min> and I<max>. If the I<min>
attribute is specified, the test fails if the HTTP response returns in less than
that many seconds. If the I<max> attribute is specified, the test fails if the HTTP
response returns in more than that many seconds. If the value of I<min> is greater
than the value of I<max>, the test will always fail.

=head1 Example Tests

The following is a very simple test. We are just testing to see if the page is returned
in a reasonable amount of time. In this case, the test is successful if we recieve a
status code of 200 (OK) and if the page returns in no more than 10 seconds.

  <test label="Did it come back">
    <request url="http://www.tscn.com/" method="GET"/>
	<response>
	  <status code="200"/>
	  <time max="10"/>
	</response>
  </test>

To extend this test a little, we will check to see if the returned page is an HTML document.
In this case, I am taking advantage of the fact that I know the page has the HTML tags in
all upper case.

  <test label="Respond in HTML">
    <request url="http://www.tscn.com/" method="GET"/>
	<response>
	  <status code="200"/>
	  <time max="10"/>
	  <header name="Content-Type" value="text/html"/>
	  <content match="regexp"><![CDATA[<HTML>.*</HTML>]]>
	</response>
  </test>

Now we will check to see if we are getting the page (or, at least the title) that we
think we are getting back.

  <test label="Old WSC root page">
    <request url="http://www.tscn.com/" method="GET"/>
	<response>
	  <status code="200"/>
	  <time max="10"/>
	  <header name="Content-Type" value="text/html"/>
	  <content match="regexp"><![CDATA[<HTML>.*</HTML>]]>
	  <content match="regexp"><![CDATA[
<TITLE>Wall Street City - The Investor's Supersite on the Web</TITLE>
]]>
	</response>
  </test>

=head1 Example msg Tests

The C<msg> element is a little more subtle than most of the other test criteria. It
is almost always used in conjunction with the C<or> or C<and> elements. The C<msg>
element serves two purposes: display a message alerting the user to an unusual condition,
abort a testset in case an exceptional situation is detected.

In order to report an exceptional condition that has been recognized in the test, use
the C<and> element. For example,

  <test label="Part of a long sequence of tests">
    <request url="http://www.test.com/" method="GET"/>
	<response>
	  <status code="200"/>
      <and>
        <content match="regexp">This is exceptional</content>
        <msg action="stop" print="always">
            WARNING: Exceptional condition detected.
            Aborting test set...
        </msg>
      </and>
	</response>
  </test>

If, on the other hand, you want to report the failure of a critical test criterion
that would affect any tests that follow, use the C<or> element. For example,

  <test label="First test in a long set">
    <request url="http://www.test.com/" method="GET"/>
	<response>
	  <status code="200"/>
      <or>
        <content match="regexp">This MUST be found</content>
        <msg action="stop" print="always">
            WARNING: Required content missing.
            Aborting test set...
        </msg>
      </or>
	</response>
  </test>

=head1 The Include Path

B<HTTPtest> will search the include path starting with the paths specified in the B<-I>
command line switch, in the order specified. Next, any paths specified in C<option>
elements in the order they are specified in the test set file. Finally, as a last resort,
the subdirectory I<lib> under the directory from which B<HTTPtest> was run is checked.

=head1 Outstanding Issues

The following are issues still outstanding:

=over 4

=item *

The C<codelib> functionality has not been extensively tested.

=item *

The C<code> functionality has not been extensively tested. In addition,
it's functionality may change slightly in the near future.

=item *

Need to clean up the reporting and logging subsystems.

=item *

I do not like the name of the C<inclusion> element. It is subject to change.

=item *

The B<-f name> command line option which names a file containing the names
of testset files. Need to check handling of params in this case.

=item *

Need to support multiple C<body> tags inside of a C<request>. Also need to check
definition of boundaries and multiple levels of nesting.

=item *

Need to look into other HTTP request methods to verify that the script can support
them and add them to the DTD and input function.

=item *

Once I figure out what a C<session> is, I need to implement it.

=item *

Support for cookie jars is a possibility. I'm just not sure how it
should fit into the test paradigm.

=item *

Need to add functionality similar to C<param> for C<include> elements. This new
child of C<include> would declare replaceable parameters that would be replaced in
the body of the included file. These templatized includes could simplify creation
and maintenance of similar tests.

=item *

I need to add tutorial docs for the use of C<code> and C<codelib>, especially
the new I<id> feature of C<codelib>. 

=back

=head1 Support Web Site

Some level of support for the B<HTTPtest> script can be found at the URL
http://www.anomaly.org/wade/HTTPtest/. This site will also contain the
test scripts and other information.

=cut