line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Mojolicious::Plugin::SimpleSession; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
26717
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
32
|
|
4
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
38
|
|
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
5
|
use base 'Mojolicious::Plugin'; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
971
|
|
7
|
1
|
|
|
1
|
|
14827
|
use Digest; |
|
1
|
|
|
|
|
640
|
|
|
1
|
|
|
|
|
30
|
|
8
|
1
|
|
|
1
|
|
1196
|
use Storable qw/store retrieve freeze/; |
|
1
|
|
|
|
|
3554
|
|
|
1
|
|
|
|
|
101
|
|
9
|
1
|
|
|
1
|
|
975
|
use File::Spec::Functions qw/catfile tmpdir/; |
|
1
|
|
|
|
|
977
|
|
|
1
|
|
|
|
|
72
|
|
10
|
1
|
|
|
1
|
|
7
|
use Carp qw/croak/; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
947
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
my $max_time = 60 * 60; # 1 hour |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
sub register { |
16
|
0
|
|
|
0
|
1
|
|
my ( $self, $app ) = @_; |
17
|
|
|
|
|
|
|
|
18
|
0
|
|
|
|
|
|
my $stash_key = 'session'; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
$app->plugins->add_hook( |
21
|
|
|
|
|
|
|
before_dispatch => sub { |
22
|
0
|
|
|
0
|
|
|
my ( $self, $c ) = @_; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# fetch session from cookie if it exists, |
25
|
|
|
|
|
|
|
# check for validity and load the data into |
26
|
|
|
|
|
|
|
# the data structure. |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
# grab session hash from cookie, if we can. |
29
|
0
|
|
|
|
|
|
my $oldcookies = $c->tx->req->cookies; |
30
|
0
|
|
|
|
|
|
my $cookie_hash; |
31
|
0
|
|
|
|
|
|
foreach my $cookie (@$oldcookies) { |
32
|
0
|
0
|
|
|
|
|
if ( $cookie->name eq 'session' ) { |
33
|
0
|
|
|
|
|
|
$cookie_hash = $cookie->value->to_string; |
34
|
0
|
|
|
|
|
|
last; |
35
|
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
0
|
|
|
|
|
|
my $session_data = {}; |
39
|
0
|
0
|
|
|
|
|
if ( _cookie_valid($cookie_hash) ) { |
40
|
0
|
|
|
|
|
|
eval { |
41
|
0
|
|
|
|
|
|
$session_data = retrieve(_hash_filename($cookie_hash)); |
42
|
|
|
|
|
|
|
}; |
43
|
0
|
0
|
|
|
|
|
croak "Could not import session: $@" if $@; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# No cookie was given to us, or there was no file for it, |
47
|
|
|
|
|
|
|
# so create it. |
48
|
|
|
|
|
|
|
else { |
49
|
0
|
|
|
|
|
|
my $cookie_hash_value |
50
|
|
|
|
|
|
|
= time() . rand(1) . $c->tx->remote_address; |
51
|
0
|
|
|
|
|
|
my $digester = Digest->new('SHA-1'); |
52
|
0
|
|
|
|
|
|
$digester->add($cookie_hash_value); |
53
|
0
|
|
|
|
|
|
$cookie_hash = $digester->hexdigest; |
54
|
|
|
|
|
|
|
|
55
|
0
|
|
|
|
|
|
my $cookie = Mojo::Cookie::Response->new; |
56
|
0
|
|
|
|
|
|
$cookie->name('session'); |
57
|
0
|
|
|
|
|
|
$cookie->path('/'); |
58
|
0
|
|
|
|
|
|
$cookie->value($cookie_hash); |
59
|
0
|
|
|
|
|
|
$c->tx->res->cookies($cookie); |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# Create the disk file to match, and store a checksum in memory |
62
|
|
|
|
|
|
|
# so we can later determine if it has changed. |
63
|
0
|
|
|
|
|
|
delete $session_data->{_checksum}; |
64
|
0
|
|
|
|
|
|
_dump_session( _hash_filename($cookie_hash), $session_data ); |
65
|
0
|
|
|
|
|
|
$session_data->{_checksum} = _checksum_data($session_data); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
0
|
|
|
|
|
|
$session_data->{cookie_hash} = $cookie_hash; |
69
|
0
|
|
|
|
|
|
$c->stash->{$stash_key} = $session_data; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
} |
72
|
0
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
$app->plugins->add_hook( |
75
|
|
|
|
|
|
|
after_dispatch => sub { |
76
|
0
|
|
|
0
|
|
|
my ( $self, $c ) = @_; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# Update the session data on-disk with the new |
79
|
|
|
|
|
|
|
# data from the data structure, if the data structure has |
80
|
|
|
|
|
|
|
# been changed. |
81
|
0
|
|
|
|
|
|
my $session_data = $c->stash->{$stash_key}; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
# hash is in session data |
84
|
0
|
|
|
|
|
|
my $cookie_hash = $session_data->{cookie_hash}; |
85
|
0
|
|
|
|
|
|
delete $session_data->{cookie_hash}; |
86
|
|
|
|
|
|
|
|
87
|
0
|
|
0
|
|
|
|
my $checksum = $session_data->{_checksum} || ''; |
88
|
0
|
|
|
|
|
|
delete $session_data->{_checksum}; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# Only store if we have changed the data. |
91
|
0
|
0
|
0
|
|
|
|
if ($cookie_hash && (_checksum_data($session_data) ne $checksum)) { |
92
|
0
|
|
|
|
|
|
$session_data->{_checksum} = _checksum_data($session_data); |
93
|
0
|
|
|
|
|
|
_dump_session( _hash_filename($cookie_hash), $session_data ); |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
# And while we are visiting the disk, clean up. |
96
|
0
|
|
|
|
|
|
_cull_sessions(); |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
} |
99
|
0
|
|
|
|
|
|
); |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
# Calculate a checksum on some data. |
103
|
|
|
|
|
|
|
sub _checksum_data { |
104
|
0
|
|
|
0
|
|
|
my $ref = shift; |
105
|
0
|
|
|
|
|
|
my $digester = Digest->new('SHA-1'); |
106
|
0
|
|
|
|
|
|
$digester->add(freeze($ref)); |
107
|
0
|
|
|
|
|
|
return $digester->hexdigest; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub _cookie_valid { |
111
|
0
|
|
|
0
|
|
|
my $cookie_hash = shift; |
112
|
0
|
|
|
|
|
|
my $filename = _hash_filename($cookie_hash); |
113
|
0
|
0
|
|
|
|
|
return 0 unless ( -e $filename ); |
114
|
0
|
0
|
|
|
|
|
return 0 if ( _too_old( $filename ) ); |
115
|
0
|
|
|
|
|
|
return 1; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub _cull_sessions { |
119
|
0
|
|
|
0
|
|
|
my $dir = tmpdir(); |
120
|
0
|
|
|
|
|
|
my $glob_pattern = catfile($dir, "*.ses"); |
121
|
0
|
|
|
|
|
|
foreach my $session_file (glob $glob_pattern) { |
122
|
0
|
0
|
|
|
|
|
if (_too_old($session_file)) { |
123
|
0
|
|
|
|
|
|
unlink $session_file; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
sub _too_old { |
129
|
0
|
|
|
0
|
|
|
my $file = shift; |
130
|
0
|
0
|
|
|
|
|
return 1 if ( ( time() - (stat($file))[8] ) > $max_time ); |
131
|
0
|
|
|
|
|
|
return 0; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
sub _dump_session { |
135
|
0
|
|
|
0
|
|
|
my ( $filename, $session_data ) = @_; |
136
|
0
|
|
|
|
|
|
my $tmp_filename = $filename . ".tmp.$$"; |
137
|
0
|
|
|
|
|
|
store($session_data, $tmp_filename); |
138
|
0
|
|
0
|
|
|
|
rename $tmp_filename, |
139
|
|
|
|
|
|
|
$filename || croak "Could not rename $tmp_filename: $!"; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
sub _hash_filename { |
143
|
0
|
|
|
0
|
|
|
my $hash = shift; |
144
|
0
|
|
|
|
|
|
return catfile( tmpdir(), "$hash.ses" ); |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
=head1 NAME |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
Mojolicious::Plugin::SimpleSession - Exceedingly Simple Mojolicious Sessions |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=head1 VERSION |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
Version 0.01 |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=cut |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
our $VERSION = '0.01'; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=head1 SYNOPSIS |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
In the C subroutine of your Mojolicious application, add: |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
$self->plugin('simple_session'); |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
That's it! |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Inside your application, you can now reference a hashref called 'session' in |
168
|
|
|
|
|
|
|
the stash, like this: |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
my $count = $self->stash->{session}->{count}; |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
$count++; |
173
|
|
|
|
|
|
|
$self->stash->{session}->{count} = $count; |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
Session data is preserved across requests for this user (identified by their |
176
|
|
|
|
|
|
|
cookie). |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
If you need to be able to control expiry, use a database store, or basically |
179
|
|
|
|
|
|
|
do anything more intelligent with your sessions, you probably want to look |
180
|
|
|
|
|
|
|
at L. |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
=head1 FUNCTIONS |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=over 4 |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=item register |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
Called by the Mojolicious framework when the plugin is registered. |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
=back |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=head1 AUTHOR |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
Justin Hawkins, C<< >> |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=head1 BUGS |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
199
|
|
|
|
|
|
|
the web interface at L. I will be notified, and then you'll |
200
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
=head1 SUPPORT |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
perldoc Mojolicious::Plugin::SimpleSession |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
You can also look for information at: http://hawkins.id.au/notes/perl/modules/mojolicious::plugin::simplesession |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=over 4 |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
L |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
L |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
=item * CPAN Ratings |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
L |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
=item * Search CPAN |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
L |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
=back |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
Copyright 2010 Justin Hawkins. |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
239
|
|
|
|
|
|
|
under the terms of either: the GNU General Public License as published |
240
|
|
|
|
|
|
|
by the Free Software Foundation; or the Artistic License. |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
See http://dev.perl.org/licenses/ for more information. |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
=cut |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
1; # End of Mojolicious::Plugin::SimpleSession |