File Coverage

blib/lib/MVC/Neaf/X/Session/File.pm
Criterion Covered Total %
statement 66 69 95.6
branch 19 32 59.3
condition 5 15 33.3
subroutine 15 15 100.0
pod 9 9 100.0
total 114 140 81.4


line stmt bran cond sub pod time code
1             package MVC::Neaf::X::Session::File;
2              
3 2     2   95001 use strict;
  2         14  
  2         65  
4 2     2   10 use warnings;
  2         4  
  2         93  
5             our $VERSION = '0.2901';
6              
7             =head1 NAME
8              
9             MVC::Neaf::X::Session::File - File-based sessions for Not Even A Framework.
10              
11             =head1 DESCRIPTION
12              
13             This module implements session storage, as described in
14             L.
15              
16             It will store session data inside a single directory.
17             The file format is JSON but MAY change in the future.
18              
19             Uses flock() to avoid collisions.
20              
21             If session_ttl was specified, old session files will be deleted.
22              
23             B The file-locking MAY be prone to race conditions. If you want real secure
24             expiration, please specify expiration INSIDE the session, or use a database.
25              
26             =head1 SYNOPSIS
27              
28             use strict;
29             use warnings;
30             use MVC::Neaf;
31             use MVC::Neaf::X::Session::File;
32              
33             MVC::Neaf->set_session_engine(
34             engine => MVC::Neaf::X::Session::File->new( dir => $mydir )
35             );
36             # ... define your application here
37              
38             =head1 METHODS
39              
40             =cut
41              
42 2     2   19 use Fcntl qw(:flock :seek);
  2         4  
  2         283  
43 2     2   562 use URI::Escape qw(uri_escape);
  2         1662  
  2         113  
44              
45 2     2   502 use MVC::Neaf::Util qw(JSON encode_json decode_json);
  2         11  
  2         122  
46 2     2   14 use parent qw(MVC::Neaf::X::Session);
  2         21  
  2         16  
