APR-Emulate-PSGI
view release on metacpan or search on metacpan
---
abstract: 'Class that Emulates the mod_perl2 APR Object (Apache2::RequestRec, et al)'
author:
- 'Nathan Gray, <kolibrie@cpan.org>'
build_requires:
ExtUtils::MakeMaker: 6.59
IO::File: 0
Test::More: 0.88
configure_requires:
ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
generated_by: 'Module::Install version 1.06'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: APR-Emulate-PSGI
no_index:
directory:
- inc
- t
requires:
HTTP::Headers: 0
URI: 0
perl: 5.10.0
resources:
license: http://dev.perl.org/licenses/
repository: git://github.com/kolibrie/apr-emulate-psgi.git
version: 0.03
Makefile.PL view on Meta::CPAN
use 5.010000;
use inc::Module::Install;
# Define metadata
name 'APR-Emulate-PSGI';
all_from 'lib/APR/Emulate/PSGI.pm';
readme_pod_from 'lib/APR/Emulate/PSGI.pm';
# Specific dependencies
requires 'URI' => '0';
requires 'HTTP::Headers' => '0';
test_requires 'Test::More' => '0.88';
test_requires 'IO::File' => '0';
auto_set_repository;
WriteAll;
HTTP environment information is read from the PSGI environment that is
passed in as a parameter. If no PSGI environment is supplied,
environment information is read from the global %ENV.
=cut
=item psgi_status
Returns the numeric HTTP response that should be used when building
a PSGI response.
my $status = $r->psgi_status();
The value is determined by looking at the current value of L</status_line>,
or if that is not set, the current value of L</status>, or if that is not
set, defaults to 200.
=cut
=item psgi_headers
Returns an arrayref of headers which can be used when building a PSGI
response.
A Content-Length header is not included, and must be added in accordance
with the L<PSGI> specification, while building the PSGI response.
my $headers_arrayref = $r->psgi_headers();
=cut
=back
=head2 Request Methods
inc/Module/Install.pm view on Meta::CPAN
# all of the following checks should be included in import(),
# to allow "eval 'require Module::Install; 1' to test
# installation of Module::Install. (RT #51267)
#-------------------------------------------------------------
# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
use inc::${\__PACKAGE__};
not:
use ${\__PACKAGE__};
inc/Module/Install.pm view on Meta::CPAN
# This reportedly fixes a rare Win32 UTC file time issue, but
# as this is a non-cross-platform XS module not in the core,
# we shouldn't really depend on it. See RT #24194 for detail.
# (Also, this module only supports Perl 5.6 and above).
eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
my $s = (stat($0))[9];
# If the modification time is only slightly in the future,
# sleep briefly to remove the problem.
my $a = $s - time;
if ( $a > 0 and $a < 5 ) { sleep 5 }
# Too far in the future, throw an error.
inc/Module/Install.pm view on Meta::CPAN
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
return $args{_self} if $args{_self};
inc/Module/Install.pm view on Meta::CPAN
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
$file = "$self->{path}/$subpath.pm";
my $pkg = "$self->{name}::$subpath";
$pkg =~ s!/!::!g;
# If we have a mixed-case package name, assume case has been preserved
# correctly. Otherwise, root through the file to locate the case-preserved
# version of the package name.
if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
my $content = Module::Install::_read($subpath . '.pm');
my $in_pod = 0;
foreach ( split //, $content ) {
$in_pod = 1 if /^=\w/;
$in_pod = 0 if /^=cut/;
next if ($in_pod || /^=cut/); # skip pod text
next if /^\s*#/; # and comments
if ( m/^\s*package\s+($pkg)\s*;/i ) {
inc/Module/Install/Can.pm view on Meta::CPAN
}
return;
}
# Can our C compiler environment build XS files
sub can_xs {
my $self = shift;
# Ensure we have the CBuilder module
$self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
# Do we have the configure_requires checker?
local $@;
eval "require ExtUtils::CBuilder;";
if ( $@ ) {
# They don't obey configure_requires, so it is
# someone old and delicate. Try to avoid hurting
# them by falling back to an older simpler test.
return $self->can_cc();
}
# Do we have a working C compiler
my $builder = ExtUtils::CBuilder->new(
quiet => 1,
);
unless ( $builder->have_compiler ) {
# No working C compiler
return 0;
}
# Write a C file representative of what XS becomes
require File::Temp;
my ( $FH, $tmpfile ) = File::Temp::tempfile(
"compilexs-XXXXX",
SUFFIX => '.c',
);
binmode $FH;
print $FH <<'END_C';
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
inc/Module/Install/Can.pm view on Meta::CPAN
eval {
local $^W = 0;
$object = $builder->compile(
source => $tmpfile,
);
@libs = $builder->link(
objects => $object,
module_name => 'sanexs',
);
};
my $result = $@ ? 0 : 1;
# Clean up all the build files
foreach ( $tmpfile, $object, @libs ) {
next unless defined $_;
1 while unlink;
}
return $result;
}
# Can we locate a (the) C compiler
sub can_cc {
my $self = shift;
my @chunks = split(/ /, $Config::Config{cc}) or return;
# $Config{cc} may contain args; try to find out the program part
while (@chunks) {
return $self->can_run("@chunks") || (pop(@chunks), next);
inc/Module/Install/Fetch.pm view on Meta::CPAN
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
$|++;
print "Fetching '$file' from $host... ";
unless (eval { require Socket; Socket::inet_aton($host) }) {
warn "'$host' resolve failed!\n";
return;
}
return unless $scheme eq 'ftp' or $scheme eq 'http';
require Cwd;
my $dir = Cwd::getcwd();
chdir $args{local_dir} or return if exists $args{local_dir};
if (eval { require LWP::Simple; 1 }) {
inc/Module/Install/Makefile.pm view on Meta::CPAN
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
# This previous attempted to inherit the version of
# ExtUtils::MakeMaker in use by the module author, but this
# was found to be untenable as some authors build releases
# using future dev versions of EU:MM that nobody else has.
# Instead, #toolchain suggests we use 6.59 which is the most
# stable version on CPAN at time of writing and is, to quote
# ribasushi, "not terminally fucked, > and tested enough".
# TODO: We will now need to maintain this over time to push
# the version up as new versions are released.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
$self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
$args->{NAME} =~ s/-/::/g;
$args->{VERSION} = $self->version or die <<'EOT';
ERROR: Can't determine distribution version. Please specify it
explicitly via 'version' in Makefile.PL, or set a valid $VERSION
inc/Module/Install/Makefile.pm view on Meta::CPAN
}
if ( $self->makemaker(6.31) and $self->license ) {
$args->{LICENSE} = $self->license;
}
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
# Merge both kinds of requires into BUILD_REQUIRES
my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
%$build_prereq = ( %$build_prereq,
map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
($self->configure_requires, $self->build_requires)
);
# Remove any reference to perl, BUILD_REQUIRES doesn't support it
delete $args->{BUILD_REQUIRES}->{perl};
# Delete bundled dists from prereq_pm, add it to Makefile DIR
my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
my %processed;
foreach my $bundle (@{ $self->bundles }) {
my ($mod_name, $dist_dir) = @$bundle;
delete $prereq->{$mod_name};
$dist_dir = File::Basename::basename($dist_dir); # dir for building this module
if (not exists $processed{$dist_dir}) {
if (-d $dist_dir) {
# List as sub-directory to be processed by make
push @$subdirs, $dist_dir;
}
# Else do nothing: the module is already present on the system
$processed{$dist_dir} = undef;
}
}
}
unless ( $self->makemaker('6.55_03') ) {
%$prereq = (%$prereq,%$build_prereq);
delete $args->{BUILD_REQUIRES};
}
inc/Module/Install/Metadata.pm view on Meta::CPAN
name
module_name
abstract
version
distribution_type
tests
installdirs
};
my @tuple_keys = qw{
configure_requires
build_requires
requires
recommends
bundles
resources
};
my @resource_keys = qw{
homepage
bugtracker
repository
};
my @array_keys = qw{
keywords
author
};
*authors = \&author;
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys { @array_keys }
foreach my $key ( @boolean_keys ) {
*$key = sub {
my $self = shift;
if ( defined wantarray and not @_ ) {
return $self->{values}->{$key};
}
$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
return $self;
inc/Module/Install/Metadata.pm view on Meta::CPAN
foreach my $key ( @array_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} if defined wantarray and !@_;
$self->{values}->{$key} ||= [];
push @{$self->{values}->{$key}}, @_;
return $self;
};
}
foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
@{ $self->{values}->{resources} };
}
return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
$self->resources( $key => $uri );
return 1;
};
}
foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
*$key = sub {
my $self = shift;
return $self->{values}->{$key} unless @_;
my @added;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
push @added, [ $module, $version ];
}
push @{ $self->{values}->{$key} }, @added;
return map {@$_} @added;
};
}
# Resource handling
my %lc_resource = map { $_ => 1 } qw{
homepage
license
bugtracker
repository
};
sub resources {
my $self = shift;
while ( @_ ) {
my $name = shift or last;
my $value = shift or next;
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
$self->{values}->{resources} ||= [];
push @{ $self->{values}->{resources} }, [ $name, $value ];
}
$self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
sub install_as_cpan { $_[0]->installdirs('site') }
sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
my $value = @_ ? shift : 1;
inc/Module/Install/Metadata.pm view on Meta::CPAN
dist_name => $self->name,
dist_version => $self->version,
license => $self->license,
);
$self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
my $self = shift;
my $name = shift;
my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
# The user used ->feature like ->features by passing in the second
# argument as a reference. Accomodate for that.
$mods = $_[0];
} else {
$mods = \@_;
}
my $count = 0;
push @$features, (
$name => [
map {
ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
} @$mods
]
);
return @$features;
}
sub features {
my $self = shift;
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
return $self->{values}->{features}
? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
return $self->{values}->{no_index};
}
inc/Module/Install/Metadata.pm view on Meta::CPAN
lgpl => 'http://opensource.org/licenses/lgpl-license.php',
lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
bsd => 'http://opensource.org/licenses/bsd-license.php',
gpl => 'http://opensource.org/licenses/gpl-license.php',
gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
mit => 'http://opensource.org/licenses/mit-license.php',
mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
open_source => undef,
unrestricted => undef,
restrictive => undef,
unknown => undef,
);
sub license {
my $self = shift;
return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
$license = __extract_license($license) || lc $license;
$self->{values}->{license} = $license;
# Automatically fill in license URLs
if ( $license_urls{$license} ) {
$self->resources( license => $license_urls{$license} );
}
return 1;
}
sub _extract_license {
my $pod = shift;
my $matched;
return __extract_license(
($matched) = $pod =~ m/
inc/Module/Install/Metadata.pm view on Meta::CPAN
my @phrases = (
'(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
'(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
'Artistic and GPL' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
'GNU lesser public license' => 'lgpl', 1,
'GNU library general public license' => 'lgpl', 1,
'GNU library public license' => 'lgpl', 1,
'GNU Free Documentation license' => 'unrestricted', 1,
'GNU Affero General Public License' => 'open_source', 1,
'(?:Free)?BSD license' => 'bsd', 1,
'Artistic license 2\.0' => 'artistic_2', 1,
'Artistic license' => 'artistic', 1,
'Apache (?:Software )?license' => 'apache', 1,
'GPL' => 'gpl', 1,
'LGPL' => 'lgpl', 1,
'BSD' => 'bsd', 1,
'Artistic' => 'artistic', 1,
'MIT' => 'mit', 1,
'Mozilla Public License' => 'mozilla', 1,
'Q Public License' => 'open_source', 1,
'OpenSSL License' => 'unrestricted', 1,
'SSLeay License' => 'unrestricted', 1,
'zlib License' => 'open_source', 1,
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
return $license;
}
}
return '';
inc/Module/Install/Metadata.pm view on Meta::CPAN
if ( @links > 1 ) {
warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
# Set the bugtracker
bugtracker( $links[0] );
return 1;
}
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->requires( $module => $version );
}
}
sub test_requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
$self->test_requires( $module => $version );
}
}
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
inc/Module/Install/Metadata.pm view on Meta::CPAN
# We need Parse::CPAN::Meta to load the file
unless ( eval { require Parse::CPAN::Meta; 1; } ) {
return undef;
}
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
if ( $perl ) {
$val->{requires} ||= [];
my $requires = $val->{requires};
# Canonize to three-dot version after Perl 5.6
if ( $perl >= 5.006 ) {
$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
unshift @$requires, [ perl => $perl ];
}
# Load the advisory META.yml file
my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashs
delete $meta->{requires};
delete $meta->{build_requires};
delete $meta->{recommends};
if ( exists $val->{requires} ) {
$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
}
if ( exists $val->{build_requires} ) {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
return $meta;
}
1;
inc/Module/Install/Win32.pm view on Meta::CPAN
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
or
ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.
You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
}
1;
lib/APR/Emulate/PSGI.pm view on Meta::CPAN
my ( $class, $env ) = @_;
my $self = bless {
'psgi_env' => $env,
'cgi_mode' => ( defined($env) ? 0 : 1 ),
}, $class;
return $self;
}
=item psgi_status
Returns the numeric HTTP response that should be used when building
a PSGI response.
my $status = $r->psgi_status();
The value is determined by looking at the current value of L</status_line>,
or if that is not set, the current value of L</status>, or if that is not
set, defaults to 200.
=cut
sub psgi_status {
my ($self) = @_;
my $status = $self->status_line() || $self->status() || '200';
$status =~ s/\D//g;
return $status;
}
=item psgi_headers
Returns an arrayref of headers which can be used when building a PSGI
response.
A Content-Length header is not included, and must be added in accordance
with the L<PSGI> specification, while building the PSGI response.
my $headers_arrayref = $r->psgi_headers();
=cut
sub psgi_headers {
my ($self) = @_;
my @headers = ();
my $status = $self->psgi_status();
t/10_psgi.t view on Meta::CPAN
use Test::More;
use APR::Emulate::PSGI;
use IO::File;
plan('tests' => 21);
# Set up filehandles needed in the PSGI environment.
my $error_string;
my $request_body = 'hello=world';
my $response_body = 'howdy';
open my $fh_in, '<', \do { $request_body };
open my $fh_errors, '>', \$error_string;
# Set up PSGI environment.
my $psgi_env = {
'REMOTE_ADDR' => '192.168.1.1',
'REQUEST_METHOD' => 'POST',
'CONTENT_TYPE' => 'application/x-www-form-urlencoded',
'CONTENT_LENGTH' => length($request_body),
'HTTP_HOK' => 'gahaha',
t/10_psgi.t view on Meta::CPAN
# Verify that data is going in as expected (request).
SKIP: {
skip(
'Not yet implemented: $r->connection()',
1,
) unless $r->can('connection');
is(
$r->connection()->remote_ip(),
'192.168.1.1',
'Remote address is available.',
);
}
is(
$r->method(),
'POST',
'Request method is available.',
);
is(
t/10_psgi.t view on Meta::CPAN
length($request_body),
'POST content is read.',
);
is(
$actual,
$request_body,
'POST content is correct.',
);
# Set headers for the response.
is(
$r->headers_out()->add('X-Foo' => 'Bar'),
1,
'Header added.',
);
is(
$r->content_type('text/html'),
'text/html',
'Content-type is set.',
);
# Verify that data comes out as expected (response).
is(
$r->psgi_status(),
'200',
'Received expected status.',
);
my $headers = +{ @{$r->psgi_headers()} };
is(
$headers->{'Content-Type'},
t/10_psgi.t view on Meta::CPAN
is(
exists($headers->{'Cache-control'}),
'',
'Received no Cache-control header.',
);
my $body_fh = IO::File->new_tmpfile();
{
local *STDOUT = $body_fh;
#my $length = $r->print($response_body);
is(
#$length,
$r->print($response_body),
length($response_body),
'Content is printed.',
);
}
$body_fh->seek(0, 0); # Reset filehandle back to the beginning.
is(
$body_fh->getline(),
$response_body,
'Received expected content.',
);
t/20_cgi_mode.t view on Meta::CPAN
use Test::More;
use APR::Emulate::PSGI;
use IO::File;
plan('tests' => 16);
# Set up filehandles needed in the PSGI environment.
my $error_string;
my $request_body = 'hello=world';
my $response_body = 'howdy';
open my $fh_in, '<', \do { $request_body };
open my $fh_errors, '>', \$error_string;
# Set up CGI environment.
$ENV{'REMOTE_ADDR'} = '192.168.1.1';
$ENV{'REQUEST_METHOD'} = 'POST';
$ENV{'CONTENT_TYPE'} = 'application/x-www-form-urlencoded';
$ENV{'CONTENT_LENGTH'} = length($request_body);
$ENV{'HTTP_HOK'} = 'gahaha';
t/20_cgi_mode.t view on Meta::CPAN
# Verify that data is going in as expected (request).
SKIP: {
skip(
'Not yet implemented: $r->connection()',
1,
) unless $r->can('connection');
is(
$r->connection()->remote_ip(),
'192.168.1.1',
'Remote address is available.',
);
}
is(
$r->method(),
'POST',
'Request method is available.',
);
is(
t/20_cgi_mode.t view on Meta::CPAN
'POST content is read.',
);
is(
$actual,
$request_body,
'POST content is correct.',
);
}
# Verify that data comes out as expected (response).
is(
$r->headers_out()->add('X-Foo' => 'Bar'),
1,
'Header added.',
);
my $headers_fh = IO::File->new_tmpfile();
{
local *STDOUT = $headers_fh;
t/20_cgi_mode.t view on Meta::CPAN
is(
$headers_fh->getline(),
"\n",
'Received end-of-headers indicator.',
);
my $body_fh = IO::File->new_tmpfile();
{
local *STDOUT = $body_fh;
#my $length = $r->print($response_body);
is(
#$length,
$r->print($response_body),
length($response_body),
'Content is printed.',
);
}
$body_fh->seek(0, 0); # Reset filehandle back to the beginning.
is(
$body_fh->getline(),
$response_body,
'Received expected content.',
);
( run in 0.779 second using v1.01-cache-2.11-cpan-49f99fa48dc )