Author: timbo
Date: Tue Oct 16 05:36:56 2007
New Revision: 10086
Added:
dbi/trunk/lib/DBI/Util/CacheMemory.pm
- copied, changed from r10085, /dbi/trunk/lib/DBI/Util/Cache.pm
Removed:
dbi/trunk/lib/DBI/Util/Cache.pm
Modified:
dbi/trunk/Changes
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBD/Proxy.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/t/87gofer_cache.t
Log:
Add client-side caching to DBD::Gofer.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Oct 16 05:36:56 2007
@@ -48,9 +48,12 @@
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
+ Added client-side caching to DBD::Gofer. Can use any cache with
+ get($k)/set($k,$v) methods, including all the Cache and Cache::Cache
+ distribution modules plus Cache::Memcached, Cache::FastMmap etc.
+ Works for all transports. Overridable per handle.
+
+ Added DBI::Util::CacheMemory 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
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Tue Oct 16 05:36:56 2007
@@ -63,7 +63,7 @@
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 very�cut-down version of
Class::Accessor::Fast
-lib/DBI/Util/Cache.pm A very cut-down version of Cache::Memory
+lib/DBI/Util/CacheMemory.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
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Tue Oct 16 05:36:56 2007
@@ -55,9 +55,12 @@
DBI->setup_driver('DBD::Gofer');
unless ($methods_already_installed++) {
- DBD::Gofer::db->install_method('go_dbh_method', { O=> 0x0004 }); #
IMA_KEEP_ERR
- DBD::Gofer::st->install_method('go_sth_method', { O=> 0x0004 }); #
IMA_KEEP_ERR
- DBD::Gofer::st->install_method('go_clone_sth', { O=> 0x0004 }); #
IMA_KEEP_ERR
+ my $opts = { O=> 0x0004 }; # IMA_KEEP_ERR
+ DBD::Gofer::db->install_method('go_dbh_method', $opts);
+ DBD::Gofer::st->install_method('go_sth_method', $opts);
+ DBD::Gofer::st->install_method('go_clone_sth', $opts);
+ DBD::Gofer::db->install_method('go_cache', $opts);
+ DBD::Gofer::st->install_method('go_cache', $opts);
}
my($class, $attr) = @_;
@@ -77,6 +80,16 @@
}
+ sub go_cache {
+ my $h = shift;
+ $h->{go_cache} = shift if @_;
+ # return handle's override go_cache, if it has one
+ return $h->{go_cache} if defined $h->{go_cache};
+ # or else the transports default go_cache
+ return $h->{go_transport}->{go_cache};
+ }
+
+
sub set_err_from_response { # set error/warn/info and propagate warnings
my ($h, $response) = @_;
if (my $warnings = $response->warnings) {
@@ -168,10 +181,15 @@
my $go_policy = $go_attr{go_policy};
if ($go_attr{go_cache} and not ref $go_attr{go_cache}) { # if not a
cache object already
- $go_attr{go_cache} = eval { require DBI::Util::Cache;
DBI::Util::Cache->new() };
+ my $cache_class = $go_attr{go_cache};
+ $cache_class = "DBI::Util::CacheMemory" if $cache_class eq '1';
+ _load_class($cache_class)
+ or return $drh->set_err($DBI::stderr, "Can't load $cache_class
$@");
+ $go_attr{go_cache} = eval { $cache_class->new() }
+ or $drh->set_err(0, "Can't instanciate $cache_class: $@"); #
warning
}
- # but delete any other attributes that don't appy to transport
+ # delete any other attributes that don't apply to transport
my $go_connect_method = delete $go_attr{go_connect_method};
my $transport_class = delete $go_attr{go_transport}
@@ -270,6 +288,9 @@
my $transport = $dbh->{go_transport}
or return $dbh->set_err($DBI::stderr, "Not connected (no
transport)");
+ local $transport->{go_cache} = $dbh->{go_cache}
+ if defined $dbh->{go_cache};
+
my ($response, $retransmit_sub) =
$transport->transmit_request($request);
$response ||= $transport->receive_response($request, $retransmit_sub);
$dbh->{go_response} = $response
@@ -336,7 +357,7 @@
my $cache;
my $cache_key;
if (my $cache_it = $dbh->{go_policy}->$policy_name(undef, $dbh,
@_)) {
- $cache = $dbh->{go_cache} ||= {};
+ $cache = $dbh->{go_meta_cache} ||= {}; # keep separate from
go_cache
$cache_key = sprintf "%s_wa%d(%s)", $policy_name, wantarray||0,
join(",\t", map { # XXX basic but sufficient for now
!ref($_) ? DBI::neat($_,1e6)
@@ -505,6 +526,7 @@
|| $dbh->{go_prepare_method}
|| $policy->prepare_method($dbh, $statement, $attr)
|| 'prepare'; # e.g. for code not using placeholders
+ my $go_cache = delete $attr->{go_cache};
# set to undef if there are no attributes left for the actual prepare
call
$attr = undef if $attr and not %$attr;
@@ -516,6 +538,7 @@
go_transport => $dbh->{go_transport},
go_policy => $policy,
go_last_insert_id_args => $lii_args,
+ go_cache => $go_cache,
});
$sth->STORE(Active => 0);
@@ -536,6 +559,7 @@
}, $if_active);
}
+ *go_cache = \&DBD::Gofer::go_cache;
}
@@ -588,6 +612,9 @@
my $transport = $sth->{go_transport}
or return $sth->set_err($DBI::stderr, "Not connected (no
transport)");
+ local $transport->{go_cache} = $sth->{go_cache}
+ if defined $sth->{go_cache};
+
my ($response, $retransmit_sub) =
$transport->transmit_request($request);
$response ||= $transport->receive_response($request, $retransmit_sub);
$sth->{go_response} = $response
@@ -765,6 +792,7 @@
return $sth->go_sth_method($attr);
}
+ *go_cache = \&DBD::Gofer::go_cache;
}
1;
@@ -853,7 +881,8 @@
=head3 Caching
-Not yet implemented, but the single request-response architecture lends itself
to caching.
+Client-side caching is as simple as adding "C<cache=1>" to the DSN.
+This feature alone can be worth using DBD::Gofer for.
=head3 Fewer Network Round-trips
@@ -1044,7 +1073,7 @@
=head3 http
-See the GoferTransport-http distribution on CPAN.
+See the GoferTransport-http distribution on CPAN:
http://search.cpan.org/dist/GoferTransport-http/
=head3 Gearman
@@ -1059,7 +1088,7 @@
Other attributes can be specified in the DSN to configure DBD::Gofer and/or the
Gofer transport module being used. The main attributes after C<transport>, are
-C<url> and C<policy>. These are described below.
+C<url> and C<policy>. These and other attributes are described below.
=head2 Using DBI_AUTOPROXY
@@ -1072,8 +1101,92 @@
export DBI_AUTOPROXY="dbi:Gofer:transport=stream;url=ssh:[EMAIL PROTECTED]"
+=head2 Connection Attributes
+
+These attributes can be specified in the DSN. They can also be passed in the
+\%attr parameter of the DBI connect method by adding a "C<go_>" prefix to the
name.
+
+=head3 transport
+
+Specifies the Gofer transport class to use. Required. See L</TRANSPORTS> above.
+
+If the value does not include C<::> then "C<DBD::Gofer::Transport::>" is
prefixed.
+
+The transport object can be accessed via $h->{go_transport}.
+
+=head3 dsn
+
+Specifies the DSN for the remote side to connect to. Required, and must be
last.
+
+=head3 url
+
+Used to tell the transport where to connect to. The exact form of the value
depends on the transport used.
+
+=head3 policy
+
+Specifies the policy to use. See L</CONFIGURING BEHAVIOUR POLICY>.
+
+If the value does not include C<::> then "C<DBD::Gofer::Policy>" is prefixed.
+
+The policy object can be accessed via $h->{go_policy}.
+
+=head3 timeout
+
+Specifies a timeout, in seconds, to use when waiting for responses from the
server side.
+
+=head3 retry_limit
+
+Specifies the number of times a failed request will be retried. Default is 0.
+
+=head3 retry_hook
+
+Specifies a code reference to be called to decide if a failed request should
be retried.
+The code reference is called like this:
+
+ $transport = $h->{go_transport};
+ $retry = $transport->go_retry_hook->($request, $response, $transport);
+
+If it returns true then the request will be retried, upto the C<retry_limit>.
+If it returns a false but defined value then the request will not be retried.
+If it returns undef then the default behaviour will be used, as if
C<retry_hook>
+had not been specified.
+
+The default behaviour is to retry requests where $request->is_idempotent is
true,
+or the error message matches C</induced by DBI_GOFER_RANDOM/>.
+
+=head3 cache
+
+Specifies that client-side caching should be performed. The value is the name
+of a cache class to use.
+
+Any class implementing get($key) and set($key, $value) methods can be used.
+That includes a great many powerful caching classes on CPAN, including the
+Cache and Cache::Cache distributions.
+
+You can use "C<cache=1>" is a shortcut for "C<cache=DBI::Util::CacheMemory>".
+See L<DBI::Util::CacheMemory> for a description of this simple fast default
cache.
+
+The cache object can be accessed via $h->go_cache. For example:
+
+ $dbh->go_cache->clear; # free up memory being used by the cache
+
+The cache keys are the frozen (serialized) requests, and the values are the
+frozen responses.
+
+The default behaviour is to only use the cache for requests where
+$request->is_idempotent is true (i.e., the dbh has the ReadOnly attribute set
+or the SQL statement is obviously a SELECT without a FOR UPDATE clause.)
+
+For even more control you can use the C<go_cache> attribute to pass in an
+instanciated cache object. Individual methods, including prepare(), can also
+specify alternative caches via the C<go_cache> attribute. For example, to
+specify no caching for a particular query, you could use
+
+ $sth = $dbh->prepare( $sql, { go_cache => 0 } );
+
+This can be used to implement different caching policies for different
statements.
-=head1 CONFIGURING VIA POLICY
+=head1 CONFIGURING BEHAVIOUR POLICY
DBD::Gofer supports a 'policy' mechanism that allows you to fine-tune the
number of round-trips to the Gofer server.
The policies are grouped into classes (which may be subclassed) and referenced
by the name of the class.
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 Tue Oct 16 05:36:56 2007
@@ -54,19 +54,26 @@
my ($self, $request) = @_;
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;
+ my ($go_cache, $request_cache_key);
+ if ($go_cache = $self->{go_cache}) {
+ $request_cache_key
+ = $request->{meta}{request_cache_key}
+ = $self->get_cache_key_for_request($request);
+ if ($request_cache_key) {
+ my $frozen_response = eval { $go_cache->get($request_cache_key) };
+ if ($frozen_response) {
+ $response = $self->thaw_response($frozen_response);
+ if (my $trace = $self->trace) {
+ $self->_dump("cached response found for ".ref($request),
$request);
+ $self->_dump("cached response is ".ref($response),
$response);
+ $self->trace_msg("transmit_request is returing a response
from cache\n");
+ }
+ ++$self->{cache_hit};
+ return $response;
+ }
+ warn $@ if $@;
+ ++$self->{cache_miss};
}
- ++$self->{cache_miss} if $request_key;
}
my $to = $self->go_timeout;
@@ -95,6 +102,12 @@
$response = $self->_transmit_request_with_retries($request, $transmit_sub);
+ if ($response) {
+ my $frozen_response = delete $response->{meta}{frozen};
+ $self->_store_response_in_cache($frozen_response, $request_cache_key)
+ if $go_cache;
+ }
+
$self->trace_msg("transmit_request is returing a response itself\n") if
$response;
return $response unless wantarray;
@@ -143,19 +156,10 @@
}
} while ( $self->response_needs_retransmit($request, $response) );
- my $frozen_response = delete $response->{meta}{frozen};
-
- if (my $go_cache = $self->{go_cache}) {
-
- # new() ensures that enabling go_cache also enabled keep_meta_frozen
- warn "No meta frozen in request" if !$frozen_response;
-
- my $request_key = $self->get_cache_key_for_request($request);
- if ($frozen_response && $request_key) {
- $self->trace_msg("receive_response added response to cache\n");
- $go_cache->set($request_key, $frozen_response);
- ++$self->{cache_store};
- }
+ if ($response) {
+ my $frozen_response = delete $response->{meta}{frozen};
+ $self->_store_response_in_cache($frozen_response,
$request->{meta}{request_cache_key})
+ if $self->{go_cache};
}
return $response;
@@ -218,6 +222,7 @@
# return undef if we don't want to cache this request
+# subclasses may use more specialized rules
sub get_cache_key_for_request {
my ($self, $request) = @_;
@@ -234,6 +239,23 @@
}
+sub _store_response_in_cache {
+ my ($self, $frozen_response, $request_cache_key) = @_;
+ my $go_cache = $self->{go_cache}
+ or return;
+
+ # new() ensures that enabling go_cache also enables keep_meta_frozen
+ warn "No meta frozen in response" if !$frozen_response;
+ warn "No request_cache_key" if !$request_cache_key;
+
+ if ($frozen_response && $request_cache_key) {
+ $self->trace_msg("receive_response added response to cache\n");
+ eval { $go_cache->set($request_cache_key, $frozen_response) };
+ warn $@ if $@;
+ ++$self->{cache_store};
+ }
+}
+
1;
=head1 NAME
Modified: dbi/trunk/lib/DBD/Proxy.pm
==============================================================================
--- dbi/trunk/lib/DBD/Proxy.pm (original)
+++ dbi/trunk/lib/DBD/Proxy.pm Tue Oct 16 05:36:56 2007
@@ -741,7 +741,7 @@
=head1 DESCRIPTION
DBD::Proxy is a Perl module for connecting to a database via a remote
-DBI driver.
+DBI driver. See L<DBD::Gofer> for an alternative with different trade-offs.
This is of course not needed for DBI drivers which already
support connecting to a remote database, but there are engines which
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Tue Oct 16 05:36:56 2007
@@ -85,12 +85,14 @@
return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY);
}
- # else check if all statements are select statement
+ # else check if all statements are SELECT statement that don't include FOR
UPDATE
my @statements = $self->statements;
# XXX this is very minimal for now, doesn't even allow comments before the
select
# (and can't ever work for "exec stored_procedure_name" kinds of
statements)
# XXX it also doesn't deal with multiple statements: prepare("select foo;
update bar")
- return 1 if @statements == grep { m/^ \s* SELECT \b/xmsi } @statements;
+ return 1 if @statements == grep {
+ m/^ \s* SELECT \b /xmsi && !m/ \b FOR \s+ UPDATE \b /xmsi
+ } @statements;
return 0;
}
Copied: dbi/trunk/lib/DBI/Util/CacheMemory.pm (from r10085,
/dbi/trunk/lib/DBI/Util/Cache.pm)
==============================================================================
--- /dbi/trunk/lib/DBI/Util/Cache.pm (original)
+++ dbi/trunk/lib/DBI/Util/CacheMemory.pm Tue Oct 16 05:36:56 2007
@@ -1,4 +1,4 @@
-package DBI::Util::Cache;
+package DBI::Util::CacheMemory;
# $Id$
#
@@ -12,7 +12,7 @@
=head1 NAME
-DBI::Util::Cache - a very fast but very minimal subset of Cache::Memory
+DBI::Util::CacheMemory - a very fast but very minimal subset of Cache::Memory
=head1 DESCRIPTION
Modified: dbi/trunk/t/87gofer_cache.t
==============================================================================
--- dbi/trunk/t/87gofer_cache.t (original)
+++ dbi/trunk/t/87gofer_cache.t Tue Oct 16 05:36:56 2007
@@ -8,24 +8,29 @@
use DBI;
use Data::Dumper;
use Test::More;
-use DBI::Util::Cache;
+use DBI::Util::CacheMemory;
+
+plan skip_all => "Gofer DBI_AUTOPROXY" if $ENV{DBI_AUTOPROXY} =~ /^dbi:Gofer/i;
plan 'no_plan';
-my @cache_classes = qw(DBI::Util::Cache);
+
+my $dsn = "dbi:Gofer:transport=null;policy=classic;dsn=dbi:ExampleP:";
+
+my @cache_classes = qw(DBI::Util::CacheMemory);
push @cache_classes, "Cache::Memory" if eval { require Cache::Memory };
-push @cache_classes, "1";
+push @cache_classes, "1"; # test alias for DBI::Util::CacheMemory
for my $cache_class (@cache_classes) {
my $cache_obj = ($cache_class eq "1") ? $cache_class : $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";
my $dbh = DBI->connect($dsn, undef, undef, {
@@ -67,7 +72,37 @@
is $go_transport->cache_hit, $expected;
is $go_transport->cache_miss, $expected;
is $go_transport->cache_store, $expected;
-
}
+
+print "test per-sth go_cache\n";
+
+my $dbh = DBI->connect($dsn, undef, undef, {
+ go_cache => 1,
+ RaiseError => 1, PrintError => 0, ShowErrorStatement => 1,
+} );
+ok my $go_transport = $dbh->{go_transport};
+ok my $dbh_cache = $go_transport->go_cache;
+$dbh_cache->clear; # discard ping from connect
+
+my $cache2 = DBI::Util::CacheMemory->new( namespace => "foo2" );
+ok $cache2;
+ok $cache2 != $dbh_cache;
+
+my $sth1 = $dbh->prepare("select name from ?");
+is $sth1->go_cache, $dbh_cache;
+is $dbh_cache->size, 0;
+ok $dbh->selectall_arrayref($sth1, undef, ".");
+ok $dbh_cache->size;
+
+my $sth2 = $dbh->prepare("select * from ?", { go_cache => $cache2 });
+is $sth2->go_cache, $cache2;
+is $cache2->size, 0;
+ok $dbh->selectall_arrayref($sth2, undef, ".");
+ok $cache2->size;
+
+cmp_ok $cache2->size, '>', $dbh_cache->size;
+
+
+
1;
