From: Christian Hansen Date: Sun, 26 Nov 2006 05:04:29 +0000 (+0000) Subject: Added more documentation and tests X-Git-Tag: v1.0~26 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FHTTP-Request-AsCGI.git;a=commitdiff_plain;h=9c216915d12ea486f286186438c98593c2a3c60b Added more documentation and tests --- diff --git a/Changes b/Changes index 4209fc3..e02506c 100644 --- a/Changes +++ b/Changes @@ -1,8 +1,16 @@ This file documents the revision history for Perl extension HTTP::Request::AsCGI. -0.6 2006-11-08 00:00:00 2005 - - Support for Perl 5.6 - - Support for in memory handles +0.6 2006-12-XX 00:00:00 2005 + - Added support for Perl 5.6, by Hans Dieter Pearcey (hdp@cpan.org) + - Added support for in-memory filehandles as standard filehandles + - Added support for AUTH_TYPE and REMOTE_USER, currently only support + Basic and Digest auth schemes. + - Added support for CODE in request content + - Constructor parameters has changed, "old" way of invoking constructor has + been moved to deprecation. Please see DEPRECATED section in POD. + - Added several new options to constructor for more advanced usage + - Major cleanup of internals, more readable and maintainable + - Fixed PATH_INFO, must not be urlencoded 0.5 2006-01-20 00:00:00 2005 - Fixed bug where content was overridden on 500 responses. diff --git a/MANIFEST b/MANIFEST deleted file mode 100644 index fb8c343..0000000 --- a/MANIFEST +++ /dev/null @@ -1,14 +0,0 @@ -Changes -examples/daemon.pl -examples/synopsis.pl -lib/HTTP/Request/AsCGI.pm -Makefile.PL -MANIFEST This list of files -META.yml -README -t/01use.t -t/04io.t -t/05env.t -t/06response.t -t/07forking.t -t/08error.t diff --git a/META.yml b/META.yml deleted file mode 100644 index 10bae85..0000000 --- a/META.yml +++ /dev/null @@ -1,16 +0,0 @@ -# http://module-build.sourceforge.net/META-spec.html -#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# -name: HTTP-Request-AsCGI -version: 0.2 -version_from: lib/HTTP/Request/AsCGI.pm -installdirs: site -requires: - Carp: 0 - Class::Accessor: 0 - HTTP::Request: 0 - HTTP::Response: 0 - IO::File: 0 - Test::More: 0 - -distribution_type: module -generated_by: ExtUtils::MakeMaker version 6.17 diff --git a/Makefile.PL b/Makefile.PL index 734551f..01695a5 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -7,10 +7,11 @@ WriteMakefile( VERSION_FROM => 'lib/HTTP/Request/AsCGI.pm', PREREQ_PM => { Carp => 0, - Class::Accessor => 0, + Class::Accessor => 0, HTTP::Request => 0, HTTP::Response => 1.53, IO::File => 0, - Test::More => 0 + Test::More => 0, + URI::Escape => 0 } ); diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm index 55b7bdb..c1a1ff1 100644 --- a/lib/HTTP/Request/AsCGI.pm +++ b/lib/HTTP/Request/AsCGI.pm @@ -7,9 +7,9 @@ use base 'Class::Accessor::Fast'; use Carp qw[croak]; use HTTP::Response qw[]; -use IO::Handle qw[]; use IO::File qw[SEEK_SET]; use Symbol qw[]; +use URI::Escape qw[]; __PACKAGE__->mk_accessors( qw[ is_setup is_prepared @@ -116,6 +116,9 @@ sub has_stdin { return defined $_[0]->stdin } sub has_stdout { return defined $_[0]->stdout } sub has_stderr { return defined $_[0]->stderr } +my $HTTP_Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; +my $HTTP_Version = qr/HTTP\/[0-9]+\.[0-9]+/; + sub prepare { my $self = shift; @@ -136,7 +139,7 @@ sub prepare { GATEWAY_INTERFACE => 'CGI/1.1', HTTP_HOST => $uri->host_port, HTTPS => ( $uri->scheme eq 'https' ) ? 'ON' : 'OFF', # not in RFC 3875 - PATH_INFO => $uri->path, + PATH_INFO => URI::Escape::uri_unescape($uri->path), QUERY_STRING => $uri->query || '', SCRIPT_NAME => '/', SERVER_NAME => $uri->host, @@ -150,6 +153,26 @@ sub prepare { REQUEST_METHOD => $request->method ); + if ( my $authorization = $request->header('Authorization') ) { + + ( my $scheme ) = $authorization =~ /^($HTTP_Token+)/o; + + if ( $scheme =~ /^Basic/i ) { + + if ( ( my $username ) = $request->headers->authorization_basic ) { + $cgi{AUTH_TYPE} = 'Basic'; + $cgi{REMOTE_USER} = $username; + } + } + elsif ( $scheme =~ /^Digest/i ) { + + if ( ( my $username ) = $authorization =~ /username="([^"]+)"/ ) { + $cgi{AUTH_TYPE} = 'Digest'; + $cgi{REMOTE_USER} = $username; + } + } + } + foreach my $key ( keys %cgi ) { unless ( exists $environment->{ $key } ) { @@ -157,18 +180,18 @@ sub prepare { } } - foreach my $field ( $self->request->headers->header_field_names ) { + foreach my $field ( $request->headers->header_field_names ) { my $key = uc("HTTP_$field"); $key =~ tr/-/_/; $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/; unless ( exists $environment->{ $key } ) { - $environment->{ $key } = $self->request->headers->header($field); + $environment->{ $key } = $request->headers->header($field); } } - unless ( $environment->{SCRIPT_NAME} eq '/' && $environment->{PATH_INFO} ) { + if ( $environment->{SCRIPT_NAME} ne '/' && $environment->{PATH_INFO} ) { $environment->{PATH_INFO} =~ s/^\Q$environment->{SCRIPT_NAME}\E/\//; $environment->{PATH_INFO} =~ s/^\/+/\//; } @@ -180,80 +203,13 @@ sub setup { my $self = shift; if ( $self->is_setup ) { - croak("An attempt was made to setup environment variables and STD handles which has already been setup."); - } - - $self->setup_content; - $self->setup_stdin; - $self->setup_stdout; - $self->setup_stderr; - $self->setup_environment; - - if ( $INC{'CGI.pm'} ) { - CGI::initialize_globals(); - } - - $self->is_setup(1); - - return $self; -} - -sub write_content { - my ( $self, $handle ) = @_; - - my $content = $self->request->content_ref; - - if ( ref($content) eq 'SCALAR' ) { - - if ( defined($$content) && length($$content) ) { - - print( { $self->stdin } $$content ) - or croak("Couldn't write request content SCALAR to stdin handle: '$!'"); - - if ( $self->should_rewind ) { - - seek( $self->stdin, 0, SEEK_SET ) - or croak("Couldn't rewind stdin handle: '$!'"); - } - } - } - elsif ( ref($content) eq 'CODE' ) { - - while () { - - my $chunk = &$content(); - - if ( defined($chunk) && length($chunk) ) { - - print( { $self->stdin } $chunk ) - or croak("Couldn't write request content callback to stdin handle: '$!'"); - } - else { - last; - } - } - - if ( $self->should_rewind ) { - - seek( $self->stdin, 0, SEEK_SET ) - or croak("Couldn't rewind stdin handle: '$!'"); - } - } - else { - croak("Couldn't write request content to stdin handle: 'Unknown request content $content'"); + croak( 'An attempt was made to setup environment variables and ' + . 'standard filehandles which has already been setup.' ); } -} - -sub setup_content { - my $self = shift; if ( $self->should_setup_content && $self->has_stdin ) { - $self->write_content($self->stdin); + $self->setup_content; } -} - -sub setup_stdin { - my $self = shift; if ( $self->has_stdin ) { @@ -268,7 +224,7 @@ sub setup_stdin { } open( STDIN, '<&' . fileno($self->stdin) ) - or croak("Couldn't dup stdin handle to STDIN: '$!'"); + or croak("Couldn't dup stdin filehandle to STDIN: '$!'"); } else { @@ -286,10 +242,6 @@ sub setup_stdin { binmode( $self->stdin ); binmode( STDIN ); } -} - -sub setup_stdout { - my $self = shift; if ( $self->has_stdout ) { @@ -304,7 +256,7 @@ sub setup_stdout { } open( STDOUT, '>&' . fileno($self->stdout) ) - or croak("Couldn't dup stdout handle to STDOUT: '$!'"); + or croak("Couldn't dup stdout filehandle to STDOUT: '$!'"); } else { @@ -322,10 +274,6 @@ sub setup_stdout { binmode( $self->stdout ); binmode( STDOUT); } -} - -sub setup_stderr { - my $self = shift; if ( $self->has_stderr ) { @@ -340,7 +288,7 @@ sub setup_stderr { } open( STDERR, '>&' . fileno($self->stderr) ) - or croak("Couldn't dup stdout handle to STDOUT: '$!'"); + or croak("Couldn't dup stdout filehandle to STDOUT: '$!'"); } else { @@ -358,22 +306,72 @@ sub setup_stderr { binmode( $self->stderr ); binmode( STDERR ); } -} -sub setup_environment { - my $self = shift; + { + no warnings 'uninitialized'; - no warnings 'uninitialized'; + if ( $self->should_restore ) { + $self->{restore}->{environment} = { %ENV }; + } - if ( $self->should_restore ) { - $self->{restore}->{environment} = { %ENV }; + %ENV = %{ $self->environment }; } - %ENV = %{ $self->environment }; + if ( $INC{'CGI.pm'} ) { + CGI::initialize_globals(); + } + + $self->is_setup(1); + + return $self; } -my $HTTP_Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; -my $HTTP_Version = qr/HTTP\/[0-9]+\.[0-9]+/; +sub setup_content { + my $self = shift; + my $stdin = shift || $self->stdin; + + my $content = $self->request->content_ref; + + if ( ref($content) eq 'SCALAR' ) { + + if ( defined($$content) && length($$content) ) { + + print( { $stdin } $$content ) + or croak("Couldn't write request content SCALAR to stdin filehandle: '$!'"); + + if ( $self->should_rewind ) { + + seek( $stdin, 0, SEEK_SET ) + or croak("Couldn't rewind stdin filehandle: '$!'"); + } + } + } + elsif ( ref($content) eq 'CODE' ) { + + while () { + + my $chunk = &$content(); + + if ( defined($chunk) && length($chunk) ) { + + print( { $stdin } $chunk ) + or croak("Couldn't write request content callback to stdin filehandle: '$!'"); + } + else { + last; + } + } + + if ( $self->should_rewind ) { + + seek( $stdin, 0, SEEK_SET ) + or croak("Couldn't rewind stdin filehandle: '$!'"); + } + } + else { + croak("Couldn't write request content to stdin filehandle: 'Unknown request content $content'"); + } +} sub response { my $self = shift; @@ -384,7 +382,7 @@ sub response { if ( $self->should_rewind ) { seek( $self->stdout, 0, SEEK_SET ) - or croak("Couldn't seek stdout handle: '$!'"); + or croak("Couldn't rewind stdout filehandle: '$!'"); } my $message = undef; @@ -450,10 +448,10 @@ sub response { if ( $params{sync} ) { my $position = tell( $self->stdout ) - or croak("Couldn't get file position from stdout handle: '$!'"); + or croak("Couldn't get file position from stdout filehandle: '$!'"); sysseek( $self->stdout, $position, SEEK_SET ) - or croak("Couldn't seek stdout handle: '$!'"); + or croak("Couldn't seek stdout filehandle: '$!'"); } return $response; @@ -476,7 +474,7 @@ sub response { } } else { - croak("Couldn't read response content from stdin handle: '$!'"); + croak("Couldn't read response content from stdin filehandle: '$!'"); } } @@ -496,39 +494,24 @@ sub restore { my $self = shift; if ( !$self->should_restore ) { - croak("An attempt was made to restore environment variables and STD handles which has not been saved."); + croak( 'An attempt was made to restore environment variables and ' + . 'standard filehandles which has not been saved.' ); } if ( !$self->is_setup ) { - croak("An attempt was made to restore environment variables and STD handles which has not been setup."); + croak( 'An attempt was made to restore environment variables and ' + . 'standard filehandles which has not been setup.' ); } if ( $self->is_restored ) { - croak("An attempt was made to restore environment variables and STD handles which has already been restored."); + croak( 'An attempt was made to restore environment variables and ' + . 'standard filehandles which has already been restored.' ); } - $self->restore_environment; - $self->restore_stdin; - $self->restore_stdout; - $self->restore_stderr; - - $self->{restore} = {}; - - $self->is_restored(1); - - return $self; -} - -sub restore_environment { - my $self = shift; - - no warnings 'uninitialized'; - - %ENV = %{ $self->{restore}->{environment} }; -} - -sub restore_stdin { - my $self = shift; + { + no warnings 'uninitialized'; + %ENV = %{ $self->{restore}->{environment} }; + } if ( $self->has_stdin ) { @@ -548,13 +531,9 @@ sub restore_stdin { if ( $self->should_rewind ) { seek( $self->stdin, 0, SEEK_SET ) - or croak("Couldn't rewind stdin handle: '$!'"); + or croak("Couldn't rewind stdin filehandle: '$!'"); } } -} - -sub restore_stdout { - my $self = shift; if ( $self->has_stdout ) { @@ -577,13 +556,9 @@ sub restore_stdout { if ( $self->should_rewind ) { seek( $self->stdout, 0, SEEK_SET ) - or croak("Couldn't rewind stdout handle: '$!'"); + or croak("Couldn't rewind stdout filehandle: '$!'"); } } -} - -sub restore_stderr { - my $self = shift; if ( $self->has_stderr ) { @@ -606,9 +581,15 @@ sub restore_stderr { if ( $self->should_rewind ) { seek( $self->stderr, 0, SEEK_SET ) - or croak("Couldn't rewind stderr handle: '$!'"); + or croak("Couldn't rewind stderr filehandle: '$!'"); } } + + $self->{restore} = {}; + + $self->is_restored(1); + + return $self; } sub DESTROY { @@ -625,7 +606,7 @@ __END__ =head1 NAME -HTTP::Request::AsCGI - Setup a CGI environment from a HTTP::Request +HTTP::Request::AsCGI - Setup a Common Gateway Interface environment from a HTTP::Request =head1 SYNOPSIS @@ -665,11 +646,8 @@ Provides a convinient way of setting up an CGI environment from a HTTP::Request. =item * new -Contructor - - HTTP::Request->new( $request, %environment ); - - HTTP::Request->new( request => $request, environment => \%environment ); +Contructor, this method takes a hash of parameters. The following parameters are +valid: =over 8 @@ -679,8 +657,8 @@ Contructor =item * stdin -Filehandle to be used as C, defaults to a temporary file. If value is -C, C will be left as is. +A filehandle to be used as standard input, defaults to a temporary filehandle. +If C is C, standard input will be left as is. stdin => IO::File->new_tmpfile stdin => IO::String->new @@ -689,8 +667,8 @@ C, C will be left as is. =item * stdout -Filehandle to be used as C, defaults to a temporary file. If value is -C, C will be left as is. +A filehandle to be used as standard output, defaults to a temporary filehandle. +If C is C, standard output will be left as is. stdout => IO::File->new_tmpfile stdout => IO::String->new @@ -699,8 +677,8 @@ C, C will be left as is. =item * stderr -Filehandle to be used as C, defaults to C. If value is C, -C will be left as is. +A filehandle to be used as standard error, defaults to C. If C is +C, standard error will be left as is. stderr => IO::File->new_tmpfile stderr => IO::String->new @@ -709,69 +687,123 @@ C will be left as is. =item * environment +A C of additional environment variables to be used in CGI. +C doesn't autmatically merge C<%ENV>, it has to be +explicitly given if that is desired. Environment variables given in this +C isn't overridden by C. + environment => \%ENV - environment => { PATH => '/bin:/usr/bin' } + environment => { PATH => '/bin:/usr/bin', SERVER_SOFTWARE => 'Apache/1.3' } + +Following standard meta-variables (in addition to protocol-specific) is setup: + + AUTH_TYPE + CONTENT_LENGTH + CONTENT_TYPE + GATEWAY_INTERFACE + PATH_INFO + SCRIPT_NAME + SERVER_NAME + SERVER_PORT + SERVER_PROTOCOL + SERVER_SOFTWARE + REMOTE_ADDR + REMOTE_HOST + REMOTE_USER + REQUEST_METHOD + QUERY_STRING + +Following non-standard but common meta-variables is setup: + + HTTPS + REMOTE_PORT + REQUEST_URI + +Following meta-variables is B setup but B be provided in CGI: + + PATH_TRANSLATED + +Following meta-variables is B setup but common in CGI: + + DOCUMENT_ROOT + SCRIPT_FILENAME + SERVER_ROOT =item * dup +Boolean to indicate whether to C standard filehandle or to assign the +typeglob representing the standard filehandle. Defaults to C. + dup => 0 dup => 1 =item * restore +Boolean to indicate whether or not to restore environment variables and standard +filehandles. Defaults to C. + restore => 0 restore => 1 +If C standard filehandles and environment variables will be saved duiring +C for later use in C. + =item * rewind +Boolean to indicate whether or not to rewind standard filehandles. Defaults +to C. + rewind => 0 rewind => 1 =item * content +Boolean to indicate whether or not to request content should be written to +C filehandle when C is invoked. Defaults to C. + content => 0 content => 1 =back -=item environment +=item * setup -Returns a hashref containing the environment that will be used in setup. -Changing the hashref after setup has been called will have no effect. +Attempts to setup standard filehandles and environment variables. -=item setup +=item * restore -Setups the environment and descriptors. +Attempts to restore standard filehandles and environment variables. -=item restore +=item * response -Restores the environment and descriptors. Can only be called after setup. +Attempts to parse C filehandle into a L. -=item request +=item * request -Returns the request given to constructor. +Accessor for L that was given to constructor. -=item response +=item * environment -Returns a HTTP::Response. Can only be called after restore. +Accessor for environment variables to be used in C. -=item stdin +=item * stdin -Accessor for handle that will be used for STDIN, must be a real seekable -handle with an file descriptor. Defaults to a temporary IO::File instance. +Accessor/Mutator for standard input filehandle. -=item stdout +=item * stdout -Accessor for handle that will be used for STDOUT, must be a real seekable -handle with an file descriptor. Defaults to a temporary IO::File instance. +Accessor/Mutator for standard output filehandle. -=item stderr +=item * stderr -Accessor for handle that will be used for STDERR, must be a real seekable -handle with an file descriptor. +Accessor/Mutator for standard error filehandle. =back +=head1 DEPRECATED + +XXX Constructor + =head1 SEE ALSO =over 4 diff --git a/t/01use.t b/t/01use.t index 5c9fb0f..fa63202 100644 --- a/t/01use.t +++ b/t/01use.t @@ -1,6 +1,6 @@ #!perl -use Test::More 'no_plan'; +use Test::More tests => 1; use strict; use warnings; diff --git a/t/02pod.t b/t/02pod.t new file mode 100644 index 0000000..1647794 --- /dev/null +++ b/t/02pod.t @@ -0,0 +1,7 @@ +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => 'Test::Pod 1.14 required' if $@; +plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; + +all_pod_files_ok(); diff --git a/t/04io.t b/t/04io.t index 029c5a7..3b73013 100644 --- a/t/04io.t +++ b/t/04io.t @@ -14,8 +14,11 @@ $r->content('STDIN'); $r->content_length(5); $r->content_type('text/plain'); -my $c = HTTP::Request::AsCGI->new($r); -$c->stderr(IO::File->new_tmpfile); +my $c = HTTP::Request::AsCGI->new( + request => $r, + stderr => IO::File->new_tmpfile +); + $c->setup; print STDOUT 'STDOUT'; diff --git a/t/04ioscalar.t b/t/04ioscalar.t new file mode 100644 index 0000000..345f315 --- /dev/null +++ b/t/04ioscalar.t @@ -0,0 +1,47 @@ +#!perl + +use Test::More tests => 3; + +{ + eval "use PerlIO::scalar"; + plan skip_all => 'PerlIO::scalar required' if $@; +} + +use strict; +use warnings; + +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $r = HTTP::Request->new( POST => 'http://www.host.com/'); +$r->content('STDIN'); +$r->content_length(5); +$r->content_type('text/plain'); + +open( my $stdin, ' +<', \( my $stdin_scalar ) ) + or die qq/Couldn't open a new PerlIO::scalar/; + +open( my $stdout, '+>', \( my $stdout_scalar ) ) + or die qq/Couldn't open a new PerlIO::scalar/; + +open( my $stderr, '+>', \( my $stderr_scalar ) ) + or die qq/Couldn't open a new PerlIO::scalar/; + +my $c = HTTP::Request::AsCGI->new( + request => $r, + dup => 0, + stdin => $stdin, + stdout => $stdout, + stderr => $stderr +); + +$c->setup; + +print STDOUT 'STDOUT'; +print STDERR 'STDERR'; + +$c->restore; + +is( $c->stdin->getline, 'STDIN', 'STDIN' ); +is( $c->stdout->getline, 'STDOUT', 'STDOUT' ); +is( $c->stderr->getline, 'STDERR', 'STDERR' ); diff --git a/t/04iostring.t b/t/04iostring.t new file mode 100644 index 0000000..23810e1 --- /dev/null +++ b/t/04iostring.t @@ -0,0 +1,38 @@ +#!perl + +use Test::More tests => 3; + +{ + eval "use IO::String 1.07"; + plan skip_all => 'IO::String 1.07 required' if $@; +} + +use strict; +use warnings; + +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $r = HTTP::Request->new( POST => 'http://www.host.com/'); +$r->content('STDIN'); +$r->content_length(5); +$r->content_type('text/plain'); + +my $c = HTTP::Request::AsCGI->new( + request => $r, + dup => 0, + stdin => IO::String->new, + stdout => IO::String->new, + stderr => IO::String->new +); + +$c->setup; + +print STDOUT 'STDOUT'; +print STDERR 'STDERR'; + +$c->restore; + +is( $c->stdin->getline, 'STDIN', 'STDIN' ); +is( $c->stdout->getline, 'STDOUT', 'STDOUT' ); +is( $c->stderr->getline, 'STDERR', 'STDERR' ); diff --git a/t/05env.t b/t/05env.t index 209d61e..bbb7125 100644 --- a/t/05env.t +++ b/t/05env.t @@ -1,6 +1,6 @@ #!perl -use Test::More tests => 10; +use Test::More tests => 12; use strict; use warnings; @@ -9,9 +9,13 @@ use HTTP::Request; use HTTP::Request::AsCGI; my $r = HTTP::Request->new( GET => 'http://www.host.com/cgi-bin/script.cgi/my/path/?a=1&b=2', [ 'X-Test' => 'Test' ] ); -my %e = ( SCRIPT_NAME => '/cgi-bin/script.cgi' ); -my $c = HTTP::Request::AsCGI->new( $r, %e ); -$c->stdout(undef); + $r->authorization_basic( 'chansen', 'xxx' ); + +my $c = HTTP::Request::AsCGI->new( + environment => { SCRIPT_NAME => '/cgi-bin/script.cgi' }, + request => $r, + stdout => undef +); $c->setup; @@ -20,6 +24,8 @@ is( $ENV{HTTP_HOST}, 'www.host.com:80', 'HTTP_HOST' ); is( $ENV{HTTP_X_TEST}, 'Test', 'HTTP_X_TEST' ); is( $ENV{PATH_INFO}, '/my/path/', 'PATH_INFO' ); is( $ENV{QUERY_STRING}, 'a=1&b=2', 'QUERY_STRING' ); +is( $ENV{AUTH_TYPE}, 'Basic', 'AUTH_TYPE' ); +is( $ENV{REMOTE_USER}, 'chansen', 'REMOTE_USER' ); is( $ENV{SCRIPT_NAME}, '/cgi-bin/script.cgi', 'SCRIPT_NAME' ); is( $ENV{REQUEST_METHOD}, 'GET', 'REQUEST_METHOD' ); is( $ENV{SERVER_NAME}, 'www.host.com', 'SERVER_NAME' ); diff --git a/t/06response.t b/t/06response.t index f3f9891..68e3ba2 100644 --- a/t/06response.t +++ b/t/06response.t @@ -13,7 +13,7 @@ my $response; { my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); - my $c = HTTP::Request::AsCGI->new($r); + my $c = HTTP::Request::AsCGI->new( request => $r ); $c->setup; diff --git a/t/07forking.t b/t/07forking.t index c4f0463..16b949b 100644 --- a/t/07forking.t +++ b/t/07forking.t @@ -10,7 +10,7 @@ use HTTP::Request::AsCGI; use Test::More; unless ( $Config{d_fork} ) { - plan skip_all => 'This test requires a plattform that supports fork()'; + plan skip_all => 'This test requires a platform that supports fork()'; } plan tests => 8; @@ -19,7 +19,7 @@ my $response; { my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); - my $c = HTTP::Request::AsCGI->new($r); + my $c = HTTP::Request::AsCGI->new( request => $r ); my $kid = fork(); diff --git a/t/08error.t b/t/08error.t index f117014..d611bb4 100644 --- a/t/08error.t +++ b/t/08error.t @@ -13,7 +13,7 @@ my $response; { my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); - my $c = HTTP::Request::AsCGI->new($r); + my $c = HTTP::Request::AsCGI->new( request => $r ); $c->setup; @@ -29,10 +29,10 @@ ok( length($response->content) > 0, 'Response Content' ); { my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); - my $c = HTTP::Request::AsCGI->new($r); + my $c = HTTP::Request::AsCGI->new( request => $r ); $c->setup; - + print "Content-Type: text/plain\n"; print "Status: 500 Borked\n"; print "\n"; diff --git a/t/deprecated/04io.t b/t/deprecated/04io.t new file mode 100644 index 0000000..029c5a7 --- /dev/null +++ b/t/deprecated/04io.t @@ -0,0 +1,28 @@ +#!perl + +use Test::More tests => 3; + +use strict; +use warnings; + +use IO::File; +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $r = HTTP::Request->new( POST => 'http://www.host.com/'); +$r->content('STDIN'); +$r->content_length(5); +$r->content_type('text/plain'); + +my $c = HTTP::Request::AsCGI->new($r); +$c->stderr(IO::File->new_tmpfile); +$c->setup; + +print STDOUT 'STDOUT'; +print STDERR 'STDERR'; + +$c->restore; + +is( $c->stdin->getline, 'STDIN', 'STDIN' ); +is( $c->stdout->getline, 'STDOUT', 'STDOUT' ); +is( $c->stderr->getline, 'STDERR', 'STDERR' ); diff --git a/t/deprecated/05env.t b/t/deprecated/05env.t new file mode 100644 index 0000000..18ac328 --- /dev/null +++ b/t/deprecated/05env.t @@ -0,0 +1,33 @@ +#!perl + +use Test::More tests => 12; + +use strict; +use warnings; + +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $r = HTTP::Request->new( GET => 'http://www.host.com/cgi-bin/script.cgi/my/path/?a=1&b=2', [ 'X-Test' => 'Test' ] ); + $r->authorization_basic( 'chansen', 'xxx' ); +my %e = ( SCRIPT_NAME => '/cgi-bin/script.cgi' ); +my $c = HTTP::Request::AsCGI->new( $r, %e ); + +$c->stdout(undef); +$c->setup; + +is( $ENV{GATEWAY_INTERFACE}, 'CGI/1.1', 'GATEWAY_INTERFACE' ); +is( $ENV{HTTP_HOST}, 'www.host.com:80', 'HTTP_HOST' ); +is( $ENV{HTTP_X_TEST}, 'Test', 'HTTP_X_TEST' ); +is( $ENV{PATH_INFO}, '/my/path/', 'PATH_INFO' ); +is( $ENV{QUERY_STRING}, 'a=1&b=2', 'QUERY_STRING' ); +is( $ENV{AUTH_TYPE}, 'Basic', 'AUTH_TYPE' ); +is( $ENV{REMOTE_USER}, 'chansen', 'REMOTE_USER' ); +is( $ENV{SCRIPT_NAME}, '/cgi-bin/script.cgi', 'SCRIPT_NAME' ); +is( $ENV{REQUEST_METHOD}, 'GET', 'REQUEST_METHOD' ); +is( $ENV{SERVER_NAME}, 'www.host.com', 'SERVER_NAME' ); +is( $ENV{SERVER_PORT}, '80', 'SERVER_PORT' ); + +$c->restore; + +is( $ENV{GATEWAY_INTERFACE}, undef, 'No CGI env after restore' ); diff --git a/t/deprecated/06response.t b/t/deprecated/06response.t new file mode 100644 index 0000000..f3f9891 --- /dev/null +++ b/t/deprecated/06response.t @@ -0,0 +1,39 @@ +#!perl + +use Test::More tests => 9; + +use strict; +use warnings; + +use IO::File; +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $response; + +{ + my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); + my $c = HTTP::Request::AsCGI->new($r); + + $c->setup; + + print "Content-Type: text/plain\n"; + print "Status: 200 Yay\n"; + print "Date: Thu, 19 Jan 2006 14:08:18 GMT\n"; + print "X-Field: 1\n"; + print "X-Field: 2\n"; + print "\n"; + print "Hello!"; + + $response = $c->restore->response; +} + +isa_ok( $response, 'HTTP::Response' ); +is( $response->code, 200, 'Response Code' ); +is( $response->message, 'Yay', 'Response Message' ); +is( $response->protocol, 'HTTP/1.1', 'Response Protocol' ); +is( $response->content, 'Hello!', 'Response Content' ); +is( $response->content_length, 6, 'Response Content-Length' ); +is( $response->content_type, 'text/plain', 'Response Content-Type' ); +is( $response->header('Date'), 'Thu, 19 Jan 2006 14:08:18 GMT', 'Response Date' ); +is_deeply( [ $response->header('X-Field') ], [ 1, 2 ], 'Response Header X-Field' ); diff --git a/t/deprecated/07forking.t b/t/deprecated/07forking.t new file mode 100644 index 0000000..1bccc30 --- /dev/null +++ b/t/deprecated/07forking.t @@ -0,0 +1,59 @@ +#!perl + +use strict; +use warnings; + +use Config; +use IO::File; +use HTTP::Request; +use HTTP::Request::AsCGI; +use Test::More; + +unless ( $Config{d_fork} ) { + plan skip_all => 'This test requires a platform that supports fork()'; +} + +plan tests => 8; + +my $response; + +{ + my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); + my $c = HTTP::Request::AsCGI->new($r); + + my $kid = fork(); + + unless ( defined $kid ) { + die("Can't fork() kid: $!"); + } + + unless ( $kid ) { + + $c->setup; + + print "HTTP/1.0 200 OK\n"; + print "Content-Type: text/plain\n"; + print "Status: 200\n"; + print "X-Field: 1\n"; + print "X-Field: 2\n"; + print "\n"; + print "Hello!"; + + $c->restore; + + exit(0); + } + + waitpid( $kid, 0 ); + + $response = $c->response; +} + +isa_ok( $response, 'HTTP::Response' ); +is( $response->code, 200, 'Response Code' ); +is( $response->message, 'OK', 'Response Message' ); +is( $response->protocol, 'HTTP/1.0', 'Response Protocol' ); +is( $response->content, 'Hello!', 'Response Content' ); +is( $response->content_length, 6, 'Response Content-Length' ); +is( $response->content_type, 'text/plain', 'Response Content-Type' ); +is_deeply( [ $response->header('X-Field') ], [ 1, 2 ], 'Response Header X-Field' ); diff --git a/t/deprecated/08error.t b/t/deprecated/08error.t new file mode 100644 index 0000000..f117014 --- /dev/null +++ b/t/deprecated/08error.t @@ -0,0 +1,49 @@ +#!perl + +use Test::More tests => 12; + +use strict; +use warnings; + +use IO::File; +use HTTP::Request; +use HTTP::Request::AsCGI; + +my $response; + +{ + my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); + my $c = HTTP::Request::AsCGI->new($r); + + $c->setup; + + $response = $c->restore->response; +} + +isa_ok( $response, 'HTTP::Response' ); +is( $response->code, 500, 'Response Code' ); +is( $response->message, 'Internal Server Error', 'Response Message' ); +is( $response->protocol, 'HTTP/1.1', 'Response Protocol' ); +is( $response->content_type, 'text/html', 'Response Content-Type' ); +ok( length($response->content) > 0, 'Response Content' ); + +{ + my $r = HTTP::Request->new( GET => 'http://www.host.com/' ); + my $c = HTTP::Request::AsCGI->new($r); + + $c->setup; + + print "Content-Type: text/plain\n"; + print "Status: 500 Borked\n"; + print "\n"; + print "Borked!"; + + $response = $c->restore->response; +} + +isa_ok( $response, 'HTTP::Response' ); +is( $response->code, 500, 'Response Code' ); +is( $response->message, 'Borked', 'Response Message' ); +is( $response->protocol, 'HTTP/1.1', 'Response Protocol' ); +is( $response->content_type, 'text/plain', 'Response Content-Type' ); +is( $response->content, 'Borked!', 'Response Content' );