From ffa9f969259970df45ea2353a94d1a67e8612731 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Sven=20Sch=C3=B6ling?= <s.schoeling@linet-services.de>
Date: Fri, 5 Jun 2015 18:00:17 +0200
Subject: [PATCH] Dispatcher: Client DB Handles cachen.

Spart etwa ein Drittel an Requestoverhead, von 27ms auf 17ms.
---
 SL/DBConnect.pm       |   7 +++
 SL/DBConnect/Cache.pm | 122 ++++++++++++++++++++++++++++++++++++++++++
 SL/Form.pm            |   3 +-
 3 files changed, 131 insertions(+), 1 deletion(-)
 create mode 100644 SL/DBConnect/Cache.pm

diff --git a/SL/DBConnect.pm b/SL/DBConnect.pm
index 9142f1c71..369cfe158 100644
--- a/SL/DBConnect.pm
+++ b/SL/DBConnect.pm
@@ -4,6 +4,7 @@ use strict;
 
 use DBI;
 use SL::DB;
+use SL::DBConnect::Cache;
 
 my %dateformat_to_datestyle = (
   'yy-mm-dd'   => 'ISO',
@@ -33,12 +34,18 @@ sub _connect {
 sub connect {
   my ($self, @args) = @_;
 
+  if (my $cached_dbh = SL::DBConnect::Cache->get(@args)) {
+    return $cached_dbh;
+  }
+
   my $dbh = $self->_connect(@args);
   return undef if !$dbh;
 
   my $initial_sql = $self->get_initial_sql;
   $dbh->do($initial_sql) if $initial_sql;
 
+  SL::DBConnect::Cache->store($dbh, @args);
+
   return $dbh;
 }
 
diff --git a/SL/DBConnect/Cache.pm b/SL/DBConnect/Cache.pm
new file mode 100644
index 000000000..b04a5b4e2
--- /dev/null
+++ b/SL/DBConnect/Cache.pm
@@ -0,0 +1,122 @@
+package SL::DBConnect::Cache;
+
+use strict;
+use List::MoreUtils qw(apply);
+
+my %cache;
+
+sub get {
+  my ($package, @args) = @_;
+
+  my $dbh = $cache{ _args2str(@args) };
+
+  if (!$dbh->{Active}) {
+    delete $cache{ _args2str(@args) };
+    $dbh = undef;
+  }
+
+  return $dbh;
+}
+
+sub store {
+  my ($package, $dbh, @args) = @_;
+
+  $cache{ _args2str(@args) } = $dbh;
+}
+
+sub reset {
+  my ($package, @args) = @_;
+
+  my $dbh = $cache{ _args2str(@args) };
+
+  return unless $dbh;
+
+  $dbh->rollback;
+  $dbh;
+}
+
+sub clear {
+  %cache = ();
+}
+
+sub _args2str {
+  my (@args) = @_;
+
+  my ($dbconnect, $dbuser, $dbpasswd, $options) = @_;
+  $dbconnect //= '';
+  $dbuser    //= '';
+  $dbpasswd  //= '';
+  $options   //= {};
+  my $options_str =
+    join ';', apply { s/([;\\])/\\$1/g }  # no collisions if anything contains ;
+    map { $_ => $options->{$_} }
+    sort keys %$options;                  # deterministic order
+
+  join ';', apply { s/([;\\])/\\$1/g } $dbconnect, $dbuser, $dbpasswd, $options_str;
+}
+
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+SL::DBConnect::Cache - cached database handle pool
+
+=head1 SYNOPSIS
+
+  use SL::SBConnect::Cache;
+
+  my $dbh = SL::DBConnct::Cache->get(@args);
+  SL::DBConnct::Cache->store($dbh, @args);
+
+  # reset a cached handle
+  SL::DBConnct::Cache->reset($dbh);
+
+  # close a cached handle and forget it
+  SL::DBConnct::Cache->close($dbh);
+
+  SL::DBConnct::Cache->clear($dbh);
+
+
+=head1 DESCRIPTION
+
+Implementes a managed cache for DB connection handles.
+
+The same would be possible with C<< DBI->connect_cached >>, but in that case,
+we would have no control ver the cache.
+
+=head1 METHODS
+
+=over 4
+
+=item * C<get ARGS>
+
+Retrieve a connection specified by C<ARGS>.
+
+=item * C<store DBH ARGS>
+
+Store a connection specified by C<ARGS>.
+
+=item * C<reset ARGS>
+
+Rollback the connection specified by C<ARGS>.
+
+=item * C<clear>
+
+Emties the cache. If handles are not referenced otherwise, they will get
+dropped and closed.
+
+=back
+
+=head1 BUGS
+
+None yet :)
+
+=head1 AUTHOR
+
+Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
+
+=cut
diff --git a/SL/Form.pm b/SL/Form.pm
index b0433bddd..b0709dec4 100644
--- a/SL/Form.pm
+++ b/SL/Form.pm
@@ -91,7 +91,8 @@ END {
 
 sub disconnect_standard_dbh {
   return unless $standard_dbh;
-  $standard_dbh->disconnect();
+
+  $standard_dbh->rollback();
   undef $standard_dbh;
 }
 
-- 
2.20.1