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 4299c363a40f97cbdf6b6fe9c598041fb40ccf16
Author: Alex Tokarev <noh...@nohuhu.org>
Date: Wed Aug 27 23:00:29 2014 -0700
First stab at Windows compatibility
---
lib/CGI/Test.pm | 156 +++++++++++++++++++++---------------
t/01_env.t | 76 ++++++++++++++++++
t/{parsing.t => 02_parsing.t} | 0
t/{get.t => 03_get.t} | 0
t/{post.t => 04_post.t} | 0
t/{play_get.t => 05_play_get.t} | 0
t/{play_post.t => 06_play_post.t} | 0
t/{play_multi.t => 07_play_multi.t} | 0
t/env.t | 108 -------------------------
9 files changed, 168 insertions(+), 172 deletions(-)
diff --git a/lib/CGI/Test.pm b/lib/CGI/Test.pm
index 73cf6c7..50e862f 100644
--- a/lib/CGI/Test.pm
+++ b/lib/CGI/Test.pm
@@ -10,7 +10,7 @@ package CGI::Test;
use strict;
use warnings;
-no warnings 'uninitialized';
+#no warnings 'uninitialized';
use Carp;
use HTTP::Status;
@@ -20,13 +20,11 @@ use File::Spec;
use File::Basename;
use Cwd qw(abs_path);
+use vars qw($VERSION);
-require Exporter;
-use vars qw($VERSION @ISA @EXPORT);
+$VERSION = '0.50';
-$VERSION = '0.32';
-@ISA = qw(Exporter);
-@EXPORT = qw(ok);
+use constant WINDOWS => eval { $^O =~ /win/i };
#############################################################################
#
@@ -364,16 +362,37 @@ sub _cgi_request
my @post = ();
local $SIG{PIPE} = 'IGNORE';
local (*PREAD, *PWRITE);
- if (defined $input)
- {
- unless (pipe(PREAD, PWRITE))
- {
- warn "can't open pipe: $!";
- return $error->new(RC_INTERNAL_SERVER_ERROR, $this);
+
+ my ($in_fh, $out_fh, $in_fname, $out_fname);
+
+ if (defined $input) {
+ # In Windows, we use temp files instead of pipes to avoid
+ # duplication errors
+ if ( WINDOWS ) {
+ ($in_fh, $in_fname) =
+ mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_in.XXXXXX"));
+
+ binmode $in_fh;
+
+ syswrite $in_fh, $input->data, $input->length;
+ close $in_fh;
+
+ @post = (
+ -in_fname => $in_fname,
+ -input => $input,
+ );
}
+ else {
+ if ( not pipe(PREAD, PWRITE) ) {
+ warn "can't open pipe: $!";
+ return $error->new(RC_INTERNAL_SERVER_ERROR, $this);
+ }
- @post = (-in => \*PREAD,
- -input => $input,);
+ @post = (
+ -in => \*PREAD,
+ -input => $input,
+ );
+ }
}
#
@@ -381,8 +400,10 @@ sub _cgi_request
# the script is done.
#
- my ($fh, $fname) =
+ ($out_fh, $out_fname) =
mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_out.XXXXXX"));
+
+ close $out_fh if WINDOWS;
select((select(STDOUT), $| = 1)[ 0 ]);
print STDOUT ""; # Flush STDOUT before forking
@@ -397,21 +418,24 @@ sub _cgi_request
#
# Child will run the CGI program with no input if it's a GET and
# output stored to $fh. When issuing a POST, data will be provided
- # by the parent through a pipe.
+ # by the parent through a pipe in Unixy systems, or through a temp file
+ # in Windows.
#
- if ($pid == 0)
- {
+ if ($pid == 0) {
close PWRITE if defined $input; # Writing side of the pipe
+
$this->_run_cgi(
-script_file => $script, # Real path
-script_name => $script_name, # Virtual path, given in URI
-user => $user,
- -out => $fh,
+ -out => $out_fh,
+ -out_fname => $out_fname,
-uri => $u,
-path_info => $path,
@post, # Additional params for POST
- );
+ );
+
confess "not reachable!";
}
@@ -419,7 +443,8 @@ sub _cgi_request
# Parent process
#
- close $fh;
+ close $out_fh unless WINDOWS;
+
if (defined $input)
{ # Send POST input data
close PREAD;
@@ -433,7 +458,8 @@ sub _cgi_request
{
warn "waitpid returned with pid=$child, but expected pid=$pid";
kill 'TERM', $pid or warn "can't SIGTERM pid $pid: $!";
- unlink $fname or warn "can't unlink $fname: $!";
+ unlink $in_fname or warn "can't unlink $in_fname: $!";
+ unlink $out_fname or warn "can't unlink $out_fname: $!";
return $error->new(RC_NO_CONTENT, $this);
}
@@ -441,11 +467,12 @@ sub _cgi_request
# Get header within generated response, and determine Content-Type.
#
- my $header = $this->_parse_header($fname);
+ my $header = $this->_parse_header($out_fname);
unless (scalar keys %$header)
{
warn "script $script_name generated no valid headers";
- unlink $fname or warn "can't unlink $fname: $!";
+ unlink $in_fname or warn "can't unlink $in_fname: $!";
+ unlink $out_fname or warn "can't unlink $out_fname: $!";
return $error->new(RC_INTERNAL_SERVER_ERROR, $this);
}
@@ -453,7 +480,7 @@ sub _cgi_request
# Return error page if we got 5xx status
#
- if ( my ($status) = $header->{Status} =~ /^(5\d\d)/ ) {
+ if ( my ($status) = ($header->{Status} || '') =~ /^(5\d\d)/ ) {
return $error->new($status, $this);
}
@@ -478,13 +505,17 @@ sub _cgi_request
my $page = $objtype->new(
-server => $this,
- -file => $fname,
+ -file => $out_fname,
-content_type => $type, # raw type, with parameters
-user => $user,
-uri => $u,
);
-
- unlink $fname or warn "can't unlink $fname: $!";
+
+ if ($in_fname) {
+ unlink $in_fname or warn "can't unlink $in_fname: $!";
+ }
+
+ unlink $out_fname or warn "can't unlink $out_fname: $!";
return $page;
}
@@ -510,29 +541,33 @@ sub _run_cgi
my %params = @_;
- my $script = $params{-script_file};
- my $name = $params{-script_name};
- my $user = $params{-user};
- my $in = $params{-in};
- my $out = $params{-out};
- my $u = $params{-uri};
- my $path = $params{-path_info};
- my $input = $params{-input};
+ my $script = $params{-script_file};
+ my $name = $params{-script_name};
+ my $user = $params{-user};
+ my $in = $params{-in};
+ my $in_fname = $params{-in_fname};
+ my $out = $params{-out};
+ my $out_fname = $params{-out_fname};
+ my $u = $params{-uri};
+ my $path = $params{-path_info};
+ my $input = $params{-input};
#
# Connect file descriptors.
#
- if (defined $in)
- {
- open(STDIN, '<&=' . fileno($in)) || die "can't redirect STDIN: $!";
- }
- else
- {
- my $devnull = File::Spec->devnull;
- open(STDIN, $devnull) || die "can't open $devnull: $!";
+ if ( !WINDOWS ) {
+ if (defined $in)
+ {
+ open(STDIN, '<&=' . fileno($in)) || die "can't redirect STDIN: $!";
+ }
+ else
+ {
+ my $devnull = File::Spec->devnull;
+ open(STDIN, $devnull) || die "can't open $devnull: $!";
+ }
+ open(STDOUT, '>&=' . fileno($out)) || die "can't redirect STDOUT: $!";
}
- open(STDOUT, '>&=' . fileno($out)) || die "can't redirect STDOUT: $!";
#
# Setup default CGI environment.
@@ -548,7 +583,7 @@ sub _run_cgi
# If there's no input, delete CONTENT_* variables.
#
- if (defined $in)
+ if (defined $input)
{
$ENV{CONTENT_TYPE} = $input->mime_type;
$ENV{CONTENT_LENGTH} = $input->length;
@@ -627,9 +662,18 @@ sub _run_cgi
chdir $directory or die "can't cd to $directory: $!";
- {exec "./$basename"}
+ if ( WINDOWS ) {
+ my $cmd_line = $input ? "$basename < ${in_fname} > ${out_fname}"
+ : "$basename >${out_fname}"
+ ;
+
+ exec $cmd_line;
+ }
+ else {
+ exec "./$basename";
+ }
+
die "could not exec $script: $!";
- return;
}
######################################################################
@@ -682,22 +726,6 @@ sub _parse_header
return \%header;
}
-######################################################################
-#
-# ok
-#
-# Useful to print test result when using Test::Harness.
-#
-######################################################################
-sub ok
-{
- my ($num, $ok, $comment) = @_;
- print "not " unless $ok;
- print "ok $num";
- print " # $comment" if defined $comment;
- print "\n";
-}
-
1;
=head1 NAME
diff --git a/t/01_env.t b/t/01_env.t
new file mode 100644
index 0000000..f958af7
--- /dev/null
+++ b/t/01_env.t
@@ -0,0 +1,76 @@
+use Test::More tests => 16;
+
+use CGI::Test;
+
+my $SERVER = "some-server";
+my $PORT = 18;
+my $BASE = "http://${SERVER}:${PORT}/cgi-bin";;
+my $SCRIPT = $^O =~ /win/i ? 'printenv.bat' : 'printenv';
+my $SCRIPT_FNAME = $^O =~ /win/i ? "t\\cgi\\$SCRIPT" : "t/cgi/$SCRIPT";
+
+my $ct = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+);
+
+ok defined $ct, "Got CGI::Test object";
+isa_ok $ct, 'CGI::Test', 'isa';
+
+my $PATH_INFO = "path/info";
+my $QUERY = "query=1";
+my $USER = "ram";
+
+my $page = $ct->GET("$BASE/$SCRIPT/${PATH_INFO}?${QUERY}", $USER);
+my $raw_length = length $page->raw_content;
+
+ok !$page->is_error, "No errors in page";
+ok $raw_length, "Got raw length: $raw_length";
+
+my %V;
+parse_content(\%V, $page->raw_content_ref);
+
+cmp_ok $V{SCRIPT_NAME}, 'eq', "/cgi-bin/$SCRIPT", "SCRIPT_NAME";
+cmp_ok $V{SERVER_PORT}, '==', $PORT, "SERVER_PORT";
+cmp_ok $V{REQUEST_METHOD}, 'eq', "GET", "REQUEST_METHOD";
+cmp_ok $V{SCRIPT_FILENAME}, 'eq', $SCRIPT_FNAME, "SCRIPT_FILENAME";
+cmp_ok $V{PATH_INFO}, 'eq', "/$PATH_INFO", "PATH_INFO";
+cmp_ok $V{QUERY_STRING}, 'eq', $QUERY, "QUERY_STRING";
+cmp_ok $V{REMOTE_USER}, 'eq', $USER, "REMOTE_USER";
+cmp_ok $V{HTTP_USER_AGENT}, 'eq', "CGI::Test", "HTTP_USER_AGENT";
+
+my $AGENT = "LWP::UserAgent";
+my $EXTRA = "is set";
+$page->delete;
+
+my $ct2 = CGI::Test->new(
+ -base_url => $BASE,
+ -cgi_dir => "t/cgi",
+ -cgi_env => {
+ EXTRA_IMPORTANT_VARIABLE => $EXTRA,
+ HTTP_USER_AGENT => $AGENT,
+ SCRIPT_FILENAME => "foo",
+ },
+);
+
+$page = $ct2->GET("$BASE/$SCRIPT");
+parse_content(\%V, $page->raw_content_ref);
+
+cmp_ok $V{SCRIPT_NAME}, 'eq', "/cgi-bin/$SCRIPT", "SCRIPT_NAME";
+cmp_ok $V{HTTP_USER_AGENT}, 'eq', $AGENT, "HTTP_USER_AGENT";
+cmp_ok $V{EXTRA_IMPORTANT_VARIABLE}, 'eq', $EXTRA, "EXTRA_IMPORTANT_VARIABLE";
+
+ok !exists $V{REMOTE_USER}, "REMOTE_USER not set";
+
+$page->delete;
+
+exit 0; ## DONE
+
+sub parse_content {
+ my ($h, $cref) = @_;
+ %$h = ();
+ foreach my $l (split /\n/, $$cref) {
+ my ($k, $v) = $l =~ /^([^=]+)\s*=\s*(.*)$/;
+ $h->{$k} = $v;
+ }
+}
+
diff --git a/t/parsing.t b/t/02_parsing.t
similarity index 100%
rename from t/parsing.t
rename to t/02_parsing.t
diff --git a/t/get.t b/t/03_get.t
similarity index 100%
rename from t/get.t
rename to t/03_get.t
diff --git a/t/post.t b/t/04_post.t
similarity index 100%
rename from t/post.t
rename to t/04_post.t
diff --git a/t/play_get.t b/t/05_play_get.t
similarity index 100%
rename from t/play_get.t
rename to t/05_play_get.t
diff --git a/t/play_post.t b/t/06_play_post.t
similarity index 100%
rename from t/play_post.t
rename to t/06_play_post.t
diff --git a/t/play_multi.t b/t/07_play_multi.t
similarity index 100%
rename from t/play_multi.t
rename to t/07_play_multi.t
diff --git a/t/env.t b/t/env.t
deleted file mode 100644
index 82b2b84..0000000
--- a/t/env.t
+++ /dev/null
@@ -1,108 +0,0 @@
-#
-# $Id: env.t,v 1.2 2003/09/29 11:00:50 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: env.t,v $
-# Revision 1.2 2003/09/29 11:00:50 mshiltonj
-# CGI::Test has changed ownership. The new owner is Steven Hilton
-# <mshilt...@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:03 ram
-# Baseline for first Alpha release.
-#
-# $EndLog$
-#
-
-use CGI::Test;
-
-print "1..15\n";
-
-my $SERVER = "some-server";
-my $PORT = 18;
-my $BASE = "http://${SERVER}:${PORT}/cgi-bin";;
-
-my $ct = CGI::Test->new(
- -base_url => $BASE,
- -cgi_dir => "t/cgi",
-);
-
-ok 1, defined $ct;
-
-my $PATH_INFO = "path/info";
-my $QUERY = "query=1";
-my $USER = "ram";
-
-my $page = $ct->GET("$BASE/printenv/${PATH_INFO}?${QUERY}", $USER);
-ok 2, !$page->is_error;
-ok 3, length $page->raw_content;
-
-my %V;
-parse_content(\%V, $page->raw_content_ref);
-
-ok 4, $V{SCRIPT_NAME} eq "/cgi-bin/printenv";
-ok 5, $V{SERVER_PORT} == $PORT;
-ok 6, $V{REQUEST_METHOD} eq "GET";
-ok 7, $V{SCRIPT_FILENAME} eq "t/cgi/printenv";
-ok 8, $V{PATH_INFO} eq "/$PATH_INFO";
-ok 9, $V{QUERY_STRING} eq $QUERY;
-ok 10, $V{REMOTE_USER} eq $USER;
-ok 11, $V{HTTP_USER_AGENT} eq "CGI::Test";
-
-my $AGENT = "LWP::UserAgent";
-my $EXTRA = "is set";
-$page->delete;
-
-my $ct2 = CGI::Test->new(
- -base_url => $BASE,
- -cgi_dir => "t/cgi",
- -cgi_env => {
- EXTRA_IMPORTANT_VARIABLE => $EXTRA,
- HTTP_USER_AGENT => $AGENT,
- SCRIPT_FILENAME => "foo",
- },
-);
-
-$page = $ct2->GET("$BASE/printenv");
-parse_content(\%V, $page->raw_content_ref);
-
-ok 12, $V{SCRIPT_NAME} eq "/cgi-bin/printenv";
-ok 13, $V{HTTP_USER_AGENT} eq $AGENT;
-ok 14, $V{EXTRA_IMPORTANT_VARIABLE} eq $EXTRA;
-ok 15, !exists $V{REMOTE_USER};
-$page->delete;
-
-exit 0; ## DONE
-
-sub parse_content {
- my ($h, $cref) = @_;
- %$h = ();
- foreach my $l (split /\n/, $$cref) {
- my ($k, $v) = split / = /, $l;
- $h->{$k} = $v;
- }
-}
-
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-perl/packages/libcgi-test-perl.git
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
