use IO::File qw[SEEK_SET];
use Symbol qw[];
-__PACKAGE__->mk_accessors(qw[environment request is_restored is_setuped is_prepared should_dup should_restore should_rewind stdin stdout stderr]);
+__PACKAGE__->mk_accessors( qw[ is_setuped
+ is_prepared
+ is_restored
+
+ should_dup
+ should_restore
+ should_rewind
+ should_setup_content
+
+ environment
+ request
+ stdin
+ stdout
+ stderr ] );
our $VERSION = 0.6_01;
$self->should_rewind(1);
}
+ if ( exists $params->{content} ) {
+ $self->should_setup_content( $params->{content} ? 1 : 0 );
+ }
+ else {
+ $self->should_setup_content(1);
+ }
+
$self->prepare;
return $self;
sub setup {
my $self = shift;
+ $self->setup_content;
$self->setup_stdin;
$self->setup_stdout;
$self->setup_stderr;
return $self;
}
-sub setup_environment {
+sub setup_content {
my $self = shift;
- no warnings 'uninitialized';
+ if ( $self->should_setup_content && $self->has_stdin ) {
- if ( $self->should_restore ) {
- $self->{restore}->{environment} = { %ENV };
- }
+ if ( $self->request->content_length ) {
- %ENV = %{ $self->environment };
-}
+ my $content = $self->request->content_ref;
-sub setup_stdin {
- my $self = shift;
+ if ( ref $content eq 'SCALAR' ) {
- if ( $self->has_stdin ) {
+ if ( defined $$content && length $$content ) {
- binmode( $self->stdin );
-
- if ( $self->request->content_length ) {
+ print( { $self->stdin } $$content )
+ or croak("Couldn't write request content to stdin handle: '$!'");
- syswrite( $self->stdin, $self->request->content )
- or croak("Couldn't write request content to stdin handle: '$!'");
+ if ( $self->should_rewind ) {
- sysseek( $self->stdin, 0, SEEK_SET )
- or croak("Couldn't seek stdin handle: '$!'");
+ seek( $self->stdin, 0, SEEK_SET )
+ or croak("Couldn't seek stdin handle: '$!'");
+ }
+ }
+ }
+ else {
+ croak("Can't handle request content of '$content'");
+ }
}
+ }
+}
+
+sub setup_stdin {
+ my $self = shift;
+
+ if ( $self->has_stdin ) {
if ( $self->should_dup ) {
}
STDIN->fdopen( $self->stdin, '<' )
- or croak("Couldn't redirect STDIN: '$!'");
+ or croak("Couldn't dup stdin handle to STDIN: '$!'");
}
else {
$self->{restore}->{stdin_ref} = \*$stdin;
}
- *{ $stdin } = $self->stdin;
+ *$stdin = $self->stdin;
}
+ binmode( $self->stdin );
binmode( STDIN );
}
}
}
STDOUT->fdopen( $self->stdout, '>' )
- or croak("Couldn't redirect STDOUT: '$!'");
+ or croak("Couldn't dup stdout handle to STDOUT: '$!'");
}
else {
$self->{restore}->{stdout_ref} = \*$stdout;
}
- *{ $stdout } = $self->stdout;
+ *$stdout = $self->stdout;
}
binmode( $self->stdout );
}
STDERR->fdopen( $self->stderr, '>' )
- or croak("Couldn't redirect STDERR: '$!'");
+ or croak("Couldn't dup stderr handle to STDERR: '$!'");
}
else {
$self->{restore}->{stderr_ref} = \*$stderr;
}
- *{ $stderr } = $self->stderr;
+ *$stderr = $self->stderr;
}
binmode( $self->stderr );
}
}
+sub setup_environment {
+ my $self = shift;
+
+ no warnings 'uninitialized';
+
+ if ( $self->should_restore ) {
+ $self->{restore}->{environment} = { %ENV };
+ }
+
+ %ENV = %{ $self->environment };
+}
+
sub response {
my $self = shift;
my %params = ( headers_only => 0, sync => 0, @_ );
- return undef unless $self->stdout;
+ return undef unless $self->has_stdout;
- seek( $self->stdout, 0, SEEK_SET )
- or croak("Couldn't seek stdout handle: '$!'");
+ if ( $self->should_rewind ) {
- my $headers;
- while ( my $line = $self->stdout->getline ) {
- $headers .= $line;
- last if $headers =~ /\x0d?\x0a\x0d?\x0a$/;
+ seek( $self->stdout, 0, SEEK_SET )
+ or croak("Couldn't seek stdout handle: '$!'");
}
- unless ( defined $headers ) {
- $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
- }
+ my $message = undef;
+ my $response = HTTP::Response->new( 200, 'OK' );
+ $response->protocol('HTTP/1.1');
- unless ( $headers =~ /^HTTP/ ) {
- $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
+ while ( my $line = $self->stdout->getline ) {
+ $message .= $line;
+ last if $message =~ /\x0d?\x0a\x0d?\x0a$/;
}
- my $response = HTTP::Response->parse($headers);
- $response->date( time() ) unless $response->date;
+ if ( !$message ) {
- my $message = $response->message;
- my $status = $response->header('Status');
+ $response->code(500);
+ $response->message('Internal Server Error');
+ $response->date( time );
+ $response->content( $response->error_as_HTML );
+ $response->content_type('text/html');
+ $response->content_length( length $response->content );
- if ( $message && $message =~ /^(.+)\x0d$/ ) {
- $response->message($1);
+ return $response;
}
- if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {
+ my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
+ my $Version = qr/HTTP\/[0-9]+\.[0-9]+/;
- my $code = $1;
- my $message = $2 || HTTP::Status::status_message($code);
+ if ( $message =~ s/^($Version)[\x09\x20]+(\d{3})[\x09\x20]+([\x20-\xFF]*)\x0D?\x0A//o ) {
- $response->code($code);
- $response->message($message);
+ $response->protocol($1);
+ $response->code($2);
+ $response->message($3);
}
- my $length = ( stat( $self->stdout ) )[7] - tell( $self->stdout );
+ $message =~ s/\x0D?\x0A[\x09\x20]+/\x20/gs;
- if ( $response->code == 500 && !$length ) {
+ foreach ( split /\x0D?\x0A/, $message ) {
- $response->content( $response->error_as_HTML );
- $response->content_type('text/html');
+ if ( /^($Token+)[\x09\x20]*:[\x09\x20]*([\x20-\xFF]+)[\x09\x20]*$/o ) {
+ $response->headers->push_header( $1 => $2 );
+ }
+ else {
+ # XXX what should we do on bad headers?
+ }
+ }
- return $response;
+ my $status = $response->header('Status');
+
+ if ( $status && $status =~ /^(\d{3})[\x09\x20]+([\x20-\xFF]+)$/ ) {
+ $response->code($1);
+ $response->message($2);
+ }
+
+ if ( !$response->date ) {
+ $response->date(time);
}
if ( $params{headers_only} ) {
while () {
- my $r = $self->stdout->read( $content, 4096, $content_length );
+ my $r = $self->stdout->read( $content, 65536, $content_length );
if ( defined $r ) {
last unless $r;
}
else {
- croak("Couldn't read from stdin handle: '$!'");
+ croak("Couldn't read response content from stdin handle: '$!'");
}
}
else {
my $stdin_ref = $self->{restore}->{stdin_ref};
-
- *{ $stdin_ref } = $stdin;
+ *$stdin_ref = $stdin;
}
if ( $self->should_rewind ) {
else {
my $stdout_ref = $self->{restore}->{stdout_ref};
-
- *{ $stdout_ref } = $stdout;
+ *$stdout_ref = $stdout;
}
if ( $self->should_rewind ) {
else {
my $stderr_ref = $self->{restore}->{stderr_ref};
-
- *{ $stderr_ref } = $stderr;
+ *$stderr_ref = $stderr;
}
if ( $self->should_rewind ) {
sub DESTROY {
my $self = shift;
- if ( $self->should_restore ) {
-
- if ( $self->is_setuped && !$self->is_restored ) {
- $self->restore;
- }
+ if ( $self->should_restore && $self->is_setuped && !$self->is_restored ) {
+ $self->restore;
}
}
projects / catagits/HTTP-Request-AsCGI.git / blobdiff