File Coverage

blib/lib/Starch/Store/DBI.pm
Criterion Covered Total %
statement 59 62 95.1
branch 6 10 60.0
condition 1 3 33.3
subroutine 18 18 100.0
pod 2 2 100.0
total 86 95 90.5


line stmt bran cond sub pod time code
1             package Starch::Store::DBI;
2 1     1   13138 use 5.008001;
  1         4  
3 1     1   7 use strictures 2;
  1         9  
  1         44  
4             our $VERSION = '0.04';
5              
6             =head1 NAME
7              
8             Starch::Store::DBI - Starch storage backend using DBI.
9              
10             =head1 SYNOPSIS
11              
12             my $starch = Starch->new(
13             store => {
14             class => '::DBI',
15             dbh => [
16             $dsn,
17             $username,
18             $password,
19             { RaiseError=>1, AutoCommit=>1 },
20             ],
21             },
22             );
23              
24             =head1 DESCRIPTION
25              
26             This L store uses L to set and get state data.
27              
28             Consider using L instead
29             of this store as L provides superior re-connection
30             and transaction handling capabilities.
31              
32             The table in your database should contain three columns. This
33             is the SQLite syntax for creating a compatible table which you
34             can modify to work for your particular database's syntax:
35              
36             CREATE TABLE starch_states (
37             key TEXT NOT NULL PRIMARY KEY,
38             data TEXT NOT NULL,
39             expiration INTEGER NOT NULL
40             )
41              
42             =cut
43              
44 1     1   1869 use DBI;
  1         17434  
  1         75  
45 1     1   9 use Types::Standard -types;
  1         4  
  1         22  
46 1     1   4815 use Types::Common::String -types;
  1         2  
  1         12  
47 1     1   1424 use Scalar::Util qw( blessed );
  1         3  
  1         95  
48 1     1   611 use Data::Serializer::Raw;
  1         837  
  1         33  
49              
50 1     1   9 use Moo;
  1         2  
  1         10  
51 1     1   477 use namespace::clean;
  1         3  
  1         12  
