File Coverage

blib/lib/Prancer/Session/Store/Database/Driver.pm
Criterion Covered Total %
statement 24 92 26.1
branch 0 24 0.0
condition 0 21 0.0
subroutine 8 21 38.1
pod 1 2 50.0
total 33 160 20.6


line stmt bran cond sub pod time code
1             package Prancer::Session::Store::Database::Driver;
2              
3 4     4   2412 use strict;
  4         4  
  4         109  
4 4     4   10 use warnings FATAL => 'all';
  4         4  
  4         89  
5              
6 4     4   9 use Plack::Session::Store;
  4         4  
  4         139  
7 4     4   12 use parent qw(Plack::Session::Store);
  4         3  
  4         25  
8              
9 4     4   204 use Carp;
  4         4  
  4         246  
10 4     4   11 use YAML;
  4         4  
  4         154  
11 4     4   21 use Try::Tiny;
  4         11  
  4         172  
12 4     4   11 use Prancer qw(logger);
  4         3  
  4         2781  
13              
14             sub new {
15 0     0 1       my ($class, $config) = @_;
16              
17                 try {
18 0     0             require DBI;
19                 } catch {
20 0 0   0             my $error = (defined($_) ? $_ : "unknown");
21 0                   logger->fatal("could not initialize session handler: could not load DBI: ${error}");
22 0                   croak;
23 0               };
24              
25             # this is the only required field
26 0 0             unless ($config->{'database'}) {
27 0                   logger->fatal("could not initialize session handler: no database name configured");
28 0                   croak;
29                 }
30              
31             # initialize the serializer that will be used
32 0 0             my $self = bless($class->SUPER::new(%{$config || {}}), $class);
  0            
33 0     0         $self->{'_serializer'} = sub { YAML::freeze(reverse(@_)) };
  0            
34 0     0         $self->{'_deserializer'} = sub { YAML::thaw(@_) };
  0            
35              
36 0               $self->{'_database'} = $config->{'database'};
37 0               $self->{'_username'} = $config->{'username'};
38 0               $self->{'_password'} = $config->{'password'};
39 0               $self->{'_hostname'} = $config->{'hostname'};
40 0               $self->{'_port'} = $config->{'port'};
41 0               $self->{'_autocommit'} = $config->{'autocommit'};
42 0               $self->{'_charset'} = $config->{'charset'};
43 0   0           $self->{'_check_threshold'} = $config->{'connection_check_threshold'} || 30;
44 0   0           $self->{'_table'} = $config->{'table'} || "sessions";
45 0   0           $self->{'_timeout'} = $config->{'expiration_timeout'} || 1800;
46 0   0           $self->{'_autopurge'} = $config->{'autopurge'} || 1;
47              
48             # store a pool of database connection handles
49 0               $self->{'_handles'} = {};
50              
51 0               return $self;
52             }
53              
54             sub handle {
55 0     0 0       my $self = shift;
56              
57             # to be fork safe and thread safe, use a combination of the PID and TID (if running
58             # with use threads) to make sure no two processes/threads share a handle.
59             # implementation based on DBIx::Connector by David E. Wheeler
60 0               my $pid_tid = $$;
61 0 0             $pid_tid .= '_' . threads->tid if $INC{'threads.pm'};
62              
63             # OK, see if we have a matching handle
64 0   0           my $handle = $self->{'_handles'}->{$pid_tid} || undef;
65              
66 0 0             if ($handle->{'dbh'}) {
67 0 0 0               if ($handle->{'dbh'}{'Active'} && $self->{'_check_threshold'} &&
      0        
68                         (time - $handle->{'last_connection_check'} < $self->{'_check_threshold'})) {
69              
70             # the handle has been checked recently so just return it
71 0                       return $handle->{dbh};
72                     } else {
73 0 0                     if (_check_connection($handle->{'dbh'})) {
74 0                           $handle->{last_connection_check} = time;
75 0                           return $handle->{'dbh'};
76                         } else {
77             # er need to reconnect
78 0                           logger->debug("database connection to '${\$self->{'_connection'}}' went away -- reconnecting");
  0            
79              
80             # try to disconnect but don't care if it fails
81 0 0                         if ($handle->{'dbh'}) {
82 0     0                         try { $handle->{'dbh'}->disconnect() } catch {};
  0            
  0            
83                             }
84              
85             # try to connect again and save the new handle
86 0                           $handle->{'dbh'} = $self->_get_connection();
87 0                           return $handle->{'dbh'};
88                         }
89                     }
90                 } else {
91 0                   $handle->{'dbh'} = $self->_get_connection();
92 0 0                 if ($handle->{'dbh'}) {
93 0                       $handle->{'last_connection_check'} = time;
94 0                       $self->{'_handles'}->{$pid_tid} = $handle;
95 0                       return $handle->{'dbh'};
96                     }
97                 }
98              
99 0               return;
100             }
101              
102             sub _get_connection {
103 0     0         my $self = shift;
104              
105 0               my $dbh = undef;
106                 try {
107 0   0 0             $dbh = DBI->connect(@{$self->{'_dsn'}}) || die "${\$DBI::errstr}\n";
108                 } catch {
109 0     0             logger->fatal("could not initialize database connection '${\$self->{'_connection'}}': " . $_);
  0            
110 0               };
111              
112 0               return $dbh;
113             }
114              
115             # Check the connection is alive
116             sub _check_connection {
117 0     0         my $dbh = shift;
118 0 0             return unless $dbh;
119              
120 0 0 0           if ($dbh->{Active} && (my $result = $dbh->ping())) {
121 0 0                 if (int($result)) {
122             # DB driver itself claims all is OK, trust it:
123 0                       return 1;
124                     } else {
125             # it was "0 but true", meaning the DBD doesn't implement ping and
126             # instead we got the default DBI ping implementation. implement
127             # our own basic check, by performing a real simple query.
128                         return try {
129 0     0                     return $dbh->do('SELECT 1');
130                         } catch {
131 0     0                     return 0;
132 0                       };
133                     }
134                 } else {
135 0                   return;
136                 }
137             }
138              
139             1;
140