File Coverage

blib/lib/WWW/Webrobot.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package WWW::Webrobot;
use strict;
use warnings;

# Author: Stefan Trcek
# Copyright(c) 2004-2006 ABAS Software AG

*VERSION = \'0.81';

use Carp;
use WWW::Webrobot::Properties;
use WWW::Webrobot::SymbolTable;
use WWW::Webrobot::XML2Tree;
use WWW::Webrobot::TestplanRunner;
use WWW::Webrobot::Global;
use WWW::Webrobot::AssertDefault;
use WWW::Webrobot::XHtml;


my %arg_default = (
                   data => {},
                   option => {},
                   assert => WWW::Webrobot::AssertDefault -> new(),
                   description => '',
                   useragent => '',
                   http_header => {},
                   define => {},
                   is_recursive => 0,
                   fail_str => '',
                   fail => -1,
                  );

=head1 NAME

WWW::Webrobot - Run Testplans

=head1 SYNOPSIS

 use WWW::Webrobot;
 WWW::Webrobot -> new($cfg) -> run($test_plan);

configures Webrobot with $cfg, reads a testplan and executes this plan

=head1 DESCRIPTION

Runs a testplan according to a configuration.

=head1 METHODS

=over

=item $wr = WWW::Webrobot -> new( $cfg_name, $cmd_param );

Construct an object.

 $cfg_name
     SCLAR: config string
     REF  : Name of the config file
 $cmd_param
     ??? to be documented

