APR-Emulate-PSGI

 view release on metacpan or  search on metacpan

META.yml  view on Meta::CPAN

---
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;

README.pod  view on Meta::CPAN


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 1.789 second using v1.01-cache-2.11-cpan-49f99fa48dc )