File Coverage

blib/lib/Dancer2/Core/Role/SessionFactory/File.pm
Criterion Covered Total %
statement 48 59 81.3
branch 15 32 46.8
condition 0 3 0.0
subroutine 11 12 91.6
pod 0 1 0.0
total 74 107 69.1


line stmt bran cond sub pod time code
1             package Dancer2::Core::Role::SessionFactory::File;
2             # ABSTRACT: Role for file-based session factories
3             $Dancer2::Core::Role::SessionFactory::File::VERSION = '1.0.0';
4 4     4   11648 use Moo::Role;
  4         14  
  4         30  
5             with 'Dancer2::Core::Role::SessionFactory';
6              
7 4     4   1990 use Carp 'croak';
  4         13  
  4         234  
8 4     4   31 use Dancer2::Core::Types;
  4         11  
  4         42  
9 4     4   52037 use Dancer2::FileUtils qw(path set_file_mode escape_filename);
  4         16  
  4         346  
10 4     4   31 use Fcntl ':flock';
  4         8  
  4         597  
11 4     4   2096 use File::Copy ();
  4         9784  
  4         3218  
12              
13             #--------------------------------------------------------------------------#
14             # Required by classes consuming this role
15             #--------------------------------------------------------------------------#
16              
17             requires '_suffix'; # '.yml', '.json', etc.
18             requires '_thaw_from_handle'; # given handle, return session 'data' field
19             requires '_freeze_to_handle'; # given handle and data, serialize it
20              
21              
22             #--------------------------------------------------------------------------#
23             # Attributes and methods
24             #--------------------------------------------------------------------------#
25              
26             has session_dir => (
27             is => 'ro',
28             isa => Str,
29             default => sub { path( '.', 'sessions' ) },
30             );
31              
32             sub BUILD {
33 4     4 0 381 my $self = shift;
34              
35 4 100       202 if ( !-d $self->session_dir ) {
36 1 50       148 mkdir $self->session_dir
37             or croak "Unable to create session dir : "
38             . $self->session_dir . ' : '
39             . $!;
40             }
41             }
42              
43             sub _sessions {
44 0     0   0 my ($self) = @_;
45 0         0 my $sessions = [];
46              
47 0 0       0 opendir( my $dh, $self->session_dir )
48             or croak "Unable to open directory " . $self->session_dir . " : $!";
49              
50 0         0 my $suffix = $self->_suffix;
51              
52 0         0 while ( my $file = readdir($dh) ) {
53 0 0 0     0 next if $file eq '.' || $file eq '..';
54 0 0       0 if ( $file =~ /(\w+)\Q$suffix\E/ ) {
55 0         0 push @{$sessions}, $1;
  0         0  
56             }
57             }
58 0         0 closedir($dh);
59              
60 0         0 return $sessions;
61             }
62              
63             sub _retrieve {
64 17     17   53 my ( $self, $id ) = @_;
65 17         84 my $session_file = path( $self->session_dir, escape_filename($id) . $self->_suffix );
66              
67 17 100       551 croak "Invalid session ID: $id" unless -f $session_file;
68              
69 16 50       710 open my $fh, '+<', $session_file or die "Can't open '$session_file': $!\n";
70 16 50       194 flock $fh, LOCK_SH or die "Can't lock file '$session_file': $!\n";
71 16         94 my $data = $self->_thaw_from_handle($fh);
72 16 50       55274 close $fh or die "Can't close '$session_file': $!\n";
73              
74 16         154 return $data;
75             }
76              
77             sub _change_id {
78 1     1   8 my ($self, $old_id, $new_id) = @_;
79              
80 1         6 my $old_path =
81             path($self->session_dir, escape_filename($old_id) . $self->_suffix);
82              
83 1 50       28 return if !-f $old_path;
84              
85 1         11 my $new_path =
86             path($self->session_dir, escape_filename($new_id) . $self->_suffix);
87              
88 1         11 File::Copy::move($old_path, $new_path);
89             }
90              
91             sub _destroy {
92 5     5   16 my ( $self, $id ) = @_;
93 5         22 my $session_file = path( $self->session_dir, escape_filename($id) . $self->_suffix );
94 5 50       123 return if !-f $session_file;
95              
96 5         449 unlink $session_file;
97             }
98              
99             sub _flush {
100 21     21   369 my ( $self, $id, $data ) = @_;
101 21         104 my $session_file = path( $self->session_dir, escape_filename($id) . $self->_suffix );
102              
103 21 50       42117 open my $fh, '>', $session_file or die "Can't open '$session_file': $!\n";
104 21 50       368 flock $fh, LOCK_EX or die "Can't lock file '$session_file': $!\n";
105 21 50       273 seek $fh, 0, 0 or die "Can't seek in file '$session_file': $!\n";
106 21 50       500 truncate $fh, 0 or die "Can't truncate file '$session_file': $!\n";
107 21         135 set_file_mode($fh);
108 21         131 $self->_freeze_to_handle( $fh, $data );
109 21 50       2629 close $fh or die "Can't close '$session_file': $!\n";
110              
111 21         189 return $data;
112             }
113              
114             1;
115              
116             __END__
117              
118             =pod
119              
120             =encoding UTF-8
121              
122             =head1 NAME
123              
124             Dancer2::Core::Role::SessionFactory::File - Role for file-based session factories
125              
126             =head1 VERSION
127              
128             version 1.0.0
129              
130             =head1 DESCRIPTION
131              
132             This is a specialized SessionFactory role for storing session
133             data in files.
134              
135             This role manages the files. Classes consuming it only need to handle
136             serialization and deserialization.
137              
138             Classes consuming this must satisfy three requirements: C<_suffix>,
139             C<_freeze_to_handle> and C<_thaw_from_handle>.
140              
141             package Dancer2::Session::XYX;
142              
143             use Dancer2::Core::Types;
144             use Moo;
145              
146             has _suffix => (
147             is => 'ro',
148             isa => Str,
149             default => sub { '.xyz' },
150             );
151              
152             with 'Dancer2::Core::Role::SessionFactory::File';
153              
154             sub _freeze_to_handle {
155             my ($self, $fh, $data) = @_;
156              
157             # ... do whatever to get data into $fh
158              
159             return;
160             }
161              
162             sub _thaw_from_handle {
163             my ($self, $fh) = @_;
164             my $data;
165              
166             # ... do whatever to get data from $fh
167              
168             return $data;
169             }
170              
171             1;
172              
173             =head1 ATTRIBUTES
174              
175             =head2 session_dir
176              
177             Where to store the session files. Defaults to "./sessions".
178              
179             =head1 AUTHOR
180              
181             Dancer Core Developers
182              
183             =head1 COPYRIGHT AND LICENSE
184              
185             This software is copyright (c) 2023 by Alexis Sukrieh.
186              
187             This is free software; you can redistribute it and/or modify it under
188             the same terms as the Perl 5 programming language system itself.
189              
190             =cut