File Coverage

blib/lib/WWW/Webrobot/SelftestRunner.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package WWW::Webrobot::SelftestRunner;

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

use Exporter;
@EXPORT_OK = qw/ RunTestplan RunTestplan2 HttpdEcho Config /;

use strict;
use warnings;

use HTTP::Response;
use HTTP::Headers;
use URI;

use WWW::Webrobot;
use WWW::Webrobot::StupidHTTPD;


=head1 NAME

WWW::Webrobot::SelftestRunner - Start httpd and run a test plan

=head1 SYNOPSIS

 use WWW::Webrobot::SelftestRunner qw/RunTestplan HttpdEcho Config/;
 exit RunTestplan(HttpdEcho, Config(qw/Test/, $test_plan);

 exit RunTestplan(HttpdEcho, Config(qw/Test Html/, $test_plan);

see also t/get.t


=head1 DESCRIPTION

This package serves some functions to start a http daemon
and run a test plan.
It is only used for the test in the C directory.


=head1 FUNCTIONS

=over

=item RunTestplan($serverfunc, $config, $testplan)

Run a C http daemon implementing C<$serverfunc>.
Then run a C http client using the configuration C<$config>
and the testplan C<$testplan>.

=cut

sub RunTestplan {
    my ($exit, $webrobot) = RunTestplan2(@_);
    return $exit;
}

sub RunTestplan2 {
    my ($server_func, $config, $test_plan) = @_;

    my $daemon = WWW::Webrobot::StupidHTTPD -> new();
    $daemon -> start($server_func, fork_daemon => 1);

    $config .= "names=application=" . $daemon -> server_url() . "\n";
    my $webrobot = WWW::Webrobot -> new($config);
    my $exit = $webrobot -> run($test_plan);

    $daemon -> stop();

    return ($exit, $webrobot);
}


my $simple_html_text_0 = <<'EOF';


        A_Static_Html_Page


        A simple text.


EOF

my $simple_html_text_1 = <<'EOF';


        Confuse perl regular expressions: [a-z]
        HTMLish text


EOF

my $frame_0 = <<'EOF';




    Your browser does not support frames.


EOF

my $ACTION = {
    # NOTE: depending on the key the HTTP response will be
    # text/html or text/plain
    url => sub {
        my ($connection, $request) = @_;
        $request -> uri();
    },
    content => sub {
        my ($connection, $request) = @_;
        $request -> content();
    },
    method => sub {
        my ($connection, $request) = @_;
        $request -> method();
    },
    headers => sub {
        my ($connection, $request) = @_;
        $request -> headers() -> as_string();
    },
    constant_html_0 => sub {
        my ($connection, $request) = @_;
        return $simple_html_text_0;
    },
    constant_html_1 => sub {
        my ($connection, $request) = @_;
        return $simple_html_text_1;
    },
    html_frame_0 => sub {
        my ($connection, $request) = @_;
        return $frame_0;
    },
    html_as_utf8 => sub {
        my ($connection, $request) = @_;
        my $path = $request->uri();
        my $file = $path || "";
        $file =~ s{^/*html_as_utf8/(.*)$}{$1};
        local *F;
        open F, "<$file" or die "Can't open '$file': $!";
        my $html = do { local $/;  };
        close F;
        return $html;
    },
    # 500 => sub {},
    # Don't use '500' as a key: some tests rely that this key doesn't exist!
};

=item HttpdEcho

A simple server function for the C http daemon.
It read the requested url C
as an action where the action is denoted by the C part within the url.
The result of the action is returned as content in the response.
Actions are

 url           echo the url as response content
 content       echo the content in the request as response content
 method        echo the method in the request as response content
 headers       echo a stringified form of the request headers as response content

=cut

sub HttpdEcho {
    my %parm = (@_);
    my $charset = $parm{charset} ? "; charset=" . $parm{charset} : "";
    my $plain_header = HTTP::Headers -> new(Content_Type => "text/plain$charset");
    my $html_header = HTTP::Headers -> new(Content_Type => "text/html$charset");
    return sub {
        my ($connection, $request) = @_;

        my $path = $request->uri();
        my $action = $path || "";
        $action =~ s{^/*([^/]+).*$}{$1};
        $action = "" if ! exists $ACTION->{$action};

        my $response = (exists $ACTION->{$action}) ?
            HTTP::Response -> new(
                200,
                undef,
                ($action =~ /html/) ? $html_header : $plain_header,
                $ACTION->{$action}->($connection, $request)
            ) : HTTP::Response -> new(500, undef, $plain_header, undef);
        $connection -> send_response($response);
    };
};


=item Config(Modulenames...)

Simple config string for C output.
Defaults to "Test" if no parameter is given.

Example:

 my $cfg = Config(qw/Html Test/);
 my $cfg = Config;

=cut

sub Config {
    push @_, "Test" if ! @_;
    return join "", map {"output=WWW::Webrobot::Print::$_\n"} @_;
}


=pod

=back

=cut

1;