File Coverage

blib/lib/MVC/Neaf/X/Session/Base.pm
Criterion Covered Total %
statement 57 69 82.6
branch 15 28 53.5
condition 11 29 37.9
subroutine 12 14 85.7
pod 9 9 100.0
total 104 149 69.8


line stmt bran cond sub pod time code
1             package MVC::Neaf::X::Session::Base;
2              
3 6     6   3068 use strict;
  6         25  
  6         177  
4 6     6   33 use warnings;
  6         15  
  6         259  
5             our $VERSION = '0.2901';
6              
7             =head1 DESCRIPTION
8              
9             MVC::Neaf::X::Session::Base - session engine base class & tooling for
10             Not Even A Framework.
11              
12             =head1 SINOPSYS
13              
14             package My::Session::Engine;
15             use parent qw(MVC::Neaf::X::Session::Base);
16              
17             sub store { ... };
18             sub fetch { ... };
19              
20             1;
21              
22             =head1 METHODS
23              
24             =cut
25              
26 6     6   49 use Carp;
  6         12  
  6         383  
27              
28 6     6   455 use MVC::Neaf::Util qw(encode_json decode_json);
  6         11  
  6         313  
29 6     6   36 use parent qw(MVC::Neaf::X::Session);
  6         12  
  6         68  
30              
31             =head2 new( %options )
32              
33             %options may include:
34              
35             =over
36              
37             =item * session_ttl - how long until session expires (not given = don't expire).
38              
39             =item * session_renewal_ttl - how long until session is forcibly re-saved
40             and updated.
41             Defaults to session_ttl * some_fraction.
42             0 means don't do this at all.
43              
44             =back
45              
46             =cut
47              
48             sub new {
49 4     4 1 21 my $class = shift;
50              
51 4         25 my $self = $class->SUPER::new( @_ );
52              
53 4 50       31 if (!defined $self->{session_ttl}) {
54 0         0 $self->{session_ttl} = 7*24*60*60; # default expiration to a week
55             };
56              
57 4 50       13 if (!defined $self->{session_renewal_ttl}) {
58 4         21 my $ttl = $self->session_ttl;
59 4   50     29 $self->{session_renewal_ttl} = ($ttl || 0) * 0.875; # 7/8 of expiration
60             };
61              
62 4         29 return $self;
63             };
64              
65             =head2 save_session( $id, $hash )
66              
67             Save session data. Returns hash with keys id and expire.
68             Returned id MAY differ from the given one, and must be honored in such case.
69              
70             =cut
71              
72             sub save_session {
73 5     5 1 25 my ($self, $id, $obj) = @_;
74              
75 5         31 my $str = $self->encode( $obj );
76 5   33     13 $id ||= $self->get_session_id;
77              
78 5         20 my $hash = $self->store( $id, $str, $obj );
79              
80 5 50       33 $self->my_croak("Failed to save session (unknown reason)")
81             unless (ref $hash eq 'HASH');
82              
83 5   33     23 $hash->{id} ||= $id;
84 5   33     26 $hash->{expire} ||= $self->get_expire;
85              
86 5         15 return $hash;
87             };
88              
89             =head2 load_session( $id )
90              
91             Load session by id. A hash containing session data, id, and expiration
92             time is returned.
93              
94             Session is re-saved if time has come to update it.
95              
96             =cut
97              
98             sub load_session {
99 7     7 1 2558 my ($self, $id) = @_;
100              
101 7         24 my $hash = $self->fetch( $id );
102 7 50 33     111 return unless ref $hash eq 'HASH' and ($hash->{strfy} or $hash->{override});
      66        
103              
104             # extract real data and apply overrides if any
105 5 50       59 $hash->{data} = $hash->{strfy} ? $self->decode( $hash->{strfy} ) : {};
106 5 50       18 if ($hash->{override}) {
107             $hash->{data}{$_} = $hash->{override}{$_}
108 0         0 for keys %{ $hash->{override} };
  0         0  
109             };
110              
111             # data would be nonepty if strfy is decoded OR at least one override present
112 5 50       16 return unless $hash->{data};
113              
114             # expired = return empty & cleanup
115 5 50 66     27 if ($hash->{expire} and $hash->{expire} < time ) {
116 0         0 $self->delete_session( $id );
117 0         0 return;
118             };
119              
120 5 50       25 if ($self->need_renewal( $hash->{expire} )) {
121 0         0 my $update = $self->save_session( $id, $hash->{data} );
122 0   0     0 $hash->{id} = $update->{id} || $id;
123 0   0     0 $hash->{expire} = $update->{expire} || $self->get_expire;
124             };
125              
126             # just return fetched data
127 5         21 return $hash;
128             };
129              
130             =head2 get_expire ( $time || time )
131              
132             Caclulate expiration time, if applicable.
133              
134             =cut
135              
136             sub get_expire {
137 8     8 1 24 my ($self, $time) = @_;
138              
139 8         21 my $ttl = $self->session_ttl;
140 8 50       22 return unless $ttl;
141              
142 8 50       39 $time = time unless defined $time;
143 8         25 return $time + $ttl;
144             };
145              
146             =head2 need_renewal( $time )
147              
148             Tell if session expiring by $time needs to be renewed.
149              
150             =cut
151              
152             sub need_renewal {
153 5     5 1 27 my ($self, $time) = @_;
154              
155 5         11 my $ttl = $self->{session_renewal_ttl};
156              
157 5 100 66     34 return ($time && $ttl) ? ($time < time + $ttl) : ('');
158             };
159              
160             =head2 encode
161              
162             =cut
163              
164             sub encode {
165 5     5 1 15 my ($self, $data) = @_;
166 5         10 my $str = eval { encode_json( $data ) };
  5         45  
167 5 50       29 carp "Failed to encode session data: $@"
168             if $@;
169 5         14 return $str;
170             };
171              
172             =head2 decode
173              
174             =cut
175              
176             sub decode {
177 5     5 1 38 my ($self, $data) = @_;
178 5         12 my $obj = eval { decode_json( $data ) };
  5         32  
179 5 50       15 carp "Failed to encode session data: $@"
180             if $@;
181 5         13 return $obj;
182             };
183              
184             =head2 fetch ($id)
185              
186             Stub, to be redefined by real storage access method.
187             Return is expected as { data => stringified_session }.
188              
189             =cut
190              
191             sub fetch {
192 0     0 1   my ($self, $id) = @_;
193              
194 0           $self->my_croak("unimplemented");
195             };
196              
197             =head2 store( $id, $stringified_data, $data_as_is)
198              
199             Stub, to be redefined by real storage access method.
200              
201             Must return false value or a hash with following fields (all optional):
202              
203             =over
204              
205             =item * id - indicates that id has changed and/or client session needs update;
206              
207             =item * expire - indicates that expiration date has changed and/or needs update;
208              
209             =item * strfy - stringified session data;
210              
211             =item * override - hash with individual fields that would override
212             decoded content.
213              
214             =back
215              
216             =cut
217              
218             sub store {
219 0     0 1   my ($self, $id, $data_str, $data_real) = @_;
220              
221 0           $self->my_croak("unimplemented");
222             };
223              
224             =head1 LICENSE AND COPYRIGHT
225              
226             This module is part of L suite.
227              
228             Copyright 2016-2023 Konstantin S. Uvarin C.
229              
230             This program is free software; you can redistribute it and/or modify it
231             under the terms of either: the GNU General Public License as published
232             by the Free Software Foundation; or the Artistic License.
233              
234             See L for more information.
235              
236             =cut
237              
238             1;