52              
53             with qw(
54             Starch::Store
55             );
56              
57             =head1 REQUIRED ARGUMENTS
58              
59             =head2 dbh
60              
61             This must be set to either array ref arguments for L
62             or a pre-built object (often retrieved using a method proxy).
63              
64             When configuring Starch from static configuration files using a
65             L
66             is a good way to link your existing L object constructor
67             in with Starch so that starch doesn't build its own.
68              
69             =cut
70              
71             has _dbh_arg => (
72             is => 'ro',
73             isa => (InstanceOf[ 'DBI::db' ]) | ArrayRef,
74             init_arg => 'dbh',
75             required => 1,
76             );
77              
78             has dbh => (
79             is => 'lazy',
80             isa => InstanceOf[ 'DBI::db' ],
81             init_arg => undef,
82             );
83             sub _build_dbh {
84 4     4   7062 my ($self) = @_;
85              
86 4         20 my $dbh = $self->_dbh_arg();
87 4 50       27 return $dbh if blessed $dbh;
88              
89 4         50 return DBI->connect( @$dbh );
90             }
91              
92             =head1 OPTIONAL ARGUMENTS
93              
94             =head2 serializer
95              
96             A L for serializing the state data for storage
97             in the L. Can be specified as string containing the
98             serializer name, a hash ref of Data::Serializer::Raw arguments, or as a
99             pre-created Data::Serializer::Raw object. Defaults to C.
100              
101             Consider using the C or C serializers for speed.
102              
103             C will likely be the fastest and produce the most compact data.
104              
105             =cut
106              
107             has _serializer_arg => (
108             is => 'ro',
109             isa => ((InstanceOf[ 'Data::Serializer::Raw' ]) | HashRef) | NonEmptySimpleStr,
110             init_arg => 'serializer',
111             default => 'JSON',
112             );
113              
114             has serializer => (
115             is => 'lazy',
116             isa => InstanceOf[ 'Data::Serializer::Raw' ],
117             init_arg => undef,
118             );
119             sub _build_serializer {
120 3     3   45 my ($self) = @_;
121              
122 3         16 my $serializer = $self->_serializer_arg();
123 3 50       17 return $serializer if blessed $serializer;
124              
125 3 50       11 if (ref $serializer) {
126 0         0 return Data::Serializer::Raw->new( %$serializer );
127             }
128              
129 3         37 return Data::Serializer::Raw->new(
130             serializer => $serializer,
131             );
132             }
133              
134             =head2 table
135              
136             The table name where states are stored in the database.
137             Defaults to C.
138              
139             =cut
140              
141             has table => (
142             is => 'ro',
143             isa => NonEmptySimpleStr,
144             default => 'starch_states',
145             );
146              
147             =head2 key_column
148              
149             The column in the L
where the state ID is stored. 150             Defaults to C. 151               152             =cut 153               154             has key_column => ( 155             is => 'ro', 156             isa => NonEmptySimpleStr, 157             default => 'key', 158             ); 159               160             =head2 data_column 161               162             The column in the L which will hold the state 163             data. Defaults to C. 164               165             =cut 166               167             has data_column => ( 168             is => 'ro', 169             isa => NonEmptySimpleStr, 170             default => 'data', 171             ); 172               173             =head2 expiration_column 174               175             The column in the L which will hold the epoch time 176             when the state should be expired. Defaults to C. 177               178             =cut 179               180             has expiration_column => ( 181             is => 'ro', 182             isa => NonEmptySimpleStr, 183             default => 'expiration', 184             ); 185               186             =head1 ATTRIBUTES 187               188             =head2 insert_sql 189               190             The SQL used to create state data. 191               192             =cut 193               194             has insert_sql => ( 195             is => 'lazy', 196             isa => NonEmptyStr, 197             init_arg => undef, 198             ); 199             sub _build_insert_sql { 200 3     3   107 my ($self) = @_; 201               202 3         85 return sprintf( 203             'INSERT INTO %s (%s, %s, %s) VALUES (?, ?, ?)', 204             $self->table(), 205             $self->key_column(), 206             $self->data_column(), 207             $self->expiration_column(), 208             ); 209             } 210               211             =head2 update_sql 212               213             The SQL used to update state data. 214               215             =cut 216               217             has update_sql => ( 218             is => 'lazy', 219             isa => NonEmptyStr, 220             init_arg => undef, 221             ); 222             sub _build_update_sql { 223 2     2   87 my ($self) = @_; 224               225 2         59 return sprintf( 226             'UPDATE %s SET %s=?, %s=? WHERE %s=?', 227             $self->table(), 228             $self->data_column(), 229             $self->expiration_column(), 230             $self->key_column(), 231             ); 232             } 233               234             =head2 exists_sql 235               236             The SQL used to confirm whether state data already exists. 237               238             =cut 239               240             has exists_sql => ( 241             is => 'lazy', 242             isa => NonEmptyStr, 243             init_arg => undef, 244             ); 245             sub _build_exists_sql { 246 3     3   43 my ($self) = @_; 247               248 3         78 return sprintf( 249             'SELECT 1 FROM %s WHERE %s = ?', 250             $self->table(), 251             $self->key_column(), 252             ); 253             } 254               255             =head2 select_sql 256               257             The SQL used to retrieve state data. 258               259             =cut 260               261             has select_sql => ( 262             is => 'lazy', 263             isa => NonEmptyStr, 264             init_arg => undef, 265             ); 266             sub _build_select_sql { 267 3     3   34 my ($self) = @_; 268               269 3         79 return sprintf( 270             'SELECT %s, %s FROM %s WHERE %s = ?', 271             $self->data_column(), 272             $self->expiration_column(), 273             $self->table(), 274             $self->key_column(), 275             ); 276             } 277               278             =head2 delete_sql 279               280             The SQL used to delete state data. 281               282             =cut 283               284             has delete_sql => ( 285             is => 'lazy', 286             isa => NonEmptyStr, 287             init_arg => undef, 288             ); 289             sub _build_delete_sql { 290 2     2   29 my ($self) = @_; 291               292 2         53 return sprintf( 293             'DELETE FROM %s WHERE %s = ?', 294             $self->table(), 295             $self->key_column(), 296             ); 297             } 298               299             =head1 METHODS 300               301             =head2 set 302               303             Set L. 304               305             =head2 get 306               307             Set L. 308               309             =head2 remove 310               311             Set L. 312               313             =cut 314               315             sub set { 316             my ($self, $id, $namespace, $data, $expires) = @_; 317               318             my $key = $self->stringify_key( $id, $namespace ); 319               320             my $dbh = $self->dbh(); 321               322             my $sth = $dbh->prepare_cached( 323             $self->exists_sql(), 324             ); 325               326             my ($exists) = $dbh->selectrow_array( $sth, undef, $key ); 327               328             $data = $self->serializer->serialize( $data ); 329             $expires += time(); 330               331             if ($exists) { 332             my $sth = $self->dbh->prepare_cached( 333             $self->update_sql(), 334             ); 335               336             $sth->execute( $data, $expires, $key ); 337             } 338             else { 339             my $sth = $self->dbh->prepare_cached( 340             $self->insert_sql(), 341             ); 342               343             $sth->execute( $key, $data, $expires ); 344             } 345               346             return; 347             } 348               349             sub get { 350 19     19 1 15274 my ($self, $id, $namespace) = @_; 351               352 19         96 my $key = $self->stringify_key( $id, $namespace ); 353               354 19         539 my $dbh = $self->dbh(); 355               356 19         477 my $sth = $dbh->prepare_cached( 357             $self->select_sql(), 358             ); 359               360 19         2600 my ($data, $expiration) = $dbh->selectrow_array( $sth, undef, $key ); 361               362 19 100       149 return undef if !defined $data; 363               364 12 50 33     88 if ($expiration and $expiration < time()) { 365 0         0 $self->remove( $id, $namespace ); 366 0         0 return undef; 367             } 368               369 12         333 return $self->serializer->deserialize( $data ); 370             } 371               372             sub remove { 373 6     6 1 21996 my ($self, $id, $namespace) = @_; 374               375 6         27 my $key = $self->stringify_key( $id, $namespace ); 376               377 6         159 my $dbh = $self->dbh(); 378               379 6         755 my $sth = $dbh->prepare_cached( 380             $self->delete_sql(), 381             ); 382               383 6         59440 $sth->execute( $key ); 384               385 6         97 return; 386             } 387               388             1; 389             __END__