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 17 17 100.0
pod 2 2 100.0
total 85 94 90.4


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