Author: timbo
Date: Thu Feb 8 11:03:14 2007
New Revision: 8832
Added:
dbi/trunk/lib/DBD/Gofer/Transport/http.pm (contents, props changed)
dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm (contents, props changed)
Modified:
dbi/trunk/MANIFEST
Log:
First working draft of http->mod_perl transports.
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Thu Feb 8 11:03:14 2007
@@ -26,6 +26,7 @@
lib/DBD/File.pm A driver base class for simple drivers
lib/DBD/Gofer.pm DBD::Gofer 'stateless proxy' driver
lib/DBD/Gofer/Transport/Base.pm Base class for DBD::Gofer driver transport
classes
+lib/DBD/Gofer/Transport/http.pm
lib/DBD/Gofer/Transport/null.pm DBD::Gofer transport that executes in same
process (for testing)
lib/DBD/Gofer/Transport/pipeone.pm DBD::Gofer transport to new subprocess for
each request
lib/DBD/Gofer/Transport/stream.pm DBD::Gofer transport for ssh etc
@@ -43,6 +44,7 @@
lib/DBI/Gofer/Request.pm Request object from DBD::Gofer
lib/DBI/Gofer/Response.pm Response object for DBD::Gofer
lib/DBI/Gofer/Transport/Base.pm Base class for DBD::Gofer server transport
classes
+lib/DBI/Gofer/Transport/mod_perl.pm
lib/DBI/Gofer/Transport/pipeone.pm DBD::Gofer transport for single requests
lib/DBI/Gofer/Transport/stream.pm DBI::Gofer transport for ssh etc
lib/DBI/Profile.pm Manage DBI usage profile data
Added: dbi/trunk/lib/DBD/Gofer/Transport/http.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer/Transport/http.pm Thu Feb 8 11:03:14 2007
@@ -0,0 +1,98 @@
+package DBD::Gofer::Transport::http;
+
+# $Id$
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+use Carp;
+use URI;
+use LWP::UserAgent;
+use HTTP::Request;
+
+use base qw(DBD::Gofer::Transport::Base);
+
+our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+
+__PACKAGE__->mk_accessors(qw(
+ connection_info
+ response_info
+));
+
+my $encoding = "binary";
+
+
+sub transmit_request {
+ my ($self, $request) = @_;
+
+ my $info = eval {
+ my $frozen_request = $self->freeze_data($request);
+
+ my $req = $self->{req} ||= do {
+ my $url = $self->go_url || croak "No url specified";
+ my $request = HTTP::Request->new(POST => $url);
+ $request->content_type('application/x-perl-dbd-gofer-$encoding');
+ $request;
+ };
+ my $ua = $self->{ua} ||= do {
+ my $useragent = LWP::UserAgent->new(
+ #timeout => XXX,
+ env_proxy => 1, # XXX
+ );
+ $useragent->agent(join "/", __PACKAGE__, $DBI::VERSION, $VERSION);
+ #$useragent->credentials( $netloc, $realm, $uname, $pass ); XXX
+ $useragent->parse_head(0); # don't parse html head
+ $useragent;
+ };
+
+ my $content = $frozen_request;
+ $req->header('Content-Length' => length($content)); # in bytes
+ $req->content($content);
+
+ # Pass request to the user agent and get a response back
+ my $res = $ua->request($req);
+ $self->connection_info( $res );
+ };
+ if ($@) {
+ my $response = DBI::Gofer::Response->new({ err => 1, errstr => $@ });
+ $self->response_info($response);
+ }
+ else {
+ $self->response_info(undef);
+ }
+
+ return 1;
+}
+
+
+sub receive_response {
+ my $self = shift;
+
+ my $response = $self->response_info;
+ return $response if $response; # failed while starting
+
+ my $res = $self->connection_info || die;
+
+ if (not $res->is_success) {
+ return DBI::Gofer::Response->new({
+ err => 1, # or 100_000 + $res->status_code?
+ errstr => $res->status_line,
+ });
+ }
+
+ my $frozen_response = $res->content;
+
+ $response = $self->thaw_data($frozen_response);
+
+ return $response;
+}
+
+
+1;
+
+__END__
Added: dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm Thu Feb 8 11:03:14 2007
@@ -0,0 +1,30 @@
+package DBI::Gofer::Transport::mod_perl;
+
+use strict;
+use warnings;
+
+use DBI::Gofer::Execute qw(execute_request);
+
+use Apache::Constants qw(OK);
+
+use base qw(DBI::Gofer::Transport::Base);
+
+our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+
+my $transport = __PACKAGE__->new();
+
+
+sub handler {
+ my $r = shift;
+ my $r_dir_config = $r->dir_config; # cache it as it's relatively expensive
+
+ $r->read(my $frozen_request, $r->header_in('Content-length'));
+
+ my $response = execute_request( $transport->thaw_data($frozen_request) );
+
+ my $frozen_response = $transport->freeze_data($response);
+
+ print $frozen_response;
+
+ return Apache::Constants::OK;
+}
