line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Prancer::Session::Store::Database::Driver; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
2681
|
use strict; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
63
|
|
4
|
2
|
|
|
2
|
|
10
|
use warnings FATAL => 'all'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
60
|
|
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
39
|
use version; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
7
|
|
7
|
|
|
|
|
|
|
our $VERSION = '1.00'; |
8
|
|
|
|
|
|
|
|
9
|
2
|
|
|
2
|
|
963
|
use Plack::Session::Store; |
|
2
|
|
|
|
|
1589
|
|
|
2
|
|
|
|
|
48
|
|
10
|
2
|
|
|
2
|
|
787
|
use parent qw(Plack::Session::Store); |
|
2
|
|
|
|
|
482
|
|
|
2
|
|
|
|
|
9
|
|
11
|
|
|
|
|
|
|
|
12
|
2
|
|
|
2
|
|
2806
|
use DBI; |
|
2
|
|
|
|
|
25602
|
|
|
2
|
|
|
|
|
133
|
|
13
|
2
|
|
|
2
|
|
670
|
use Storable qw(nfreeze thaw); |
|
2
|
|
|
|
|
2429
|
|
|
2
|
|
|
|
|
139
|
|
14
|
2
|
|
|
2
|
|
465
|
use MIME::Base64 qw(encode_base64 decode_base64); |
|
2
|
|
|
|
|
479
|
|
|
2
|
|
|
|
|
112
|
|
15
|
2
|
|
|
2
|
|
438
|
use Try::Tiny; |
|
2
|
|
|
|
|
1045
|
|
|
2
|
|
|
|
|
85
|
|
16
|
2
|
|
|
2
|
|
8
|
use Carp; |
|
2
|
|
|
|
|
9
|
|
|
2
|
|
|
|
|
2409
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# even though this *should* work automatically, it was not |
19
|
|
|
|
|
|
|
our @CARP_NOT = qw(Prancer Try::Tiny); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub new { |
22
|
3
|
|
|
3
|
1
|
4
|
my ($class, $config) = @_; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# this is the only required field |
25
|
3
|
50
|
|
|
|
31
|
unless ($config->{'database'}) { |
26
|
0
|
|
|
|
|
0
|
croak "could not initialize session handler: no database name configured"; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
# initialize the serializer that will be used |
30
|
3
|
50
|
|
|
|
4
|
my $self = bless($class->SUPER::new(%{$config || {}}), $class); |
|
3
|
|
|
|
|
35
|
|
31
|
3
|
|
|
1
|
|
57
|
$self->{'_serializer'} = sub { encode_base64(nfreeze(shift)) }; |
|
1
|
|
|
|
|
3
|
|
32
|
3
|
|
|
1
|
|
13
|
$self->{'_deserializer'} = sub { thaw(decode_base64(shift)) }; |
|
1
|
|
|
|
|
6
|
|
33
|
|
|
|
|
|
|
|
34
|
3
|
|
|
|
|
6
|
$self->{'_database'} = $config->{'database'}; |
35
|
3
|
|
|
|
|
6
|
$self->{'_username'} = $config->{'username'}; |
36
|
3
|
|
|
|
|
4
|
$self->{'_password'} = $config->{'password'}; |
37
|
3
|
|
|
|
|
5
|
$self->{'_hostname'} = $config->{'hostname'}; |
38
|
3
|
|
|
|
|
6
|
$self->{'_port'} = $config->{'port'}; |
39
|
3
|
|
|
|
|
6
|
$self->{'_charset'} = $config->{'charset'}; |
40
|
3
|
|
50
|
|
|
16
|
$self->{'_check_threshold'} = $config->{'connection_check_threshold'} // 30; |
41
|
3
|
|
50
|
|
|
31
|
$self->{'_table'} = $config->{'table'} || "sessions"; |
42
|
3
|
|
50
|
|
|
10
|
$self->{'_timeout'} = $config->{'expiration_timeout'} // 1800; |
43
|
3
|
|
50
|
|
|
8
|
$self->{'_autopurge'} = $config->{'autopurge'} // 1; |
44
|
3
|
|
50
|
|
|
8
|
$self->{'_autopurge_probability'} = $config->{'autopurge_probability'} || 0.1; |
45
|
3
|
|
|
|
|
10
|
$self->{'_application'} = $config->{'application'}; |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# store a pool of database connection handles |
48
|
3
|
|
|
|
|
3
|
$self->{'_handles'} = {}; |
49
|
|
|
|
|
|
|
|
50
|
3
|
|
|
|
|
13
|
return $self; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub handle { |
54
|
9
|
|
|
9
|
0
|
47
|
my $self = shift; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# to be fork safe and thread safe, use a combination of the PID and TID |
57
|
|
|
|
|
|
|
# (if running with use threads) to make sure no two processes/threads share |
58
|
|
|
|
|
|
|
# a handle. implementation based on DBIx::Connector by David E. Wheeler |
59
|
9
|
|
|
|
|
15
|
my $pid_tid = $$; |
60
|
9
|
50
|
|
|
|
22
|
$pid_tid .= "_" . threads->tid() if $INC{'threads.pm'}; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
# see if we have a matching handle |
63
|
9
|
|
100
|
|
|
34
|
my $handle = $self->{'_handles'}->{$pid_tid} || undef; |
64
|
|
|
|
|
|
|
|
65
|
9
|
100
|
|
|
|
19
|
if ($handle->{'dbh'}) { |
66
|
6
|
50
|
33
|
|
|
34
|
if ($handle->{'dbh'}{'Active'} && $self->{'_check_threshold'} && |
|
|
|
33
|
|
|
|
|
67
|
|
|
|
|
|
|
(time - $handle->{'last_connection_check'} < $self->{'_check_threshold'})) { |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# the handle has been checked recently so just return it |
70
|
6
|
|
|
|
|
88
|
return $handle->{'dbh'}; |
71
|
|
|
|
|
|
|
} else { |
72
|
0
|
0
|
|
|
|
0
|
if ($self->_check_connection($handle->{'dbh'})) { |
73
|
0
|
|
|
|
|
0
|
$handle->{'last_connection_check'} = time; |
74
|
0
|
|
|
|
|
0
|
return $handle->{'dbh'}; |
75
|
|
|
|
|
|
|
} else { |
76
|
|
|
|
|
|
|
# try to disconnect but don't care if it fails |
77
|
0
|
0
|
|
|
|
0
|
if ($handle->{'dbh'}) { |
78
|
0
|
|
|
0
|
|
0
|
try { $handle->{'dbh'}->disconnect() } catch {}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# try to connect again and save the new handle |
82
|
0
|
|
|
|
|
0
|
$handle->{'dbh'} = $self->_get_connection(); |
83
|
0
|
|
|
|
|
0
|
return $handle->{'dbh'}; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
} else { |
87
|
3
|
|
|
|
|
13
|
$handle->{'dbh'} = $self->_get_connection(); |
88
|
2
|
50
|
|
|
|
7
|
if ($handle->{'dbh'}) { |
89
|
2
|
|
|
|
|
6
|
$handle->{'last_connection_check'} = time; |
90
|
2
|
|
|
|
|
5
|
$self->{'_handles'}->{$pid_tid} = $handle; |
91
|
2
|
|
|
|
|
5
|
return $handle->{'dbh'}; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
|
95
|
0
|
|
|
|
|
0
|
return; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub _get_connection { |
99
|
3
|
|
|
3
|
|
5
|
my $self = shift; |
100
|
3
|
|
|
|
|
4
|
my $dbh = undef; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
try { |
103
|
3
|
|
50
|
3
|
|
65
|
$dbh = DBI->connect(@{$self->{'_dsn'}}) || die "${\$DBI::errstr}\n"; |
104
|
|
|
|
|
|
|
} catch { |
105
|
1
|
50
|
|
1
|
|
430
|
my $error = (defined($_) ? $_ : "unknown"); |
106
|
1
|
|
|
|
|
109
|
croak "could not initialize database connection: ${error}"; |
107
|
3
|
|
|
|
|
19
|
}; |
108
|
|
|
|
|
|
|
|
109
|
2
|
|
|
|
|
900
|
return $dbh; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# Check the connection is alive |
113
|
|
|
|
|
|
|
sub _check_connection { |
114
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
115
|
0
|
|
|
|
|
0
|
my $dbh = shift; |
116
|
0
|
0
|
|
|
|
0
|
return 0 unless $dbh; |
117
|
|
|
|
|
|
|
|
118
|
0
|
0
|
0
|
|
|
0
|
if ($dbh->{'Active'} && (my $result = $dbh->ping())) { |
119
|
0
|
0
|
|
|
|
0
|
if (int($result)) { |
120
|
|
|
|
|
|
|
# DB driver itself claims all is OK, trust it |
121
|
0
|
|
|
|
|
0
|
return 1; |
122
|
|
|
|
|
|
|
} else { |
123
|
|
|
|
|
|
|
# it was "0 but true", meaning the DBD doesn't implement ping and |
124
|
|
|
|
|
|
|
# instead we got the default DBI ping implementation. implement |
125
|
|
|
|
|
|
|
# our own basic check, by performing a real simple query. |
126
|
|
|
|
|
|
|
return try { |
127
|
0
|
|
|
0
|
|
0
|
return $dbh->do("SELECT 1"); |
128
|
|
|
|
|
|
|
} catch { |
129
|
0
|
|
|
0
|
|
0
|
return 0; |
130
|
0
|
|
|
|
|
0
|
}; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
0
|
|
|
|
|
0
|
return 0; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub fetch { |
138
|
2
|
|
|
2
|
1
|
3003
|
my ($self, $session_id) = @_; |
139
|
2
|
|
|
|
|
6
|
my $dbh = $self->handle(); |
140
|
2
|
|
|
|
|
3
|
my $result = undef; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
try { |
143
|
2
|
|
|
2
|
|
43
|
my $now = time(); |
144
|
2
|
|
|
|
|
3
|
my $table = $self->{'_table'}; |
145
|
2
|
|
|
|
|
2
|
my $application = $self->{'_application'}; |
146
|
|
|
|
|
|
|
|
147
|
2
|
|
|
|
|
13
|
my $sth = $dbh->prepare(qq| |
148
|
|
|
|
|
|
|
SELECT data |
149
|
|
|
|
|
|
|
FROM ${table} |
150
|
|
|
|
|
|
|
WHERE id = ? |
151
|
|
|
|
|
|
|
AND application = ? |
152
|
|
|
|
|
|
|
AND timeout >= ? |
153
|
|
|
|
|
|
|
|); |
154
|
2
|
|
|
|
|
229
|
$sth->execute($session_id, $application, $now); |
155
|
2
|
|
|
|
|
123
|
my ($data) = $sth->fetchrow(); |
156
|
2
|
|
|
|
|
62
|
$sth->finish(); |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# deserialize the data if there is any |
159
|
2
|
100
|
|
|
|
28
|
$result = (defined($data) ? $self->{'_deserializer'}->($data) : undef); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# maybe we'll purge old sessions sometimes |
162
|
2
|
|
|
|
|
31
|
$self->_purge(); |
163
|
|
|
|
|
|
|
|
164
|
2
|
|
|
|
|
6
|
$dbh->commit(); |
165
|
|
|
|
|
|
|
} catch { |
166
|
0
|
|
|
0
|
|
0
|
try { $dbh->rollback(); } catch {}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
167
|
|
|
|
|
|
|
|
168
|
0
|
0
|
|
|
|
0
|
my $error = (defined($_) ? $_ : "unknown"); |
169
|
0
|
|
|
|
|
0
|
carp "error fetching from session: ${error}"; |
170
|
2
|
|
|
|
|
15
|
}; |
171
|
|
|
|
|
|
|
|
172
|
2
|
|
|
|
|
378
|
return $result; |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
sub store { |
176
|
1
|
|
|
1
|
1
|
2472
|
my ($self, $session_id, $data) = @_; |
177
|
1
|
|
|
|
|
4
|
my $dbh = $self->handle(); |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
try { |
180
|
1
|
|
|
1
|
|
23
|
my $now = time(); |
181
|
1
|
|
|
|
|
2
|
my $table = $self->{'_table'}; |
182
|
1
|
|
|
|
|
1
|
my $application = $self->{'_application'}; |
183
|
1
|
|
|
|
|
2
|
my $timeout = ($now + $self->{'_timeout'}); |
184
|
1
|
|
|
|
|
3
|
my $serialized = $self->{'_serializer'}->($data); |
185
|
|
|
|
|
|
|
|
186
|
1
|
|
|
|
|
37
|
my $insert_sth = $dbh->prepare(qq| |
187
|
|
|
|
|
|
|
INSERT INTO ${table} (id, application, timeout, data) |
188
|
|
|
|
|
|
|
SELECT ?, ?, ?, ? |
189
|
|
|
|
|
|
|
WHERE NOT EXISTS ( |
190
|
|
|
|
|
|
|
SELECT 1 |
191
|
|
|
|
|
|
|
FROM ${table} |
192
|
|
|
|
|
|
|
WHERE id = ? |
193
|
|
|
|
|
|
|
AND application = ? |
194
|
|
|
|
|
|
|
AND timeout >= ? |
195
|
|
|
|
|
|
|
) |
196
|
|
|
|
|
|
|
|); |
197
|
1
|
|
|
|
|
110
|
$insert_sth->execute($session_id, $application, $timeout, $serialized, $session_id, $application, $now); |
198
|
1
|
|
|
|
|
99
|
$insert_sth->finish(); |
199
|
|
|
|
|
|
|
|
200
|
1
|
|
|
|
|
15
|
my $update_sth = $dbh->prepare(qq| |
201
|
|
|
|
|
|
|
UPDATE ${table} |
202
|
|
|
|
|
|
|
SET timeout = ?, data = ? |
203
|
|
|
|
|
|
|
WHERE id = ? |
204
|
|
|
|
|
|
|
AND application = ? |
205
|
|
|
|
|
|
|
AND timeout >= ? |
206
|
|
|
|
|
|
|
|); |
207
|
1
|
|
|
|
|
71
|
$update_sth->execute($timeout, $serialized, $session_id, $application, $now); |
208
|
1
|
|
|
|
|
60
|
$update_sth->finish(); |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# maybe we'll purge old sessions sometimes |
211
|
1
|
|
|
|
|
11
|
$self->_purge(); |
212
|
|
|
|
|
|
|
|
213
|
1
|
|
|
|
|
4
|
$dbh->commit(); |
214
|
|
|
|
|
|
|
} catch { |
215
|
0
|
|
|
0
|
|
0
|
try { $dbh->rollback(); } catch {}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
216
|
|
|
|
|
|
|
|
217
|
0
|
0
|
|
|
|
0
|
my $error = (defined($_) ? $_ : "unknown"); |
218
|
0
|
|
|
|
|
0
|
carp "error fetching from session: ${error}"; |
219
|
1
|
|
|
|
|
12
|
}; |
220
|
|
|
|
|
|
|
|
221
|
1
|
|
|
|
|
233
|
return; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub remove { |
225
|
2
|
|
|
2
|
1
|
5419
|
my ($self, $session_id) = @_; |
226
|
2
|
|
|
|
|
6
|
my $dbh = $self->handle(); |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
try { |
229
|
2
|
|
|
2
|
|
52
|
my $table = $self->{'_table'}; |
230
|
2
|
|
|
|
|
4
|
my $application = $self->{'_application'}; |
231
|
|
|
|
|
|
|
|
232
|
2
|
|
|
|
|
10
|
my $sth = $dbh->prepare(qq| |
233
|
|
|
|
|
|
|
DELETE |
234
|
|
|
|
|
|
|
FROM ${table} |
235
|
|
|
|
|
|
|
WHERE id = ? |
236
|
|
|
|
|
|
|
AND application = ? |
237
|
|
|
|
|
|
|
|); |
238
|
2
|
|
|
|
|
149
|
$sth->execute($session_id, $application); |
239
|
2
|
|
|
|
|
132
|
$sth->finish(); |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# maybe we'll purge old sessions sometimes |
242
|
2
|
|
|
|
|
22
|
$self->_purge(); |
243
|
|
|
|
|
|
|
|
244
|
2
|
|
|
|
|
6
|
$dbh->commit(); |
245
|
|
|
|
|
|
|
} catch { |
246
|
0
|
|
|
0
|
|
0
|
try { $dbh->rollback(); } catch {}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
247
|
|
|
|
|
|
|
|
248
|
0
|
0
|
|
|
|
0
|
my $error = (defined($_) ? $_ : "unknown"); |
249
|
0
|
|
|
|
|
0
|
carp "error fetching from session: ${error}"; |
250
|
2
|
|
|
|
|
17
|
}; |
251
|
|
|
|
|
|
|
|
252
|
2
|
|
|
|
|
325
|
return; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub _purge { |
256
|
5
|
|
|
5
|
|
6
|
my $self = shift; |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# 10% of the time we will also purge old sessions |
259
|
5
|
100
|
|
|
|
11
|
if ($self->{'_autopurge'}) { |
260
|
1
|
|
|
|
|
47
|
my $chance = rand(); |
261
|
1
|
50
|
|
|
|
5
|
if ($chance <= $self->{'_autopurge_probability'}) { |
262
|
1
|
|
|
|
|
2
|
my $now = time(); |
263
|
1
|
|
|
|
|
3
|
my $dbh = $self->handle(); |
264
|
1
|
|
|
|
|
3
|
my $table = $self->{'_table'}; |
265
|
1
|
|
|
|
|
1
|
my $application = $self->{'_application'}; |
266
|
|
|
|
|
|
|
|
267
|
1
|
|
|
|
|
4
|
my $delete_sth = $dbh->prepare(qq| |
268
|
|
|
|
|
|
|
DELETE |
269
|
|
|
|
|
|
|
FROM ${table} |
270
|
|
|
|
|
|
|
WHERE application = ? |
271
|
|
|
|
|
|
|
AND timeout < ? |
272
|
|
|
|
|
|
|
|); |
273
|
1
|
|
|
|
|
66
|
$delete_sth->execute($application, $now); |
274
|
1
|
|
|
|
|
57
|
$delete_sth->finish(); |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
5
|
|
|
|
|
22
|
return; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
1; |