In the thread here:

http://thread.gmane.org/gmane.comp.lang.perl.modules.dbi.rose-db-object/2303/focus=2314

John suggested a new_or_cached() method and I agreed it was a good idea.

Attached is a patch against Rose::DB svn trunk that implements that method and 2
 others (ping() and cache_ttl()). Test and docs included.

John, please let me know if this was the direction you wanted to take. I'd be
happy to re-work it.

pek

-- 
Peter Karman  .  http://peknet.com/  .  [EMAIL PROTECTED]
Index: t/dbh_cache.t
===================================================================
--- t/dbh_cache.t       (revision 0)
+++ t/dbh_cache.t       (revision 0)
@@ -0,0 +1,40 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+BEGIN {
+    require Test::More;
+    eval { require DBD::SQLite };
+
+    if ( $@ || $DBD::SQLite::VERSION < 1.08 || $ENV{'RDBO_NO_SQLITE'} ) {
+        Test::More->import(
+            skip_all => $ENV{'RDBO_NO_SQLITE'}
+            ? 'SQLite tests disabled'
+            : 'Missing DBD::SQLite 1.08+'
+        );
+    }
+    elsif ( $DBD::SQLite::VERSION == 1.13 )
+    {
+        Test::More->import( skip_all => 'DBD::SQLite 1.13 is broken' );
+    }
+    else {
+        Test::More->import( tests => 5 );
+    }
+}
+
+BEGIN {
+    require 't/test-lib.pl';
+    use_ok('Rose::DB');
+}
+
+Rose::DB->default_domain('test');
+Rose::DB->default_type('sqlite_admin');
+
+ok( my $db = Rose::DB->new_or_cached(), "new_or_cached db" );
+
+ok( ref $db && $db->isa('Rose::DB'), 'new()' );
+
+ok( my $db2 = Rose::DB->new_or_cached(), "new_or_cached db2" );
+
+is( $db->dbh, $db2->dbh, "same DBI handle used" );
+
Index: lib/Rose/DB.pm
===================================================================
--- lib/Rose/DB.pm      (revision 1470)
+++ lib/Rose/DB.pm      (working copy)
@@ -53,6 +53,20 @@
   ],
 );
 
+use Rose::Class::MakeMethods::Generic 
+(
+  hash   => 
+  [
+    db_cache        => { interface => 'get_set_all' },
+    db_cache_names  => { interface => 'keys', hash_key => 'db_cache' },
+    db_cache_values => { interface => 'values', hash_key => 'db_cache' },
+    db_cache_exists => { interface => 'exists', hash_key => 'db_cache' },
+    delete_db_cache => { interface => 'delete', hash_key => 'db_cache' },
+    clear_db_cache  => { interface => 'clear', hash_key => 'db_cache' },
+    reset_db_cache  => { interface => 'reset', hash_key => 'db_cache' },
+  ],
+);
+
 __PACKAGE__->default_domain('default');
 __PACKAGE__->default_type('default');
 
@@ -119,6 +133,7 @@
     'type',
     'date_handler',
     'server_time_zone',
+    'cache_ttl',
     #'class',
   ],
 
@@ -366,6 +381,64 @@
   return $self;
 }
 
+sub ping {
+    my $self       = shift;
+    my $dbh        = shift || $self->dbh;
+    my $ret        = 0;
+    my $prev_alarm = 0;
+    eval {
+        local $SIG{__DIE__}  = sub { return (0); };
+        local $SIG{__WARN__} = sub { return (0); };
+        local $SIG{ALRM}     = sub { return (0); };
+
+        $prev_alarm = CORE::alarm(2);
+        $ret = $dbh->do("select 1");
+    };
+    $prev_alarm ? CORE::alarm($prev_alarm) : CORE::alarm(0);
+
+    return ($@) ? 0 : $ret;
+}
+
+sub new_or_cached
+{
+  my($self) = shift;
+  my $db = $self->new(@_);
+  if (!$self->db_cache)
+  {
+    $self->db_cache({});
+  }
+      
+  my $id_str = join( '::', $db->domain, $db->type, $db->dsn );
+  my $cache = $self->db_cache_exists($id_str)
+            ? $self->db_cache->{$id_str}
+            : {};
+
+  if (    defined $cache->{dbh}
+      and ( time() - $cache->{birthday} ) < $db->cache_ttl
+      and $self->ping( $cache->{dbh} ) )
+  {
+     $cache->{access_count}++;
+     $db->dbh( $cache->{dbh} );
+  }
+  else {
+     if ( exists $cache->{dbh} ) {
+       $cache->{dbh}->disconnect;  # explicitly disconnect old handle
+     }
+     my $dbh = $db->dbh;
+     $cache = {
+              dbh          => $dbh,
+              birthday     => time(),
+              access_count => 1,
+              id_str       => $id_str,
+     };
+     $self->db_cache->{$id_str} = $cache;
+  }
+    
+  $db->{'cached_dbh'} = 1;
+
+  return $db;
+}
+
 sub class 
 {
   my($self) = shift;
@@ -506,6 +579,8 @@
 sub init_domain { shift->{'_origin_class'}->default_domain }
 sub init_type   { shift->{'_origin_class'}->default_type }
 
+sub init_cache_ttl { 3600 * 24 }
+
 sub init_date_handler { Rose::DateTime::Format::Generic->new }
 sub init_server_time_zone { 'floating' }
 
@@ -726,6 +801,8 @@
 sub release_dbh
 {
   my($self, %args) = @_;
+  
+  return 1 if $self->{'cached_dbh'};
 
   my $dbh = $self->{'dbh'} or return 0;
 
@@ -2759,6 +2836,14 @@
 
 You can change this mapping with the L<driver_class|/driver_class> class 
method.
 
+=item B<new_or_cached PARAMS>
+
+Behaves like new() but uses a cached DBI handle. You can set the time to live
+for the cached handle with the L<cache_ttl> method. Every time new_or_cached()
+is called, the DBI handle is tested with the ping() method to ensure the 
connection
+is still alive. If ping() fails, the cached handle is disconnect()ed and a
+new DBI handle is created and cached.
+
 =back
 
 =head1 OBJECT METHODS
@@ -2810,6 +2895,15 @@
 
 Note: when setting this attribute, you I<must> pass in a L<DBI> database 
handle that has the same L<driver|/driver> as the object.  For example, if the 
L<driver|/driver> is C<mysql> then the L<DBI> database handle must be connected 
to a MySQL database.  Passing in a mismatched database handle will cause a 
fatal error.
 
+=item B<ping>
+
+Tickle the L<DBI> database handle to ensure the connection is still alive.
+
+=item B<cache_ttl>
+
+Set the number of seconds a cached L<DBI> handle will survive before it is 
disconnected
+and destroyed. The default is 24 hours (3600 * 24).
+
 =item B<disconnect>
 
 Decrements the reference count for the database handle and disconnects it if 
the reference count is zero.  Regardless of the reference count, it sets the 
L<dbh|/dbh> attribute to undef.
-------------------------------------------------------------------------
This SF.net email is sponsored by: Splunk Inc.
Still grepping through log files to find problems?  Stop.
Now Search log events and configuration files using AJAX and a browser.
Download your FREE copy of Splunk now >> http://get.splunk.com/
_______________________________________________
Rose-db-object mailing list
Rose-db-object@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/rose-db-object

Reply via email to