Example:
 $wr = WWW::Webrobot->new(\"configfile.cfg");
 $wr = WWW::Webrobot->new(<
 names=first=value
 names=second=another value
 EOF

=cut

sub new {
    my $class = shift;
    my $self = bless({}, ref($class) || $class);
    my ($cfg_name, $cmd_param) = @_;
    $self->cfg($cfg_name, $cmd_param) if defined $cfg_name;
    return $self;
}


=item $wr -> cfg();

Get the config data.

=item $wr -> cfg($cfg_name, $cmd_properties);

Read in the config data from a file named $cfg.
Add all properties in $cmd_properties.
$cmd_properties is a ref to a list of key/value pairs.

Example:
    $cmd_properties = [[key0, value0], [key1, value1], ...];

Note:
Currently $cfg_name may also be a (internal) hash.
It is needed for webrobot-load but is declared deprecated.

=cut

sub cfg {
    my ($self, $cfg, $cmd_param) = @_;
    confess("config data: hash no more allowed")
        if (ref $cfg eq "HASH"); # formerly allowed, check for unclean updates
    $self->{cfg} = __PACKAGE__->read_configuration($cfg, $cmd_param) if defined $cfg;
    return $self->{cfg};
}


=item $wr -> run($test_plan);

=over

=item $test_plan

Read in the testplan from a file $test_plan and run it.
If $test_plan is SCALAR it is taken as a string,
if $test_plan is a reference it is taken as a file name.

Example:
 $wr->run(\"xml_file.xml");
 $wr->run(<







 EOF

=back


=cut

sub run {
    my $self = shift;
    my ($test_plan_name, $child_id) = @_;
    $child_id ||= 1;
    #my $cfg = $self -> cfg() or die "Missing config definition";

    $test_plan_name = $test_plan_name || $self->cfg->{testplan} or
        die "No testplan defined!";
    WWW::Webrobot::Global->plan_name(ref $test_plan_name ? $$test_plan_name : "__IN_MEMORY__");

    my $sym_tbl = WWW::Webrobot::SymbolTable->new();
    foreach (@{$self->cfg->{names}}) {
        my ($key, $value) = @$_;
        $sym_tbl -> define_symbol($key, $sym_tbl->evaluate($value));
    }
    $sym_tbl -> define_symbol("_id", $child_id);
    my $test_plan = __PACKAGE__->read_testplan($test_plan_name, $sym_tbl);

    $sym_tbl = WWW::Webrobot::SymbolTable->new();
    return WWW::Webrobot::TestplanRunner -> new() -> run($test_plan, $self->cfg, $sym_tbl);
}

sub read_testplan {
    my ($pkg, $test_plan_name, $sym_tbl) = @_;

    my $parser = WWW::Webrobot::XML2Tree->new();
    my $tree =
        (! ref $test_plan_name) ?  $parser -> parse($test_plan_name) :
        (ref $test_plan_name eq 'SCALAR') ? $parser -> parsefile($$test_plan_name) :
        undef;

    # expand all properties
    $sym_tbl->evaluate($tree);

    # convert test plan tree to internal data structure
    my $test_plan = xml2testplan($tree, $sym_tbl);

    # check and normalize 'test_plan'
    die "Can't read file $test_plan_name, err=$?, msg=$@" if $@;
    ref($test_plan) or die "No valid testplan!";
    foreach (@$test_plan) {
        $_ = {%arg_default, %$_};
    }
    return $test_plan;
}

sub assert {
    my ($cond, $text) = @_;
    croak "$text" if !$cond;
}

sub xml2testplan {
    my ($tree, $sym_tbl) = @_;
    my $plan = xml2plan($tree, $sym_tbl);
    return $plan;
}

sub xml2plan {
    my ($tree, $sym_tbl) = @_;
    my $attributes = $tree->[0];
    my $tag = $tree->[1];
    my $content = $tree->[2];
    assert($tag eq "plan", " expected");
    my $plan = xml2planlist($content, $sym_tbl);
    return $plan;
}

sub xml2planlist {
    my ($tree, $sym_tbl) = @_;

    my $plan = [];
    my $attributes = $tree->[0];
    for (my $i = 1; $i < @$tree; $i += 2) {
        my $tag = $tree->[$i];
        my $content = $tree->[$i+1];
        SWITCH: foreach ($tag) {
            ! $_ and do { last }; # skip white space, obsolete?
            /^plan$/ and do {
                my $plan_attributes = $content->[0];
                my $action = $plan_attributes->{action};
                assert(!defined $action || $action eq "shuffle",
                       "action='$action' not allowed, expected [shuffle]");
                my $sub_plan = xml2planlist($content, $sym_tbl);
                fisher_yates_shuffle($sub_plan) if $action eq "shuffle";
                push @$plan, @$sub_plan;
                last;
            };
            /^request$/ and do {
                assert(ref $content eq 'ARRAY', "Test plan request expected");
                push @$plan, request2entry($content);
                last;
            };
            /^include$/ and do {
                my $attr = $content->[0];
                my $fname = $attr->{file};
                my @list = @$content[1 .. @$content-1];
                my $parm = get_data(\@list);
                $sym_tbl->push_scope();
                foreach (keys %$parm) {
                    $sym_tbl->define_symbol($_, $parm->{$_});
                }
                my $iplan = __PACKAGE__->read_testplan(\$fname, $sym_tbl);
                push @$plan, @$iplan;
                $sym_tbl->pop_scope();
                last;
            };
            /^cookies$/ and do {
                for ($content->[0]->{value} || "") {
                    assert(m/^on$/i || m/^off$/i || m/^clear$/i || m/^clear_temporary$/i,,
                           "found '$_', expected one of [on, off, clear, clear_temporary]");
                    push @$plan, {method => "COOKIES", url => "$_"};
                }
                last;
            };
            /^referrer$/ and do {
                for ($content->[0]->{value} || "") {
                    assert(m/^on$/i || m/^off$/i || m/^clear$/i,
                           "found '$_', expected 'on', 'off, 'clear'");
                    push @$plan, {method => "REFERRER", url => "$_"};
                }
                last;
            };
            /^config$/ and do {
                my @mode = ();
                push @mode, ["filename", $content->[0]->{filename} || ""] if $content->[0]->{filename};
                push @mode, ["script"  , $content->[0]->{script  } || ""] if $content->[0]->{script};
                my $cfg = config2entry($content);
                push @$plan, {method => "CONFIG", property => $cfg->{property}, _mode => \@mode, url => ""};
                last;
            };
            /^sleep$/ and do {
                push @$plan, {method => "SLEEP", url => $content->[0]->{value} || 1};
                last;
            };
            /^global-assertion$/ and do {
                my @assert = @$content[1 .. @$content-1];
                my $mode_src = $content->[0]->{mode} || "";
                my $mode = $mode_src || "add";
                assert($mode eq "new" || $mode eq "add", ": found attribute mode='$mode_src', expected 'new', 'add'");
                push @$plan, {method => "GLOBAL-ASSERTION", url => "", mode => $mode, global_assert_xml => \@assert};
                last;
            };
            assert(0, "found <$tag>, expected , , , , , , , ");
        }
    }
    return $plan;
}


sub config2entry { # copied from request2entry, may be subject to be joined
    my ($tree) = @_;

    my %entry = ();

    my $attributes = $tree->[0];
    for (my $i = 1; $i < @$tree; $i += 2) {
        my $tag = $tree->[$i];
        my $content = $tree->[$i+1];

        next if !$tag; # skip white space
        my $attr = $content->[0];
        # ??? obsolete iff CDATA->value
        my @list = @$content[1 .. @$content-1];
        if (@list > 1 && ! $list[0] && ! exists $attr->{value}) {
            $attr->{value} = $list[1];
        }
        SWITCH: foreach ($tag) {
            /^property$/ and do {
                foreach (qw/value/) {
                    if ($attr->{$_}) {
                        push @{$entry{property}}, [$_, $attr->{name}, $attr->{$_}];
                        last;
                    }
                }
                last;
            };
            assert(0, "found <$tag>, expected ");
        }
    }
    return \%entry;
}

sub request2entry {
    my ($tree) = @_;

    my %entry = ();

    my $attributes = $tree->[0];
    for (my $i = 1; $i < @$tree; $i += 2) {
        my $tag = $tree->[$i];
        my $content = $tree->[$i+1];

        next if !$tag; # skip white space
        my $attr = $content->[0];
        # ??? obsolete iff CDATA->value
        my @list = @$content[1 .. @$content-1];
        if (@list > 1 && ! $list[0] && ! exists $attr->{value}) {
            $attr->{value} = $list[1];
        }
        SWITCH: foreach ($tag) {
            /^method$/ and do {
                $entry{method} = trim($attr->{value}) || "GET";
                last;
            };
            /^url$/ and do {
                $entry{url} = trim($attr->{value}) || die "URL required";
                last;
            };
            /^description$/ and do {
                $entry{description} = trim($attr->{value});
                last;
            };
            /^useragent$/ and do {
                $entry{useragent} = trim($attr->{value});
                last;
            };
            /^http-header$/ and do {
                $entry{http_header}->{$attr->{name} || ""} = trim($attr->{value});
                last;
            };
            /^data$/ and do {
                $entry{data} = get_data(\@list);
                last;
            };
            /^assert$/ and do {
                $entry{assert_xml} = \@list;
                last;
            };
            /^recurse$/ and do {
                $entry{recurse_xml} = \@list;
                last;
            };
            /^property$/ and do {
                foreach (qw/value regex xpath header status random/) {
                    if ($attr->{$_}) {
                        push @{$entry{property}}, [$_, $attr->{name}, $attr->{$_}];
                        last;
                    }
                }
                last;
            };
            assert(0, "found <$tag>, expected , , , , , , , ");
        }
    }
    return \%entry;
}

sub get_data {
    my ($list) = @_;
    my %entry = ();

    for (my $i = 0; $i < @$list; $i += 2) {
        my $tag = $list->[$i];
        my $content = $list->[$i+1];

        next if !$tag; # skip white space
        assert($tag eq 'parm', " expected");
        my $attr = $content->[0];
        my $lhs = $attr->{name};
        my $rhs = (defined $attr->{value}) ?  $attr->{value} : ($content->[1] ? "" : trim($content->[2]));
        $entry{$lhs} = $rhs;
    }
    return \%entry;
}

sub trim {
    my ($str) = @_;
    return "" if !defined $str;
    $str =~ s/^\s+//s;
    $str =~ s/\s+$//s;
    return $str;
}


# static
# shuffle an array randomly inplace
sub fisher_yates_shuffle {
    my ($array) = @_;                     # $array is a reference to an array
    my $last = @$array;
    while ($last--) {
        my $k = int rand ($last+1);
        @$array[$last, $k] = @$array[$k, $last];
    }
}


# static
sub read_configuration {
    my ($package, $cfg_name, $cmd_param) = @_;
    die "Missing config definition" if !$cfg_name;

    # read config file in 'properties' format
    my $config = WWW::Webrobot::Properties->new(
        listmode    => [qw(names auth_basic output http_header proxy no_proxy mail.Attach)],
        key_value   => [qw(names http_header proxy)],
        multi_value => [qw(auth_basic mail.Attach)],
        structurize => [qw(load mail)],
    );
    my $cfg = $config->load($cfg_name, $cmd_param);

    # adjust property 'output' to internal data structure
    $cfg->{output} = [ $cfg->{output} ] if ref($cfg->{output}) ne "ARRAY";
    my $output = $cfg->{output};
    foreach (@$output) {
        my ($class, $rest) = split /\s+/, $_, 2;
        eval "require $class;";
        die "Can't find class='$class', $@" if $@;
        $rest ||= "";
        my @parm = eval("( $rest )");
        die "Invalid parameter list: $@" if $@;
        $_ = $class -> new(@parm);
    }

    # adjust property 'auth_basic' to internal data structure
    my %intern_realm = ();
    foreach (@{$cfg->{auth_basic}}) {
        my ($id, $login, $passwd) = @$_;
        $intern_realm{$id} = [$login, $passwd];
    }
    $cfg->{auth_basic} = \%intern_realm;

    # adjust 'http_header'
    $cfg->{http_header} = array2hash($cfg->{http_header});

    # adjust 'proxy'
    $cfg->{proxy} = array2hash($cfg->{proxy});

    # adjust 'names'
    #$cfg->{names} = array2hash($cfg->{names});

    # normalize 'load'
    $cfg->{load}->{number_of_clients} ||= 1 if defined $cfg->{load};

    return $cfg;
}


sub array2hash {
    my ($http_header) = @_;
    my %hash = ();
    foreach (@$http_header) {
        my ($key, $value) = @$_;
        $hash{$key} = $value;
    }
    return \%hash;
}

=back

=head1 SEE ALSO

L

L

=cut

1;