File Coverage

blib/lib/MVC/Neaf/X/Session/SQL.pm
Criterion Covered Total %
statement 12 63 19.0
branch 0 26 0.0
condition 0 6 0.0
subroutine 4 7 57.1
pod 3 3 100.0
total 19 105 18.1


line stmt bran cond sub pod time code
1             package MVC::Neaf::X::Session::SQL;
2              
3 2     2   67120 use strict;
  2         15  
  2         61  
4 2     2   10 use warnings;
  2         4  
  2         82  
5             our $VERSION = '0.2800_01';
6              
7             =head1 NAME
8              
9             MVC::Neaf::X::Session::SQL - SQL-based session backend for
10             Not Even A Framework.
11              
12             =head1 DESCRIPTION
13              
14             Store session data in a SQL table.
15             Consider a pre-existing DB connection and a low-traffic site where
16             having additional session storage (e.g. key-value) would be an overkill.
17              
18             =head1 SYNOPSIS
19              
20             my $session_engine = MVC::Neaf::X::Session::SQL->new (
21             dbh => $my_db_conn,
22             table => 'session',
23             id_as => 'session_name',
24             content_as => 'json_data', # optional but recommended
25             expire_as => 'expires', # optional, unix timestamp
26             mapped_cols => [ 'user_id', ... ], # optional
27             );
28              
29             =head1 METHODS
30              
31             =cut
32              
33 2     2   11 use Carp;
  2         4  
  2         150  
34 2     2   439 use parent qw(MVC::Neaf::X::Session::Base);
  2         308  
  2         21  
35              
36             =head2 new (%options)
37              
38             %options may include
39              
40             =over
41              
42             =item * dbh (required) - database connection to use, see L.
43              
44             =item * table (required) - name of table to use for sessions.
45              
46             =item * id_as (required) - name of session id column.
47             Must accept long arbitrary strings.
48              
49             =item * content_as - name of column containing encoded session data.
50             Must accept long arbitrary strings.
51              
52             =item * expire_as - name of column storing expiration date as a Unix timestamp
53             (must accept integer number).
54              
55             =item * mapped_cols - array of session fields that are mapped into
56             database columns. The field name MUST be equal to column name.
57              
58             =back
59              
60             At least one of content_as and mapped_cols MUST be present, even though
61             it could be technically possible to use sessions with id and timestamp only.
62              
63             =cut
64              
65             sub new {
66 0     0 1   my ($class, %opt) = @_;
67              
68 0           my @missing = grep { !$opt{$_} } qw(dbh table id_as);
  0            
69 0 0         $class->my_croak( "Mandatory parameters missing: @missing" )
70             if @missing;
71              
72             # Setup all requests in advance so we can fail as early as possible
73 0           my $dbh = $opt{dbh};
74 0           my $table = $opt{table};
75 0           my $id_as = $opt{id_as};
76 0           my $fields = $opt{mapped_cols};
77 0           my $raw = $opt{content_as};
78              
79 0           my @all_fields;
80 0 0         push @all_fields, $opt{content_as} if defined $opt{content_as};
81 0 0         push @all_fields, @{ $opt{mapped_cols} } if $opt{mapped_cols};
  0            
82 0 0         $class->my_croak( "At least one of mapped_cols or content_as MUST be present" )
83             unless @all_fields;
84 0 0         push @all_fields, $opt{expire_as} if defined $opt{expire_as};
85              
86             # OUCH ORM by hand...
87             # We update BEFORE inserting just in case someone forgot unique key
88             # don't do like this. Session_id MUST be indexed anyway.
89             $opt{sql_upd} = sprintf "UPDATE %s SET %s WHERE %s = ?"
90             , $table
91 0           , join( ",", map { "$_=?" } @all_fields )
  0            
92             , $id_as;
93              
94 0           $opt{sql_ins} = sprintf "INSERT INTO %s(%s) VALUES(%s)"
95             , $table
96             , join( ",", $id_as, @all_fields )
97             , join( ",", ("?") x (@all_fields+1));
98              
99 0           $opt{sql_sel} = sprintf "SELECT %s FROM %s WHERE %s"
100             , join( ",", $id_as, @all_fields )
101             , $table
102             , "$id_as = ?";
103              
104             # Now try to use at least SELECT statement to make sure that
105             # the database provided actually has the needed table.
106              
107 0           my $sth_test = $dbh->prepare_cached( $opt{sql_sel} );
108              
109 0 0         $class->my_croak( "DB check failed for table '$table'/key '$id_as'/columns '@all_fields': ".$dbh->errstr )
110             unless $sth_test->execute( "TestSessionId" );
111              
112 0           $sth_test->finish;
113 0   0       $opt{mapped_cols} ||= [];
114 0           $opt{where_die} = "table $table for $id_as =";
115              
116             # Self-test passed, everything just as planned
117              
118 0           return $class->SUPER::new(%opt);
119             };
120              
121             =head2 store( $id, $str, $hash )
122              
123             Store data in database, using $hash as additional indexed fields if any defined.
124              
125             =cut
126              
127             sub store {
128 0     0 1   my ($self, $id, $str, $hash) = @_;
129              
130             # ONLY want raw data as a parameter if we know WHERE to store it!
131 0           my @param;
132 0 0         push @param, $str if $self->{content_as};
133 0           push @param, $hash->{$_} for @{ $self->{mapped_cols} };
  0            
134 0 0         push @param, scalar $self->get_expire if $self->{expire_as};
135              
136 0           my $sth_upd = $self->{dbh}->prepare_cached( $self->{sql_upd} );
137 0           $sth_upd->execute( @param, $id );
138              
139 0           my $n = $sth_upd->rows;
140 0 0         if ($n > 0) {
141 0 0         carp "More than one row updated in $self->{where_die} '$id'"
142             if $n > 1;
143 0           return {};
144             };
145              
146             $self->my_croak("Failed to UNDATE $self->{where_die} '$id': ".$self->{dbh}->errstr)
147 0 0         if $n < 0;
148              
149             # all good, but need to insert
150 0           my $sth_ins = $self->{dbh}->prepare_cached( $self->{sql_ins} );
151 0           $sth_ins->execute( $id, @param );
152              
153             $self->my_croak( "Failed to INSERT into $self->{where_die} '$id': ".$self->{dbh}->errstr )
154 0 0         unless $sth_ins->rows == 1;
155              
156 0           return {};
157             };
158              
159             =head2 fetch( $id )
160              
161             Fetch data from table.
162              
163             Returns { data => stringified_data, orevvide => { individual_fields } }
164              
165             =cut
166              
167             sub fetch {
168 0     0 1   my ($self, $id) = @_;
169              
170 0           my $sth_sel = $self->{dbh}->prepare_cached( $self->{sql_sel} );
171 0           $sth_sel->execute( $id );
172 0           my $override = $sth_sel->fetchrow_hashref;
173 0           $sth_sel->finish;
174              
175 0 0         return unless $override;
176              
177 0   0       my $raw = delete $override->{ $self->{content_as} || '' };
178 0   0       my $expire = delete $override->{ $self->{expire_as} || '' };
179              
180             return {
181 0           strfy => $raw,
182             override => $override,
183             expire => $expire,
184             };
185             };
186              
187             =head1 LICENSE AND COPYRIGHT
188              
189             This module is part of L suite.
190              
191             Copyright 2016-2023 Konstantin S. Uvarin C.
192              
193             This program is free software; you can redistribute it and/or modify it
194             under the terms of either: the GNU General Public License as published
195             by the Free Software Foundation; or the Artistic License.
196              
197             See L for more information.
198              
199             =cut
200              
201             1;