47              
48             =head2 new( %options )
49              
50             Constructor. %options may include:
51              
52             =over
53              
54             =item * session_ttl - how long to store session data.
55              
56             =item * dir (required) - where to store files.
57              
58             =back
59              
60             =cut
61              
62             sub new {
63 3     3 1 2340 my $class = shift;
64 3         17 my $self = $class->SUPER::new( @_ );
65              
66             $self->my_croak( "dir option is mandatory" )
67 3 100 66     52 unless $self->{dir} and -d $self->{dir};
68              
69 2         13 return $self;
70             };
71              
72             =head2 save_session( $id, \%data )
73              
74             Save session data to a file.
75              
76             =cut
77              
78             sub save_session {
79 2     2 1 14 my ($self, $id, $data) = @_;
80              
81 2         7 my $raw = $self->encode_content( $data );
82 2         8 my $expire = $self->atomic_write( $id, $raw );
83 2 50       12 $expire = $self->{session_ttl} ? $self->{session_ttl}+$expire : undef;
84              
85             return {
86 2         14 id => $id,
87             expire => $expire,
88             };
89             };
90              
91             =head2 load_session( $id )
92              
93             Load session data from file.
94             Will DELETE session if session_ttl was specified and exceeded.
95              
96             =cut
97              
98             sub load_session {
99 3     3 1 1201 my ($self, $id) = @_;
100              
101 3         10 my ($raw, $expire) = $self->atomic_read( $id );
102 3 100       59 return $raw
103             ? { data => $self->decode_content( $raw ) }
104             : $raw;
105             };
106              
107             =head2 delete_session( $id )
108              
109             Remove a session, if such session is stored at all.
110              
111             =cut
112              
113             sub delete_session {
114 1     1 1 4 my ($self, $id) = @_;
115              
116 1 50       4 if (!unlink $self->get_file_name( $id )) {
117 0 0 0     0 return 0 if $!{ENOENT} or $!{EPERM} && $^O eq 'MSWin32'; # missing = ok, locked+mswin = ok
      0        
118 0         0 $self->my_croak( "Failed to delete file ".($self->get_file_name( $id ))
119             .": $!" );
120             };
121 1         49 return 1;
122             };
123              
124             =head2 atomic_read( $id )
125              
126             Internal mechanism beyond load_file.
127              
128             =cut
129              
130             sub atomic_read {
131 3     3 1 6 my ($self, $id) = @_;
132              
133 3         7 my $fname = $self->get_file_name( $id );
134 3         186 my $ok = open (my $fd, "<", $fname);
135 3 100       16 if (!$ok) {
136 1 50       11 $!{ENOENT} and return; # file missing = OK
137 0         0 $self->my_croak( "Failed to open(r) $fname: $!" );
138             };
139              
140 2 50       22 flock $fd, LOCK_SH
141             or $self->my_croak( "Failed to lock(r) $fname: $!" );
142              
143             # Remove stale sessions
144 2         27 my $ttl = $self->session_ttl;
145 2   33     32 my $expire = $ttl && [stat $fd]->[9] + $ttl;
146 2 100 66     15 if ($expire && $expire < time) {
147 1 50       6 close $fd if $^O eq 'MSWin32'; # won't delete under windows
148 1         5 $self->delete_session( $id );
149 1         729 return;
150             };
151              
152 1         5 local $/;
153 1         38 my $raw = <$fd>;
154 1 50       15 defined $raw
155             or $self->my_croak( "Failed to read from $fname: $!" );
156              
157 1         12 close $fd; # ignore errors
158 1         11 return ($raw, $expire);
159             };
160              
161             =head2 atomic_write( $id, $content )
162              
163             Internal mechanism beyond save_session.
164              
165             =cut
166              
167             sub atomic_write {
168 2     2 1 6 my ($self, $id, $raw) = @_;
169              
170 2         6 my $fname = $self->get_file_name( $id );
171 2 50       207 open (my $fd, ">>", $fname)
172             or $self->my_croak( "Failed to open(w) $fname: $!" );
173              
174 2 50       27 flock $fd, LOCK_EX
175             or $self->my_croak( "Failed to lock(w) $fname: $!" );
176              
177             # Have exclusive permissions of fname, truncate & print
178 2         52 truncate $fd, 0;
179 2         19 seek $fd, 0, SEEK_SET;
180 2 50       30 print $fd $raw
181             or $self->my_croak( "Failed to write to $fname: $!" );
182              
183 2 50       250 close $fd
184             or $self->my_croak( "Failed to sync(w) $fname: $!" );
185              
186 2         28 return time;
187             };
188              
189             =head2 get_file_name( $id )
190              
191             Convert id into filename.
192              
193             =cut
194              
195             sub get_file_name {
196 6     6 1 9 my ($self, $id) = @_;
197              
198             $self->my_croak("Storage directory not set")
199 6 50       17 unless $self->{dir};
200 6         15 return join '/', $self->{dir}, uri_escape( $id );
201             };
202              
203             =head2 encode_content( $data )
204              
205             =head2 decode_content( $raw )
206              
207             Currently JSON is used.
208              
209             =cut
210              
211             sub encode_content {
212 2     2 1 3 my ($self, $data) = @_;
213              
214 2         15 return encode_json( $data );
215             };
216              
217             sub decode_content {
218 1     1 1 4 my ($self, $raw) = @_;
219              
220 1         8 return decode_json( $raw );
221             };
222              
223             =head1 LICENSE AND COPYRIGHT
224              
225             This module is part of L suite.
226              
227             Copyright 2016-2023 Konstantin S. Uvarin C.
228              
229             This program is free software; you can redistribute it and/or modify it
230             under the terms of either: the GNU General Public License as published
231             by the Free Software Foundation; or the Artistic License.
232              
233             See L for more information.
234              
235             =cut
236              
237             1;