[libcgi-test-perl] 16/24: All tests pass in Windows and Unix-like systems
Axel Beckert
abe at deuxchevaux.org
Mon Jan 11 00:38:08 UTC 2016
This is an automated email from the git hooks/post-receive script.
abe pushed a commit to annotated tag 0.50
in repository libcgi-test-perl.
commit 34c7930e303e23470df3c492e1216537aa7fee0d
Author: Alex Tokarev <nohuhu at nohuhu.org>
Date: Thu Sep 4 22:45:19 2014 -0700
All tests pass in Windows and Unix-like systems
---
lib/CGI/Test.pm | 14 ++++-----
t/01_env.t | 10 +++++++
t/02_parsing.t | 6 +++-
t/03_get.t | 4 +++
t/04_post.t | 83 +++++++++++++++++++----------------------------------
t/lib/browse.pm | 88 ++++++++++++++++++++++++++++++++-------------------------
t/pod.t | 12 ++++++--
7 files changed, 111 insertions(+), 106 deletions(-)
diff --git a/lib/CGI/Test.pm b/lib/CGI/Test.pm
index 378db7a..5c6bef9 100644
--- a/lib/CGI/Test.pm
+++ b/lib/CGI/Test.pm
@@ -319,8 +319,6 @@ sub _cgi_request
substr($upath, 0, length $base_path) = '';
-# logdbg 'info', "uri $uri -> script+path $upath";
-
#
# We have script + path_info in the $upath variable. To determine where
# the path_info starts, we have to walk through the components and
@@ -350,8 +348,6 @@ sub _cgi_request
my $script_name = $base_path . join("/", @script); # Virtual
my $path = "/" . join("/", @components); # Virtual
-# logdbg 'info', "script=$script, path=$path";
-
return $error->new(RC_NOT_FOUND, $this) unless -f $script;
return $error->new(RC_UNAUTHORIZED, $this) unless -x $script;
@@ -367,7 +363,7 @@ sub _cgi_request
if (defined $input) {
# In Windows, we use temp files instead of pipes to avoid
- # duplication errors
+ # stream duplication errors
if ( WINDOWS ) {
($in_fh, $in_fname) =
mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_in.XXXXXX"));
@@ -423,7 +419,7 @@ sub _cgi_request
#
if ($pid == 0) {
- close PWRITE if defined $input; # Writing side of the pipe
+ close PWRITE if defined $input && !WINDOWS; # Writing side of the pipe
$this->_run_cgi(
-script_file => $script, # Real path
@@ -445,7 +441,7 @@ sub _cgi_request
close $out_fh unless WINDOWS;
- if (defined $input)
+ if (defined $input && !WINDOWS)
{ # Send POST input data
close PREAD;
syswrite PWRITE, $input->data, $input->length;
@@ -599,7 +595,7 @@ sub _run_cgi
# which are very request-specific:
#
- $ENV{REQUEST_METHOD} = defined $in ? "POST" : "GET";
+ $ENV{REQUEST_METHOD} = defined $input ? "POST" : "GET";
$ENV{PATH_INFO} = $path;
$ENV{SCRIPT_NAME} = $name;
$ENV{SCRIPT_FILENAME} = $script;
@@ -664,7 +660,7 @@ sub _run_cgi
if ( WINDOWS ) {
my $cmd_line = $input ? "$basename < ${in_fname} > ${out_fname}"
- : "$basename >${out_fname}"
+ : "$basename < NUL >${out_fname}"
;
exec $cmd_line;
diff --git a/t/01_env.t b/t/01_env.t
index 0e856f7..7b49cd0 100644
--- a/t/01_env.t
+++ b/t/01_env.t
@@ -1,9 +1,19 @@
+use Config;
use Test::More tests => 16;
use CGI::Test;
use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
+#
+# This is a workaround for a nasty Fcntl loading problem: it seems that
+# certain custom Perl builds fail to allocate some kind of resources, or
+# just try to load wrong shared objects. This results in tests
+# failing miserably; considering that custom builds are very common
+# among CPAN testers, this could be considered a serious problem.
+#
+$ENV{PATH} = $Config{bin} . ':' . $ENV{PATH};
+
my $SERVER = "some-server";
my $PORT = 18;
my $BASE = "http://${SERVER}:${PORT}/cgi-bin";
diff --git a/t/02_parsing.t b/t/02_parsing.t
index 969a8a6..cc394fb 100644
--- a/t/02_parsing.t
+++ b/t/02_parsing.t
@@ -1,10 +1,14 @@
+use Config;
+use URI;
+
use Test::More tests => 44;
use CGI::Test;
-use URI;
use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
+$ENV{PATH} = $Config{bin} . ':' . $ENV{PATH};
+
my $BASE = "http://server:18/cgi-bin";
my $SCRIPT = WINDOWS ? "getform.bat" : "getform";
diff --git a/t/03_get.t b/t/03_get.t
index b95c903..ddd4a70 100644
--- a/t/03_get.t
+++ b/t/03_get.t
@@ -1,9 +1,13 @@
+use Config;
+
use Test::More tests => 14;
use CGI::Test;
use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
+$ENV{PATH} = $Config{bin} . ':' . $ENV{PATH};
+
my $BASE = "http://server:18/cgi-bin";
my $SCRIPT = WINDOWS ? "getform.bat" : "getform";
diff --git a/t/04_post.t b/t/04_post.t
index 02a19e2..c77f322 100644
--- a/t/04_post.t
+++ b/t/04_post.t
@@ -1,81 +1,56 @@
-#
-# $Id: post.t,v 1.2 2003/09/29 11:00:51 mshiltonj Exp $
-#
-# Copyright (c) 2001, Raphael Manfredi
-#
-# You may redistribute only under the terms of the Artistic License,
-# as specified in the README file that comes with the distribution.
-#
-# HISTORY
-# $Log: post.t,v $
-# Revision 1.2 2003/09/29 11:00:51 mshiltonj
-# CGI::Test has changed ownership. The new owner is Steven Hilton
-# <mshiltonj at mshiltonj.com>. Many thanks to Raphael Manfredi
-# and Steve Fink.
-#
-# CGI::Test is now hosted as a SourceForge project. It is located
-# at <http://cgi-test.sourceforge.net>.
-#
-# POD updated to reflect the above.
-#
-# make() method on various objects has been deprecated, and has been
-# replaced by more conventional (for me, at least) new() method.
-# Support for make() may be removed in a later release.
-#
-# Entire codebase reformatted using perltidy
-# Go to <http://perltidy.sourceforge.net/> to see how neat it is.
-#
-# Self-referential object variable name standardized to '$this'
-# throughout code.
-#
-# Revision 1.1.1.1 2003/09/23 09:47:26 mshiltonj
-# Initial Import
-#
-# Revision 0.1 2001/03/31 10:54:04 ram
-# Baseline for first Alpha release.
-#
-# $EndLog$
-#
+use Config;
+
+use Test::More tests => 14;
use CGI::Test;
-print "1..13\n";
+use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
+
+$ENV{PATH} = $Config{bin} . ':' . $ENV{PATH};
my $BASE = "http://server:18/cgi-bin";
+my $SCRIPT = WINDOWS ? 'getform.bat' : 'getform';
my $ct = CGI::Test->new(
-base_url => $BASE,
-cgi_dir => "t/cgi",
);
-ok 1, defined $ct;
+ok defined $ct, "Got CGI::Test object";
+isa_ok $ct, 'CGI::Test', 'isa';
+
+my $page = $ct->GET("$BASE/$SCRIPT?method=POST&enctype=M");
-my $page = $ct->GET("$BASE/getform?method=POST&enctype=M");
-ok 2, !$page->is_error;
+ok $page->is_ok, "Page 1 OK";
+ok !$page->is_error, "Page 1 error code " . $page->error_code;
my $form = $page->forms->[0];
-ok 3, $form->method eq "POST";
+
+is $form->method, "POST", "Page 1 form method";
+
my @submit = $form->submits_named("Send");
-ok 4, @submit == 1;
+
+is @submit, 1, "Page 1 number of Send submits";
my $months = $form->widget_by_name("months");
$months->select("Jan");
my $send = $form->submit_by_name("Send");
my $page2 = $send->press;
-ok 5, !$page2->is_error;
-ok 6, !$page2->is_error;
-ok 7, $page2->form_count == 1;
-my $form2 = $page2->forms->[0];
+ok !$page2->is_error, "Page 2 error code " . $page2->error_code;
+is $page2->form_count, 1, "Page 2 form count";
+my $form2 = $page2->forms->[0];
@submit = $form2->submits_named("Send");
-ok 8, @submit == 1;
-ok 9, $form2->method eq "POST";
-ok 10, $form2->enctype =~ /^multipart/;
+
+is @submit, 1, "Page 2 number of Send submits";
+is $form2->method, 'POST', "Form 2 method";
+like $form2->enctype, qr/multipart/, "Form 2 encoding";
my $months2 = $form2->widget_by_name("months");
-ok 11, $months2->is_selected("Jul");
-ok 12, $months2->is_selected("Jan");
-ok 13, !$months2->is_selected("Feb");
+
+ok $months2->is_selected("Jul"), "Form 2 Jul is selected";
+ok $months2->is_selected("Jan"), "Form 2 Jan is selected";
+ok !$months2->is_selected("Feb"), "Form 2 Feb is not selected";
diff --git a/t/lib/browse.pm b/t/lib/browse.pm
index ee3431d..dbfa7bf 100644
--- a/t/lib/browse.pm
+++ b/t/lib/browse.pm
@@ -1,15 +1,18 @@
package browse;
+use Config;
+use Test::More;
+
use CGI::Test;
-use Config;
+use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ };
#
-# This is a fix for nasty Fcntl loading problem: it seems that
-# custom-built Perl fails to allocate some kind of resources, or
-# just tries to load wrong shared object. This results in tests
+# This is a workaround for a nasty Fcntl loading problem: it seems that
+# certain custom Perl builds fail to allocate some kind of resources, or
+# just try to load wrong shared objects. This results in tests
# failing miserably; considering that custom builds are very common
-# among CPAN testers, it is a serious problem.
+# among CPAN testers, this could be considered a serious problem.
#
$ENV{PATH} = $Config{bin} . ':' . $ENV{PATH};
@@ -19,41 +22,47 @@ sub browse {
my $method = $params{method};
my $enctype = $params{enctype};
- print "1..27\n";
+ plan tests => 27;
my $BASE = "http://server:18/cgi-bin";
+ my $SCRIPT = WINDOWS ? 'getform.bat' : 'getform';
+ my $ACTION = WINDOWS ? 'dumpargs.bat' : 'dumpargs';
+
my $ct = CGI::Test->new(
-base_url => $BASE,
-cgi_dir => "t/cgi",
);
- my $query = "action=/cgi-bin/dumpargs";
+ my $query = "action=/cgi-bin/$ACTION";
$query .= "&method=$method" if defined $method;
$query .= "&enctype=$enctype" if defined $enctype;
- my $page = $ct->GET("$BASE/getform?$query");
+ my $page = $ct->GET("$BASE/$SCRIPT?$query");
my $form = $page->forms->[0];
- ok 1, $form->action eq "/cgi-bin/dumpargs";
+ is $form->action, "/cgi-bin/$ACTION", "Action: " . $form->action;
my $submit = $form->submit_by_name("Send");
- ok 2, defined $submit;
+
+ ok defined $submit, "Send submit defined";
my $page2 = $submit->press;
- ok 3, $page2->is_ok;
+
+ ok $page2->is_ok, "Page 2 OK";
my $args = parse_args($page2->raw_content);
- ok 4, $args->{counter} == 1;
- ok 5, $args->{title} eq "Mr";
- ok 6, $args->{name} eq "";
- ok 7, $args->{skills} eq "listening";
- ok 8, $args->{new} eq "ON";
- ok 9, $args->{color} eq "white";
- ok 10, $args->{note} eq "";
- ok 11, $args->{months} eq "Jul";
- ok 12, $args->{passwd} eq "";
- ok 13, $args->{Send} eq "Send";
- ok 14, $args->{portrait} eq "";
+
+ is $args->{counter}, 1, "Page 2 counter";
+ is $args->{title}, "Mr", "Page 2 title";
+ is $args->{name}, "", "Page 2 name";
+ is $args->{skills}, "listening", "Page 2 skills";
+ is $args->{new}, "ON", "Page 2 new";
+ is $args->{color}, "white", "Page 2 color";
+ is $args->{note}, "", "Page 2 note";
+ is $args->{months}, "Jul", "Page 2 months";
+ is $args->{passwd}, "", "Page 2 passwd";
+ is $args->{Send}, "Send", "Page 2 send";
+ is $args->{portrait}, "", "Page 2 portrait";
my $r = $form->radio_by_name("title");
$r->check_tagged("Miss");
@@ -81,26 +90,27 @@ sub browse {
$t = $form->input_by_name("note");
$t->replace("this\nis\nsome\ntext");
- $page2 = $submit->press;
- my $args2 = parse_args($page2->raw_content);
-
- ok 15, $args2->{counter} == 1;
- ok 16, $args2->{title} eq "Miss";
- ok 17, $args2->{name} eq "";
- ok 18, $args2->{skills} eq "listening";
- ok 19, !exists $args2->{new}; # unchecked, not submitted
- ok 20, $args2->{color} eq "red";
- ok 21, $args2->{note} eq "this is some text";
- ok 22, join(" ", sort split(' ', $args2->{months})) eq "Feb Jan";
- ok 23, $args2->{passwd} eq "foobar";
- ok 24, $args2->{Send} eq "Send";
- ok 25, $args2->{portrait} eq "this is it, disappointed?";
+ my $page3 = $submit->press;
+ my $args3 = parse_args($page3->raw_content);
+
+ is $args3->{counter}, 1, "Page 3 counter";
+ is $args3->{title}, "Miss", "Page 3 title";
+ is $args3->{name}, "", "Page 3 name";
+ is $args3->{skills}, "listening", "Page 3 skills";
+ ok !exists $args3->{new}, "Page 3 new"; # unchecked, not submitted
+ is $args3->{color}, "red", "Page 3 color";
+ is $args3->{note}, "this is some text", "Page 3 note";
+ is join(" ", sort split(' ', $args3->{months})), "Feb Jan", "Page 3 months";
+ is $args3->{passwd}, "foobar", "Page 3 passwd";
+ is $args3->{Send}, "Send", "Page 3 send";
+ is $args3->{portrait}, "this is it, disappointed?", "Page 3 portrait";
# Ensure we tested what was requested
$method = "GET" unless defined $method;
- ok 26, $form->method eq $method;
- ok 27, substr($form->enctype, 0, 5) eq
- (defined $enctype ? "multi" : "appli");
+ my $enctype_qr = defined $enctype ? qr/multipart/ : qr/urlencoded/;
+
+ is $form->method, $method, "Form method";
+ like $form->enctype, $enctype_qr, "Form encoding";
}
# Rebuild parameter list from the output of dumpargs into a HASH
diff --git a/t/pod.t b/t/pod.t
index e5ac2c6..6abe690 100644
--- a/t/pod.t
+++ b/t/pod.t
@@ -1,6 +1,12 @@
use Test::More;
-eval "use Test::Pod 1.00";
-plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+if ( $ENV{POD_TESTS} ) {
+ eval "use Test::Pod 1.00";
+ plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+
+ all_pod_files_ok();
+}
+else {
+ plan skip_all => 'POD tests are not enabled.';
+}
-all_pod_files_ok();
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcgi-test-perl.git
More information about the Pkg-perl-cvs-commits
mailing list