|
From: Ilya M. <m_...@us...> - 2002-12-12 21:43:23
|
Update of /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest
In directory sc8-pr-cvs1:/tmp/cvs-serv19282/lib/HTTP/WebTest
Modified Files:
SelfTest.pm
Log Message:
Move self-test suite support code into module HTTP::WebTest::SelfTest
to allow reusing it in self-test suites for plugins maintained outside
of HTTP-WebTest
Index: SelfTest.pm
===================================================================
RCS file: /cvsroot/http-webtest/HTTP-WebTest/lib/HTTP/WebTest/SelfTest.pm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** SelfTest.pm 18 Nov 2002 07:45:36 -0000 1.1
--- SelfTest.pm 12 Dec 2002 21:43:12 -0000 1.2
***************
*** 32,38 ****
use vars qw(@EXPORT $HOSTNAME $PORT $URL);
! @EXPORT = qw($HOSTNAME $PORT $URL);
use Sys::Hostname;
use URI;
--- 32,48 ----
use vars qw(@EXPORT $HOSTNAME $PORT $URL);
! @EXPORT = qw($HOSTNAME $PORT $URL
! abs_url
! check_webtest
! read_file write_file
! generate_testfile canonical_output compare_output
! parse_basic_credentials
! start_webserver stop_webserver);
+ use Algorithm::Diff qw(diff);
+ use MIME::Base64;
+ use POSIX qw(SIGTERM);
use Sys::Hostname;
+ use Test;
use URI;
***************
*** 181,184 ****
--- 191,474 ----
=cut
+
+ sub check_webtest {
+ my %param = @_;
+
+ my $webtest = $param{webtest};
+ my $tests = $param{tests};
+ my $opts = $param{opts} || {};
+
+ my $output = '';
+
+ $webtest->run_tests($tests, { %$opts, output_ref => \$output });
+ canonical_output(%param, output_ref => \$output);
+ compare_output(%param, output_ref => \$output);
+ }
+
+ =head2 generate_testfile(%params)
+
+ Generates test file from template file. I.e. it replaces substring
+ '<<SERVER_URL>>' with value of named parameter C<server_url>.
+
+ =head3 Parameters
+
+ =over 4
+
+ =item file => $file
+
+ Filename of test file. Template file is expected to be in file named
+ "$file.in".
+
+ =item server_url => $server_url
+
+ Test webserver URL.
+
+ =back
+
+ =cut
+
+ sub generate_testfile {
+ my %param = @_;
+
+ my $file = $param{file};
+ my $in_file = $file . '.in';
+
+ # prepare wt script file
+ my $data = read_file($in_file);
+ $data =~ s/<<SERVER_URL>>/$param{server_url}/g;
+
+ $data = <<WARNING . $data;
+ # Note: $file is autogenerated from $in_file. DO NOT EDIT $file.
+ # Your changes will be lost. Edit $in_file instead.
+
+ WARNING
+
+ write_file($file, $data);
+ }
+
+ =head2 canonical_output(%params)
+
+ Some substrings in test output are unique for each test run. This
+ subroutine "fixes" test output so it becomes repeatable (unless tests
+ get broken).
+
+ =head3 Parameters
+
+ =over 4
+
+ =item output_ref => $output_ref
+
+ A reference on scalar which contains test output as whole string.
+
+ =item out_filter => $out_filter
+
+ An optional reference on subroutine which can be used as additional
+ filter. It gets passed test output as its first parameter.
+
+ =item server_url => $server_url
+
+ Test webserver URL. Normally it is unique for each test run so it gets
+ replaced with C<http://http.web.test/>.
+
+ =item server_hostname => $server_hostname
+
+ Test webserver URL. Normally it is unique for each machine where test
+ is run so it gets replaced with C<http.web.test>.
+
+ =back
+
+ =cut
+
+ sub canonical_output {
+ my %param = @_;
+
+ my $output_ref = $param{output_ref};
+ my $out_filter = $param{out_filter};
+ my $server_url = $param{server_url};
+ my $server_hostname = $param{server_hostname};
+
+ # run test filter if defined
+ if(defined $out_filter) {
+ $out_filter->($$output_ref);
+ }
+
+ # change urls on some canonical in test output
+ if(defined $server_url) {
+ my $url = abs_url($server_url, '/')->as_string;
+ $$output_ref =~ s|\Q$url\E
+ |http://http.web.test/|xg;
+ }
+
+ # change urls on some canonical in test output
+ if(defined $server_hostname) {
+ $$output_ref =~ s|http://\Q$server_hostname\E:\d+/
+ |http://http.web.test/|xg;
+ }
+ }
+
+ =head2 compare_output(%params)
+
+ Tests if a test output matches content of specified reference file. If
+ environment variable C<TEST_FIX> is set then the test is always
+ succeed and the content of the reference file is overwritten with
+ current test output.
+
+ =head3 Parameters
+
+ =over 4
+
+ =item output_ref => $output_ref
+
+ A reference on scalar which contains test output as whole string.
+
+ =item check_file => $check_file
+
+ Filename of the reference file.
+
+ =back
+
+ =cut
+
+ sub compare_output {
+ my %param = @_;
+
+ my $check_file = $param{check_file};
+ my $output2 = ${$param{output_ref}};
+
+ my $output1 = read_file($check_file, 1);
+ _print_diff($output1, $output2);
+ ok(($output1 eq $output2) or defined $ENV{TEST_FIX});
+
+ if(defined $ENV{TEST_FIX} and $output1 ne $output2) {
+ # special mode for writting test report output files
+
+ write_file($check_file, $output2);
+ }
+ }
+
+ # print diff of outputs
+ sub _print_diff {
+ my $output1 = shift;
+ my $output2 = shift;
+
+ my @diff = diff([split /\n/, $output1], [split /\n/, $output2]);
+
+ for my $hunk (@diff) {
+ for my $diff_str (@$hunk) {
+ print "@$diff_str\n";
+ }
+ }
+ }
+
+ =head2 start_webserver(%params)
+
+ Starts separate process with a test webserver.
+
+ =head3 Parameters
+
+ =over 4
+
+ =item port => $port
+
+ A port number where the test webserver listens for incoming connections.
+
+ =item server_sub => $server_sub
+
+ A reference on a subroutine to handle requests. It get passed two
+ named parameters: C<connect> and C<request>.
+
+ =back
+
+ =cut
+
+ sub start_webserver {
+ my %param = @_;
+
+ # try to start server
+ my $daemon = HTTP::Daemon->new(LocalPort => $param{port}, ReuseAddr => 1)
+ or die;
+
+ # fork server to separate process
+ my $pid = fork;
+ die unless defined $pid;
+ return $pid if $pid != 0;
+
+ # when we are run under debugger do not stop and call debugger at
+ # the exit of the forked process. This helps to workaround problem
+ # when forked process tries to takeover and to screw the terminal
+ $DB::inhibit_exit = 0;
+
+ # set 'we are working' flag
+ my $done = 0;
+
+ # exit on SIGTERM
+ $SIG{TERM} = sub { $done = 1 };
+ # handle closed connection
+ $SIG{PIPE} = 'IGNORE';
+
+ # handle requests untill we are killed
+ eval {
+ until($done) {
+ # wait one tenth of second for connection
+ my $rbits = '';
+ vec($rbits, $daemon->fileno, 1) = 1;
+ my $nfound = select $rbits, '', '', 0.1;
+
+ # if we have connection then handle it
+ if($nfound > 0) {
+ my $connect = $daemon->accept;
+ die unless defined $connect;
+
+ while (my $request = $connect->get_request) {
+ $param{server_sub}->(connect => $connect,
+ request => $request);
+ }
+ $connect->close;
+ undef $connect;
+ }
+ }
+ };
+ # in any case try to shutdown daemon correctly
+ $daemon->close;
+ if($@) { die $@ };
+
+ exit 0;
+ }
+
+ =head2 stop_webserver($pid)
+
+ Kills a test webserver specified by its PID.
+
+ =cut
+
+ sub stop_webserver {
+ my $pid = shift;
+
+ return kill SIGTERM, $pid;
+ }
+
+ =head2 parse_basic_credentials($credentials)
+
+ Decodes credentials for Basic authorization scheme according RFC2617.
+
+ =head3 Returns
+
+ Returns user/password pair.
+
+ =cut
+
+ sub parse_basic_credentials {
+ my $credentials = shift;
+
+ return () unless defined $credentials;
+ $credentials =~ m|^ \s* Basic \s+ ([A-Za-z0-9+/=]+) \s* $|x;
+ my $basic_credentials = $1;
+ return () unless defined $basic_credentials;
+ my $user_pass = decode_base64($basic_credentials);
+ my($user, $password) = $user_pass =~ /^ (.*) : (.*) $/x;
+ return () unless defined $password;
+
+ return ($user, $password);
+ }
=head1 COPYRIGHT
|
