Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
128 lines (104 sloc) 3.57 KB
package LWP::UserAgent::Local;
use LWP::UserAgent;
use base 'LWP::UserAgent';
use IPC::Run3 'run3';
use IO::String;
=pod
The ScriptAlias parameter to LWP::UserAgent::Local::new is used to
find what part of a URI's path corresponds to the script name
The ScriptAlias is matched against the path; the single path component
that follows is the script name.
Ultimately, it should take multiple ScriptAliases and should map them
to file-system paths.
=cut
sub new {
$class = shift;
my %super_args = %{ $_[0] };
delete $super_args{ScriptAlias};
delete $super_args{AddHandler};
$this = $class->SUPER::new(%super_args);
%$this = %{ $_[0] };
$this;
}
sub request {&simple_request}
sub simple_request {
my $this = shift;
my $request = shift;
my ($options) = @_;
Carp::croak
"LWP::UserAgent::Local::request requires an HTTP::Request argument"
unless ref $request && $request->isa('HTTP::Request');
my $request_method = $request->method();
$request_method = "GET" unless $request_method;
my $script_alias = $this->{ScriptAlias};
if ( $this->{AddHandler} ) {
my ( $handler, $ext ) = split / +/, $this->{AddHandler};
return unless $request->uri->path() =~ /$ext$/;
}
my ( $script_name, $path )
= ( $request->uri->path()
=~ m|^(?:\w+://[^/]*/?)?$script_alias([^/]*)(/?.*)| );
$script_name
or die "Couldn't determine script name from "
. $request->uri()->path();
$ENV{REQUEST_URI} = $script_alias;
$this->{cookie_jar}->add_cookie_header($request) if $this->{cookie_jar};
shift;
###delete $ENV{$_} foreach (grep {/^HTTP_/} (keys %ENV));
$request->headers()->scan(
sub {
$header_name = $_[0];
$header_name =~ tr/a-z-/A-Z_/;
$ENV{ "HTTP_" . $header_name } = $_[1];
}
);
$ENV{REQUEST_METHOD} = $request_method;
foreach $header (@headers) {
my ( $header_name, $header_val ) = $header =~ /(.*?):(.*)/;
$header_name =~ tr/a-z-/A-Z_/;
$ENV{ "HTTP_" . $header_name } = $header_val;
}
$ENV{SCRIPT_NAME} = $script_name;
$ENV{PATH_INFO} = $path;
$ENV{QUERY_STRING} = $request->uri->query || '';
$ENV{HTTP_USER_AGENT} = "Ezra's Local User Agent 0.1";
print $ENV{REQUEST_METHOD} . " => "
. $ENV{SCRIPT_NAME}
. $ENV{PATH_INFO} . "\n"
if $options->{verbose};
my $content = $request->content();
if ($content) {
$ENV{CONTENT_LENGTH} = length $request->content();
}
run3 [$^X, "./$script_name"],
\$content, \my $output, undef,
{ binmode_stdin => 1 }
or die "Couldn't spawn ./$script_name";
print STDERR "$script_name exit status: $?\n" if $?;
my $RESPONSE = IO::String->new($output);
my $response = new HTTP::Response();
$response->request($request);
my $status_line = '';
while ( ( $line = <$RESPONSE> ) !~ /^\s*$/ ) {
if ( $line =~ /^Status:/i ) {
$status_line = $line;
}
else {
my ( $hdr_name, $hdr_val ) = ( $line =~ /(.*?):(.*)/ );
$response->header( $hdr_name => $hdr_val );
}
# print "S: ", $line;
}
$this->{cookie_jar}->extract_cookies($response) if $this->{cookie_jar};
$status_line =~ s/Status: //i;
my ( $response_code, $response_desc )
= $status_line =~ /^(\d\d\d)(\s.*)?$/;
$response->code($response_code);
$response->message($response_desc);
local $/ = undef;
$body = <$RESPONSE>;
$response->content($body);
close $RESPONSE;
$response;
}
1;