Initial import of HTTP::Request::AsCGI

diff --git a/MANIFEST b/MANIFEST
new file mode 100644 (file)
index 0000000..50b0070
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,5 @@
+lib/HTTP/Request/AsCGI.pm
+t/01use.t
+Makefile.PL
+MANIFEST                              This list of files
+META.yml                   Module meta-data (added by MakeMaker)

diff --git a/META.yml b/META.yml
new file mode 100644 (file)
index 0000000..580d2b1
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,14 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
+name:         HTTP-Request-AsCGI
+version:      0.1
+version_from: lib/HTTP/Request/AsCGI.pm
+installdirs:  site
+requires:
+    Carp:                          0
+    Class::Accessor:               0
+    File::Temp:                    0.14
+    IO::Handle:                    0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17

diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..427a757
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,14 @@
+#!perl
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+    NAME         => 'HTTP::Request::AsCGI',
+    VERSION_FROM => 'lib/HTTP/Request/AsCGI.pm',
+    PREREQ_PM    => {
+        Carp             => 0,
+        Class::Accessor  => 0,
+        File::Temp       => 0.14,
+        IO::Handle       => 0
+    }
+);

diff --git a/lib/HTTP/Request/AsCGI.pm b/lib/HTTP/Request/AsCGI.pm
new file mode 100644 (file)
index 0000000..9d062a2
--- /dev/null
+++ b/lib/HTTP/Request/AsCGI.pm
@@ -0,0 +1,165 @@
+package HTTP::Request::AsCGI;
+
+use strict;
+use warnings;
+use base 'Class::Accessor::Fast';
+
+use Carp;
+use IO::Handle;
+use File::Temp;
+
+__PACKAGE__->mk_accessors( qw[ enviroment request stdin stdout stderr ] );
+
+our $VERSION = 0.1;
+
+sub new {
+    my $class   = shift;
+    my $request = shift;
+
+    my $self = {
+        request  => $request,
+        restored => 0,
+        stdin    => File::Temp->new,
+        stdout   => File::Temp->new,
+        stderr   => File::Temp->new
+    };
+
+    $self->{enviroment} = {
+        GATEWAY_INTERFACE => 'CGI/1.1',
+        HTTP_HOST         => $request->uri->host_port,
+        QUERY_STRING      => $request->uri->query || '',
+        SCRIPT_NAME       => $request->uri->path || '/',
+        SERVER_NAME       => $request->uri->host,
+        SERVER_PORT       => $request->uri->port,
+        SERVER_PROTOCOL   => $request->protocol || 'HTTP/1.1',
+        SERVER_SOFTWARE   => __PACKAGE__ . "/" . $VERSION,
+        REMOTE_ADDR       => '127.0.0.1',
+        REMOTE_HOST       => 'localhost',
+        REMOTE_PORT       => int( rand(64000) + 1000 ),        # not in RFC 3875
+        REQUEST_URI       => $request->uri->path || '/',       # not in RFC 3875
+        REQUEST_METHOD    => $request->method,
+        @_
+    };
+
+    foreach my $field ( $request->headers->header_field_names ) {
+
+        my $key = uc($field);
+        $key =~ tr/_/-/;
+        $key = 'HTTP_' . $key unless $field =~ /^Content-(Length|Type)$/;
+
+        unless ( exists $self->{enviroment}->{$key} ) {
+            $self->{enviroment}->{$key} = $request->headers->header($field);
+        }
+    }
+
+    return $class->SUPER::new($self);
+}
+
+sub setup {
+    my $self = shift;
+
+    open( my $stdin, '>&', STDIN->fileno )
+      or croak("Can't dup stdin: $!");
+
+    open( my $stdout, '>&', STDOUT->fileno )
+      or croak("Can't dup stdout: $!");
+
+    open( my $stderr, '>&', STDERR->fileno )
+      or croak("Can't dup stderr: $!");
+
+    $self->{restore} = {
+        stdin      => $stdin,
+        stdout     => $stdout,
+        stderr     => $stderr,
+        enviroment => {%ENV}
+    };
+
+    if ( $self->request->content_length ) {
+
+        $self->stdin->write( $self->request->content )
+          or croak("Can't write content: $!");
+
+        seek( $self->stdin, 0, 0 )
+          or croak("Can't seek stdin: $!");
+    }
+
+    %ENV = %{ $self->enviroment };
+
+    open( STDIN, '<&=', $self->stdin->fileno )
+      or croak("Can't open stdin: $!");
+
+    open( STDOUT, '>&=', $self->stdout->fileno )
+      or croak("Can't open stdout: $!");
+
+    open( STDERR, '>&=', $self->stderr->fileno )
+      or croak("Can't open stderr: $!");
+
+    return $self;
+}
+
+sub restore {
+    my $self = shift;
+
+    %ENV = %{ $self->{restore}->{enviroment} };
+
+    open( STDIN, '>&', $self->{restore}->{stdin} )
+      or croak("Can't restore stdin: $!");
+
+    open( STDOUT, '>&', $self->{restore}->{stdout} )
+      or croak("Can't restore stdout: $!");
+
+    open( STDERR, '>&', $self->{restore}->{stderr} )
+      or croak("Can't restore stderr: $!");
+      
+    $self->{restored}++;
+}
+
+sub DESTROY {
+    my $self = shift;
+    $self->restore unless $self->{restored};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Request::AsCGI - Create a CGI enviroment from a HTTP::Request
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4 
+
+=item new
+
+=item setup
+
+=item restore
+
+=item request
+
+=item stdin
+
+=item stdout
+
+=item stderr
+
+=back
+
+=head1 BUGS
+
+=head1 AUTHOR
+
+Christian Hansen, C<ch@ngmedia.com>
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify 
+it under the same terms as perl itself.
+
+=cut

diff --git a/t/01use.t b/t/01use.t
new file mode 100644 (file)
index 0000000..5c9fb0f
--- /dev/null
+++ b/t/01use.t
@@ -0,0 +1,8 @@
+#!perl
+
+use Test::More 'no_plan';
+
+use strict;
+use warnings;
+
+use_ok 'HTTP::Request::AsCGI';