On 10/11/06, Brandon Black <[EMAIL PROTECTED]> wrote:
Of course, it would help if I actually attached the patch :)
Attached is a rough draft patch against the DBI trunk for some rudimentary sth cache management
Of course, it would help if I actually attached the patch :)
=== DBI.pm
==================================================================
--- DBI.pm (revision 11195)
+++ DBI.pm (local)
@@ -406,6 +406,7 @@
preparse => { }, # XXX
prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0x2200 },
prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0x2200 },
+ manage_sth_cache=> { U =>[1,1], },
selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 },
@@ -1258,6 +1259,7 @@
substr($imp_class,-4,4) = '::st';
my $app_class = ref $dbh;
substr($app_class,-4,4) = '::st';
+ $attr->{Created} ||= time; # stamp the creation time
_new_handle($app_class, $dbh, $attr, $imp_data, $imp_class);
}
@@ -1631,6 +1633,39 @@
return [EMAIL PROTECTED];
}
+ sub manage_sth_cache {
+ my ($dbh) = @_;
+
+ my $cache = $dbh->FETCH('CachedKids') or return;
+ my $now = time;
+
+ my $max_stmts = $dbh->FETCH('dbi_sth_cache_max_stmts');
+ my $max_age = $dbh->FETCH('dbi_sth_cache_max_age');
+ $max_stmts = 1000 if !defined $max_stmts;
+ $max_age = 86400 if !defined $max_age;
+
+ my $num_stmts = scalar keys %$cache;
+ my $to_delete = ($max_stmts < $num_stmts)
+ ? $num_stmts - $max_stmts
+ : 0;
+ my $cutoff = $max_age
+ ? $now - $max_age
+ : 0;
+
+ # there are probably more efficient ways to implement this if it becomes a problem
+ foreach my $stmt (sort { $cache->{$a}->{Created} <=> $cache->{$b}->{Created} } keys %$cache) {
+ if($to_delete) {
+ $to_delete--;
+ }
+ elsif($cache->{$stmt}->{Created} > $cutoff) {
+ last;
+ }
+ delete $cache->{$stmt};
+ }
+
+ $dbh->STORE('dbi_sth_cache_last_checked', $now);
+ }
+
sub prepare_cached {
my ($dbh, $statement, $attr, $if_active) = @_;
# Needs support at dbh level to clear cache before complaining about
@@ -1638,6 +1673,15 @@
# the template must handle clearing the cache themselves.
my $cache = $dbh->FETCH('CachedKids');
$dbh->STORE('CachedKids', $cache = {}) unless $cache;
+
+ if(my $check_interval = $dbh->FETCH('dbi_sth_cache_check_interval')) {
+ my $last_checked = $dbh->FETCH('dbi_sth_cache_last_checked') || 0;
+ if((my $now = time) - $last_checked >= $check_interval) {
+ $dbh->STORE('dbi_sth_cache_last_checked', $now);
+ $dbh->manage_sth_cache();
+ }
+ }
+
my @attr_keys = ($attr) ? sort keys %$attr : ();
my $key = ($attr) ? join("~~", $statement, @attr_keys, @[EMAIL PROTECTED]) : $statement;
my $sth = $cache->{$key};
@@ -5196,6 +5240,20 @@
The C<take_imp_data> method was added in DBI 1.36 but wasn't useful till 1.49.
+=item C<manage_sth_cache>
+
+ $dbh->manage_sth_cache;
+
+Invoking this method causes the $dbh to clean up the statement cache used
+by C<prepare_cached>. It will remove the oldest statements in the cache
+until no more than C<dbi_sth_cache_max_stmts> (default 1000) are left,
+and then remove any that are older than C<dbi_sth_cache_max_age>
+(default 86400 (1 day)). You could invoke this periodically in order to
+keep the statement cache from growing indefinitely when DBI is used by
+a long-running process. Another alternative is to set the attribute
+C<dbi_sth_cache_check_interval>, which will cause it to be automatically
+periodically invoked for you by C<prepare_cached>.
+
=back
@@ -5335,7 +5393,27 @@
Returns the username used to connect to the database.
+=item C<dbi_sth_cache_max_age> (integer)
+Sets the maximum age (in seconds) of a statement in the sth cache used by
+C<prepare_cached>. Defaults to 86400 (1 day). Only takes effect when
+you explicitly call the dbh method C<manage_sth_cache>, or you set the
+related attribute C<dbi_sth_cache_check_interval>.
+
+=item C<dbi_sth_cache_max_stmts> (integer)
+
+Sets the maximum number of statements allowed in the sth cache used by
+C<prepare_cached>. Defaults to 1000. Only takes effect when
+you explicitly call the dbh method C<manage_sth_cache>, or you set the
+related attribute C<dbi_sth_cache_check_interval>.
+
+=item C<dbi_sth_cache_check_interval> (integer)
+
+If this attribute is set, it causes C<prepare_cached> to automatically
+invoke C<manage_sth_cache> periodically before doing its normal work.
+The value is the minimum time between invocations. By default
+C<prepare_cached> never invokes C<manage_sth_cache>.
+
=back
=== t/16sth_cache.t
==================================================================
--- t/16sth_cache.t (revision 11195)
+++ t/16sth_cache.t (local)
@@ -0,0 +1,138 @@
+#!perl -w
+
+use strict;
+
+use Test::More tests => 19;
+
+## ----------------------------------------------------------------------------
+## 16sth_cache.t
+## ----------------------------------------------------------------------------
+
+## If you're getting unexpected failures here, try setting the environment
+## variable "DBI_TEST_SKIP_TIMING" (more details below...)
+
+BEGIN {
+ use_ok('DBI');
+}
+
+# Makes a new dbh with the given attrs
+sub make_dbh {
+ my %attrs = @_;
+ my $dbh = DBI->connect('dbi:NullP:dummy', '', '', \%attrs);
+ # no need to artificially inflate test count here...
+ die "not a dbh" if !$dbh->isa('DBI::db');
+ return $dbh;
+}
+
+sub sth_count { scalar keys %{shift->{CachedKids}} }
+
+# Makes a new unique statement every call
+{
+ my $_num_stmts = 0;
+ sub make_stmt {
+ my $dbh = shift;
+ my $sth = $dbh->prepare_cached('SELECT 1 + ' . $_num_stmts++);
+ # no need to artificially inflate test count here...
+ die "not an sth" if !$sth->isa('DBI::st');
+ return $sth;
+ }
+ sub reset_stmts { $_num_stmts = 0; }
+}
+
+# ---
+
+{
+ my $dbh = make_dbh;
+ make_stmt($dbh) for (1 .. 1007);
+ is(sth_count($dbh), 1007, 'no effect when not used');
+}
+
+# ---
+
+{
+ my $dbh = make_dbh;
+ make_stmt($dbh) for (1 .. 1007);
+ $dbh->manage_sth_cache;
+ is(sth_count($dbh), 1000, 'default max_stmts works');
+}
+
+# ---
+
+{
+ my $dbh = make_dbh(dbi_sth_cache_max_stmts => 1024);
+ make_stmt($dbh) for (1 .. 1007);
+ $dbh->manage_sth_cache;
+ is(sth_count($dbh), 1007, 'explicit max_stmts 1');
+ make_stmt($dbh) for (1 .. 21);
+ is(sth_count($dbh), 1028, 'explicit max_stmts 2');
+ $dbh->manage_sth_cache;
+ is(sth_count($dbh), 1024, 'explicit max_stmts 3');
+}
+
+SKIP: {
+ # In theory, if the test machine is really really slow,
+ # it will cause problems for these tests.
+ # This environment variable will skip them:
+
+ skip "Timing-sensitive tests", 7 if $ENV{DBI_TEST_SKIP_TIMING};
+
+ # ---
+
+ {
+ my $dbh = make_dbh(dbi_sth_cache_max_age => 1);
+ make_stmt($dbh) for (1 .. 3);
+ is(sth_count($dbh), 3, 'explicit max_age 1');
+ $dbh->manage_sth_cache;
+ is(sth_count($dbh), 3, 'explicit max_age 2');
+ sleep(1);
+ $dbh->manage_sth_cache;
+ is(sth_count($dbh), 0, 'explicit max_age 3');
+ }
+
+ # ---
+
+ {
+ my $dbh = make_dbh(dbi_sth_cache_check_interval => 1);
+ make_stmt($dbh) for (1 .. 1024);
+ is(sth_count($dbh), 1024, 'auto defaults 1');
+ sleep(1);
+ make_stmt($dbh);
+ is(sth_count($dbh), 1001, 'auto defaults 2');
+ }
+
+ # ---
+
+ {
+ my $dbh = make_dbh(
+ dbi_sth_cache_check_interval => 2,
+ dbi_sth_cache_max_age => 1
+ );
+ make_stmt($dbh) for (1 .. 5);
+ is(sth_count($dbh), 5, 'auto age 1');
+ sleep(2);
+ make_stmt($dbh);
+ is(sth_count($dbh), 1, 'auto age 2');
+ }
+
+ # ---
+
+ {
+ reset_stmts; # this test cares about the numbers
+ my $dbh = make_dbh( dbi_sth_cache_max_age => 4 );
+ make_stmt($dbh) for (1 .. 5);
+ is(sth_count($dbh), 5, 'age ordering 1');
+ sleep(3);
+ make_stmt($dbh) for (1 .. 3);
+ is(sth_count($dbh), 8, 'age ordering 2');
+ sleep(2);
+ $dbh->manage_sth_cache;
+ is(sth_count($dbh), 3, 'age ordering 3');
+ foreach my $stmt ( keys %{$dbh->{CachedKids}} ) {
+ $stmt =~ m/^SELECT 1 \+ (\d+)/;
+ my $digit = $1 || 0;
+ ok($digit >= 5, 'age ordering values');
+ }
+ }
+}
+
+1;
