Author: timbo
Date: Fri Sep 28 09:11:07 2007
New Revision: 10015
Added:
dbi/trunk/lib/DBI/Util/Cache.pm (contents, props changed)
dbi/trunk/t/87gofer_cache.t
Modified:
dbi/trunk/Changes
dbi/trunk/MANIFEST
dbi/trunk/Makefile.PL
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBD/Gofer/Transport/null.pm
dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
Log:
Added client-side caching to DBD::Gofer. Can use any cache
object compatible with the Cache module interface.
Added DBI::Util::Cache for use with DBD::Gofer
It's a very fast and small strict subset of Cache::Memory.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Sep 28 09:11:07 2007
@@ -48,6 +48,11 @@
thanks to Jerry D. Hedden and Michael G Schwern.
Fixed DBI for VMS thanks to Peter (Stig) Edwards.
+ Added client-side caching to DBD::Gofer. Can use any cache
+ object compatible with the Cache module interface.
+ Added DBI::Util::Cache for use with DBD::Gofer
+ It's a very fast and small strict subset of Cache::Memory.
+
=head2 Changes in DBI 1.59 (svn rev 9874), 23rd August 2007
Fixed DBI::ProfileData to unescape headers lines read from data file.
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Fri Sep 28 09:11:07 2007
@@ -62,7 +62,8 @@
lib/DBI/ProxyServer.pm The proxy drivers server
lib/DBI/PurePerl.pm A DBI.xs emulation in Perl
lib/DBI/SQL/Nano.pm A 'smaller than micro' SQL parser
-lib/DBI/Util/_accessor.pm A cut-down version of Class::Accessor::Fast
+lib/DBI/Util/_accessor.pm A very�cut-down version of
Class::Accessor::Fast
+lib/DBI/Util/Cache.pm A very cut-down version of Cache::Memory
lib/DBI/W32ODBC.pm An experimental DBI emulation layer for
Win32::ODBC
lib/Win32/DBIODBC.pm An experimental Win32::ODBC emulation layer for
DBI
t/01basics.t
@@ -95,6 +96,7 @@
t/80proxy.t
t/85gofer.t
t/86gofer_fail.t
+t/87gofer_cache.t
t/pod.t
test.pl Assorted informal tests, including tests for
memory leaks
typemap
Modified: dbi/trunk/Makefile.PL
==============================================================================
--- dbi/trunk/Makefile.PL (original)
+++ dbi/trunk/Makefile.PL Fri Sep 28 09:11:07 2007
@@ -139,7 +139,7 @@
EXE_FILES => [ "dbiproxy$ext_pl", "dbiprof$ext_pl", "dbilogstrip$ext_pl" ],
DIR => [ ],
dynamic_lib => { OTHERLDFLAGS => "$::opt_g" },
- clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zv*_*.t"
+ clean => { FILES=> "\$(DISTVNAME) Perl.xsi t/zv*_*.t dbi__null_test_tmp*"
." dbiproxy$ext_pl dbiprof$ext_pl dbilogstrip$ext_pl
dbitrace.log dbi.prof ndtest.prt" },
dist => {
DIST_DEFAULT=> 'clean distcheck disttest tardist',
Modified: dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/Base.pm Fri Sep 28 09:11:07 2007
@@ -22,12 +22,23 @@
go_timeout
go_retry_hook
go_retry_limit
+ go_cache
+ cache_hit
+ cache_miss
+ cache_store
));
__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
meta
));
+sub new {
+ my ($class, $args) = @_;
+ $args->{$_} = 0 for (qw(cache_hit cache_miss cache_store));
+ return $class->SUPER::new($args);
+}
+
+
sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 }
@@ -39,8 +50,24 @@
sub transmit_request {
my ($self, $request) = @_;
- my $to = $self->go_timeout;
+ my $response;
+
+ if (my $go_cache = $self->{go_cache}) {
+ my $request_key = $self->get_cache_key_for_request($request);
+ my $frozen_response = $go_cache->get($request_key) if $request_key;
+ if ($frozen_response) {
+ $response = $self->thaw_response($frozen_response);
+ my $trace = $self->trace;
+ $self->_dump("cached response found for ".ref($request), $request)
if $trace;
+ $self->_dump("cached response is ".ref($response), $response) if
$trace;
+ $self->trace_msg("transmit_request is returing a response from
cache\n");
+ ++$self->{cache_hit};
+ return $response;
+ }
+ ++$self->{cache_miss} if $request_key;
+ }
+ my $to = $self->go_timeout;
my $transmit_sub = sub {
$self->trace_msg("transmit_request\n");
local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
@@ -64,7 +91,7 @@
return $response;
};
- my $response = $self->_transmit_request_with_retries($request,
$transmit_sub);
+ $response = $self->_transmit_request_with_retries($request, $transmit_sub);
$self->trace_msg("transmit_request is returing a response itself\n") if
$response;
@@ -93,7 +120,7 @@
my $response = eval {
alarm($to) if $to;
- $self->receive_response_by_transport();
+ $self->receive_response_by_transport($request);
};
alarm(0) if $to;
@@ -114,6 +141,18 @@
}
} while ( $self->response_needs_retransmit($request, $response) );
+ my $frozen_response = delete $response->{meta}{frozen}
+ or warn "No meta frozen in request";
+
+ if ($frozen_response and my $go_cache = $self->{go_cache}) {
+ my $request_key = $self->get_cache_key_for_request($request);
+ if ($request_key) {
+ $self->trace_msg("receive_response added response to cache\n");
+ $go_cache->set($request_key, $frozen_response);
+ ++$self->{cache_store};
+ }
+ }
+
return $response;
}
@@ -173,6 +212,23 @@
}
+# return undef if we don't want to cache this request
+sub get_cache_key_for_request {
+ my ($self, $request) = @_;
+
+ # we only want to cache idempotent requests
+ # is_idempotent() is true if GOf_REQUEST_IDEMPOTENT or
GOf_REQUEST_READONLY set
+ return undef if not $request->is_idempotent;
+
+ # XXX would be nice to avoid the extra freeze here
+ my $key = $self->freeze_request($request, undef, 1);
+
+ #use Digest::MD5; warn "get_cache_key_for_request:
".Digest::MD5::md5_base64($key)."\n";
+
+ return $key;
+}
+
+
1;
=head1 NAME
Modified: dbi/trunk/lib/DBD/Gofer/Transport/null.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/null.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/null.pm Fri Sep 28 09:11:07 2007
@@ -18,6 +18,7 @@
__PACKAGE__->mk_accessors(qw(
pending_response
+ transmit_count
));
my $executor = DBI::Gofer::Execute->new();
@@ -25,6 +26,7 @@
sub transmit_request_by_transport {
my ($self, $request) = @_;
+ $self->transmit_count( ($self->transmit_count()||0) + 1 ); # just for tests
my $frozen_request = $self->freeze_request($request);
Modified: dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/stream.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/stream.pm Fri Sep 28 09:11:07 2007
@@ -148,7 +148,7 @@
my ($pid, $rfh, $efh, $cmd) = @{$connection}{qw(pid rfh efh cmd)};
my $errno = 0;
- my $frozen_response;
+ my $encoded_response;
my $stderr_msg;
$self->read_response_from_fh( {
@@ -160,14 +160,14 @@
$rfh => {
error => sub { warn "error reading response: $!"; $errno||=$!; 1 },
eof => sub { warn "eof on stdout" if 0; 1 },
- read => sub { $frozen_response .= $_;
($frozen_response=~s/\015\012$//) ? 1 : 0 },
+ read => sub { $encoded_response .= $_;
($encoded_response=~s/\015\012$//) ? 1 : 0 },
},
});
# if we got no output on stdout at all then the command has
# probably exited, possibly with an error to stderr.
# Turn this situation into a reasonably useful DBI error.
- if (not $frozen_response) {
+ if (not $encoded_response) {
my $msg = "No response received";
if (chomp $stderr_msg && $stderr_msg) {
$msg .= sprintf ", error reported by \"%s\" (pid %d%s): %s",
@@ -181,14 +181,16 @@
die "$msg\n";
}
- $self->trace_msg("Response received: $frozen_response\n",0)
+ $self->trace_msg("Response received: $encoded_response\n",0)
if $trace >= 4;
$self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0)
if $stderr_msg && $trace;
+ my $frozen_response = pack("H*", $encoded_response);
+
# XXX need to be able to detect and deal with corruption
- my $response = $self->thaw_response(pack("H*",$frozen_response));
+ my $response = $self->thaw_response($frozen_response);
if ($stderr_msg) {
# add stderr messages as warnings (for PrintWarn)
Modified: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm Fri Sep 28 09:11:07 2007
@@ -23,6 +23,7 @@
__PACKAGE__->mk_accessors(qw(
trace
+ keep_meta_frozen
serializer_obj
));
@@ -35,6 +36,7 @@
my ($class, $args) = @_;
$args->{trace} ||= $class->_init_trace;
$args->{serializer_obj} ||= DBI::Gofer::Serializer::Storable->new();
+ $args->{keep_meta_frozen} ||= 1 if $args->{go_cache};
my $self = bless {}, $class;
$self->$_( $args->{$_} ) for keys %$args;
$self->trace_msg("$class->new({ @{[ %$args ]} })\n") if $self->trace;
@@ -61,6 +63,11 @@
chomp $@;
die "Error freezing ".ref($data)." object: $@";
}
+
+ # stash the frozen data into the data structure itself
+ # to make life easy for the client caching code in
DBD::Gofer::Transport::Base
+ $data->{meta}{frozen} = $frozen if $self->keep_meta_frozen;
+
return $frozen;
}
# public aliases used by subclasses
@@ -73,14 +80,16 @@
my $data;
eval {
# check for and extract our gofer header and the info it contains
- $frozen_data =~ s/$packet_header_regex//o
+ (my $frozen = $frozen_data) =~ s/$packet_header_regex//o
or die "does not have gofer header\n";
my ($t_version) = $1;
$serializer ||= $self->{serializer_obj};
- $data = $serializer->deserialize($frozen_data);
+ $data = $serializer->deserialize($frozen);
die ref($serializer)."->deserialize didn't return a reference"
unless ref $data;
$data->{_transport}{version} = $t_version;
+
+ $data->{meta}{frozen} = $frozen_data if $self->keep_meta_frozen;
};
if ($@) {
chomp(my $err = $@);
@@ -92,6 +101,7 @@
}
$self->_dump("thawing $self->{trace} ".ref($data), $data)
if !$skip_trace and $self->trace;
+
return $data;
}
# public aliases used by subclasses
@@ -103,6 +113,10 @@
# and the tace level passed in
sub _dump {
my ($self, $label, $data) = @_;
+
+ # don't dump the binary
+ local $data->{meta}{frozen} if $data->{meta} && $data->{meta}{frozen};
+
if ($self->trace >= 2) {
require Data::Dumper;
local $Data::Dumper::Indent = 1;
Added: dbi/trunk/lib/DBI/Util/Cache.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Util/Cache.pm Fri Sep 28 09:11:07 2007
@@ -0,0 +1,113 @@
+package DBI::Util::Cache;
+
+# $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;
+
+=head1 NAME
+
+DBI::Util::Cache - a fast but very minimal subset of Cache::Memory
+
+=head1 DESCRIPTION
+
+Like Cache::Memory (part of the Cache distribution) but doesn't support any
fancy features.
+
+This module aims to be a very fast compatible strict sub-set for simple cases.
+
+=head1 METHODS WITH CHANGES
+
+=head2 new
+
+All options except C<namespace> are ignored.
+
+=head2 set
+
+Doesn't support expiry.
+
+=head2 purge
+
+Same as clear() - deletes everything in the namespace.
+
+=head1 METHODS WITHOUT CHANGES
+
+=over
+
+=item clear
+
+=item count
+
+=item exists
+
+=item remove
+
+=back
+
+=head1 UNSUPPORTED METHODS
+
+If it's not listed above, it's not supported.
+
+=cut
+
+our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+
+my %cache;
+
+sub new {
+ my ($class, %options ) = @_;
+ $options{namespace} ||= 'Default';
+ my $self = bless {
+ #_cache => \%cache, # canbe handy for debugging/dumping
+ %options,
+ } => $class;
+ $self->clear;
+ return $self;
+}
+
+sub set {
+ my ($self, $key, $value) = @_;
+ $cache{ $self->{namespace} }->{$key} = $value;
+}
+
+sub get {
+ my ($self, $key) = @_;
+ return $cache{ $self->{namespace} }->{$key};
+}
+
+sub exists {
+ my ($self, $key) = @_;
+ return exists $cache{ $self->{namespace} }->{$key};
+}
+
+sub remove {
+ my ($self, $key) = @_;
+ return delete $cache{ $self->{namespace} }->{$key};
+}
+
+sub purge {
+ return shift->clear;
+}
+
+sub clear {
+ $cache{ shift->{namespace} } = {};
+}
+
+sub count {
+ return scalar keys %{ $cache{ shift->{namespace} } };
+}
+
+sub size {
+ my $c = $cache{ shift->{namespace} };
+ my $size = 0;
+ while ( my ($k,$v) = each %$c ) {
+ $size += length($k) + length($v);
+ }
+ return $size;
+}
+
+1;
Added: dbi/trunk/t/87gofer_cache.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/87gofer_cache.t Fri Sep 28 09:11:07 2007
@@ -0,0 +1,70 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use DBI;
+use Data::Dumper;
+use Test::More;
+use DBI::Util::Cache;
+
+plan 'no_plan';
+
+my @cache_classes = qw(DBI::Util::Cache);
+push @cache_classes, "Cache::Memory" if eval { require Cache::Memory };
+
+for my $cache_class (@cache_classes) {
+ my $cache_obj = $cache_class->new();
+ run_tests($cache_obj);
+}
+
+sub run_tests {
+ my $cache_obj = shift;
+
+ my $tmp;
+ my $dsn = "dbi:Gofer:transport=null;policy=classic;dsn=dbi:ExampleP:";
+ print " using $cache_obj for $dsn\n";
+
+ is $cache_obj->count, 0, 'cache should be empty to start';
+
+ my $dbh = DBI->connect($dsn, undef, undef, {
+ go_cache => $cache_obj,
+ RaiseError => 1, PrintError => 0, ShowErrorStatement => 1,
+ } );
+ ok my $go_transport = $dbh->{go_transport};
+
+ # setup
+ $cache_obj->clear;
+ is $cache_obj->count, 0, 'cache should be empty after clear';
+
+ $go_transport->transmit_count(0);
+ is $go_transport->transmit_count, 0, 'transmit_count should be 0';
+
+ $go_transport->cache_hit(0);
+ $go_transport->cache_miss(0);
+ $go_transport->cache_store(0);
+
+ # request 1
+ ok my $rows1 = $dbh->selectall_arrayref("select name from ?", {}, ".");
+ cmp_ok $cache_obj->count, '>', 0, 'cache should not be empty after select';
+
+ is $go_transport->cache_hit, 0;
+ is $go_transport->cache_miss, 1;
+ is $go_transport->cache_store, 1;
+
+ is $go_transport->transmit_count, 1, 'should make 1 round trip';
+ $go_transport->transmit_count(0);
+ is $go_transport->transmit_count, 0, 'transmit_count should be 0';
+
+ # request 2
+ ok my $rows2 = $dbh->selectall_arrayref("select name from ?", {}, ".");
+ is_deeply $rows2, $rows1;
+ is $go_transport->transmit_count, 0, 'should make 1 round trip';
+
+ is $go_transport->cache_hit, 1;
+ is $go_transport->cache_miss, 1;
+ is $go_transport->cache_store, 1;
+
+}
