view release on metacpan or  search on metacpan

t/lib/Test/HTTP/Server.pm  view on Meta::CPAN

sub in_body
{
	my $self = shift;
	my %headers = @{ $self->{headers} };

	$_ = "";
	my $len = $headers{content_length};
	$len = 10 * 1024 * 1024 unless defined $len;

	read STDIN, $_, $len;
	return $_;
}

sub out_response
{
	my $self = shift;
	my $code = shift;
	print "HTTP/$self->{version} $code\r\n";
}

sub out_headers
{
	my $self = shift;
	while ( my ( $name, $value ) = splice @_, 0, 2 ) {
		$name = join "-", map { ucfirst lc $_ } split /[_-]+/, $name;
		if ( ref $value ) {
			# must be an array
			foreach my $val ( @$value ) {
				print "$name: $val\r\n";
			}
		} else {
			print "$name: $value\r\n";
		}
	}
}

sub out_body
{
	my $self = shift;
	my $body = shift;

	use bytes;
	my $len = length $body;
	print "Content-Length: $len\r\n";
	print "\r\n";
	print $body;
}

sub out_all
{
	my $self = shift;

	my %default_headers = (
		content_type => "text/plain",
		date => $self->_http_time,
	);
	$self->{out_headers} = { %default_headers };

	my $req = $self->{request}->[1];
	$req =~ s#^/##;
	my @args = map { uri_unescape $_ } split m#/#, $req;
	my $func = shift @args;
	$func = "index" unless defined $func and length $func;

	my $body;
	eval {
		$body = $self->$func( @args );
	};
	if ( $@ ) {
		warn "Server error: $@\n";
		$self->out_response( "404 Not Found" );
		$self->out_headers(
			%default_headers
		);
		$self->out_body(
			"Server error: $@\n"
		);
	} elsif ( defined $body ) {
		$self->out_response( $self->{out_code} || "200 OK" );
		$self->out_headers( %{ $self->{out_headers} } );
		$self->out_body( $body );
	}
}

# default handlers
sub index
{
	my $self = shift;
	my $body = "Available functions:\n";
	$body .= ( join "", map "- $_\n", sort { $a cmp $b}
		grep { not __PACKAGE__->can( $_ ) }
		grep { Test::HTTP::Server::Request->can( $_ ) }
		keys %{Test::HTTP::Server::Request::} )
		|| "NONE\n";
	return $body;
}

sub echo
{
	my $self = shift;
	my $type = shift;
	my $body = "";
	if ( not $type or $type eq "head" ) {
		$body .= $self->{head};
	}
	if ( ( not $type or $type eq "body" ) and defined $self->{body} ) {
		$body .= $self->{body};
	}
	return $body;
}

sub cookie
{
	my $self = shift;
	my $num = shift || 1;
	my $template = shift ||
		"test_cookie%n=true; expires=%date(+600); path=/";

	my $expdate = sub {
		my $time = shift;
		$time += time if $time =~ m/^[+-]/;