package t::Utils;
use strict;
use Exporter ();
use IO::Socket::INET;
use vars qw( @ISA @EXPORT @EXPORT_OK );
@ISA = qw( Exporter );
@EXPORT = qw( &server_start &server_next &fork_proxy &web_ok &bare_request );
@EXPORT_OK = @EXPORT;
use HTTP::Daemon;
use LWP::UserAgent;
sub server_start {
my $daemon = HTTP::Daemon->new(
LocalHost => 'localhost',
ReuseAddr => 1,
)
or die "Unable to start web server";
return $daemon;
}
sub server_next {
my $daemon = shift;
my $answer = shift;
my $conn = $daemon->accept;
my $req = $conn->get_request;
my $rep;
if ( ref $answer eq 'CODE' ) {
$rep = $answer->( $req, @_ );
}
else {
$rep = HTTP::Response->new(
200, 'OK',
HTTP::Headers->new( 'Content-Type' => 'text/plain' ),
sprintf( "You asked for <a href='%s'>%s</a>", ( $req->uri ) x 2 )
);
}
$conn->send_response($rep);
$conn->close;
}
sub fork_proxy {
my $proxy = shift;
my $sub = shift;
my $pid = fork;
die "Unable to fork proxy" if not defined $pid;
if ( $pid == 0 ) {
$0 .= " (proxy)";
$proxy->start;
$sub->() if ( defined $sub and ref $sub eq 'CODE' );
exit 0;
}
return $pid;
}
sub web_ok {
my $ua = LWP::UserAgent->new( env_proxy => 1, timeout => 30 );
my $res =
$ua->request(
HTTP::Request->new( GET => shift||'http://www.google.com/intl/en/' ) );
return $res->is_success;
}
sub bare_request {
my ($url, $headers, $proxy) = @_;
$proxy->url() =~ /:(\d+)/;
my $sock = IO::Socket::INET->new(
PeerAddr => 'localhost',
PeerPort => $1,
Proto => 'tcp'
) or do { warn "Can't connect to the proxy"; return ""; };
print $sock "GET $url HTTP/1.0\015\012",
$headers->as_string( "\015\012" ), "\015\012";
my $content = join "", <$sock>;
close $sock or warn "close: $!";
return $content;
}
package HTTP::Proxy;
sub _filter_stack {
my ( $self, $part, $mesg ) = splice( @_, 0, 3 );
die "No <$part><$mesg> filter stack"
unless $part =~ /^(?:header|body)$/
and $mesg =~ /^(?:request|response)$/;
for (@_) {
die "$_ is not a HTTP::Request or HTTP::Response"
unless ( ref $_ ) =~ /^HTTP::(Request|Response)$/;
$self->{ lc $1 } = $_;
}
$self->{response}->request( $self->{request} );
return $self->{$part}{$mesg};
}