line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
############################################################################# |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Apache::Session |
4
|
|
|
|
|
|
|
# Apache persistent user sessions |
5
|
|
|
|
|
|
|
# Copyright(c) 1998, 1999, 2000, 2001, 2004 Jeffrey William Baker (jwbaker@acm.org) |
6
|
|
|
|
|
|
|
# Distribute under the Perl License |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
############################################################################# |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 NAME |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
Apache::Session - A persistence framework for session data |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=head1 SYNOPSIS |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
use Apache::Session::MySQL; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
my %session; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
#make a fresh session for a first-time visitor |
21
|
|
|
|
|
|
|
tie %session, 'Apache::Session::MySQL'; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
#stick some stuff in it |
24
|
|
|
|
|
|
|
$session{visa_number} = "1234 5678 9876 5432"; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
#get the session id for later use |
27
|
|
|
|
|
|
|
my $id = $session{_session_id}; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
#...time passes... |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
#get the session data back out again during some other request |
32
|
|
|
|
|
|
|
my %session; |
33
|
|
|
|
|
|
|
tie %session, 'Apache::Session::MySQL', $id; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
validate($session{visa_number}); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
#delete a session from the object store permanently |
38
|
|
|
|
|
|
|
tied(%session)->delete; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=head1 DESCRIPTION |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
Apache::Session is a persistence framework which is particularly useful |
44
|
|
|
|
|
|
|
for tracking session data between httpd requests. Apache::Session is |
45
|
|
|
|
|
|
|
designed to work with Apache and mod_perl, but it should work under |
46
|
|
|
|
|
|
|
CGI and other web servers, and it also works outside of a web server |
47
|
|
|
|
|
|
|
altogether. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
Apache::Session consists of five components: the interface, the object store, |
50
|
|
|
|
|
|
|
the lock manager, the ID generator, and the serializer. The interface is |
51
|
|
|
|
|
|
|
defined in Session.pm, which is meant to be easily subclassed. The object |
52
|
|
|
|
|
|
|
store can be the filesystem, a Berkeley DB, a MySQL DB, an Oracle DB, a |
53
|
|
|
|
|
|
|
Postgres DB, Sybase, or Informix. Locking is done by lock files, semaphores, or |
54
|
|
|
|
|
|
|
the locking capabilities of the various databases. Serialization is done via |
55
|
|
|
|
|
|
|
Storable, and optionally ASCII-fied via MIME or pack(). ID numbers are |
56
|
|
|
|
|
|
|
generated via MD5. The reader is encouraged to extend these capabilities to |
57
|
|
|
|
|
|
|
meet his own requirements. |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
A derived class of Apache::Session is used to tie together the three following |
60
|
|
|
|
|
|
|
components. The derived class inherits the interface from Apache::Session, and |
61
|
|
|
|
|
|
|
specifies which store and locker classes to use. Apache::Session::MySQL, for |
62
|
|
|
|
|
|
|
instance, uses the MySQL storage class and also the MySQL locking class. You |
63
|
|
|
|
|
|
|
can easily plug in your own object store or locker class. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
=head1 INTERFACE |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
The interface to Apache::Session is very simple: tie a hash to the |
68
|
|
|
|
|
|
|
desired class and use the hash as normal. The constructor takes two |
69
|
|
|
|
|
|
|
optional arguments. The first argument is the desired session ID |
70
|
|
|
|
|
|
|
number, or undef for a new session. The second argument is a hash |
71
|
|
|
|
|
|
|
of options that will be passed to the object store and locker classes. |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=head2 tieing the session |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
Get a new session using DBI: |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
tie %session, 'Apache::Session::MySQL', undef, |
78
|
|
|
|
|
|
|
{ DataSource => 'dbi:mysql:sessions' }; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
Restore an old session from the database: |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
tie %session, 'Apache::Session::MySQL', $session_id, |
83
|
|
|
|
|
|
|
{ DataSource => 'dbi:mysql:sessions' }; |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=head2 Storing and retrieving data to and from the session |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
Hey, how much easier could it get? |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
$session{first_name} = "Chuck"; |
91
|
|
|
|
|
|
|
$session{an_array_ref} = [ $one, $two, $three ]; |
92
|
|
|
|
|
|
|
$session{an_object} = Some::Class->new; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head2 Reading the session ID |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
The session ID is the only magic entry in the session object, |
97
|
|
|
|
|
|
|
but anything beginning with an "_" is considered reserved for |
98
|
|
|
|
|
|
|
future use. |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
my $id = $session{_session_id}; |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=head2 Permanently removing the session from storage |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
tied(%session)->delete; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=head1 BEHAVIOR |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
Apache::Session tries to behave the way the author believes that |
109
|
|
|
|
|
|
|
you would expect. When you create a new session, Session immediately |
110
|
|
|
|
|
|
|
saves the session to the data store, or calls die() if it cannot. It |
111
|
|
|
|
|
|
|
also obtains an exclusive lock on the session object. If you retrieve |
112
|
|
|
|
|
|
|
an existing session, Session immediately restores the object from storage, |
113
|
|
|
|
|
|
|
or calls die() in case of an error. Session also obtains a non-exclusive |
114
|
|
|
|
|
|
|
lock on the session. |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
As you put data into the session hash, Session squirrels it away for |
117
|
|
|
|
|
|
|
later use. When you untie() the session hash, or it passes out of |
118
|
|
|
|
|
|
|
scope, Session checks to see if anything has changed. If so, Session |
119
|
|
|
|
|
|
|
gains an exclusive lock and writes the session to the data store. |
120
|
|
|
|
|
|
|
It then releases any locks it has acquired. |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
Note that Apache::Session does only a shallow check to see if anything has |
123
|
|
|
|
|
|
|
changed. If nothing changes in the top level tied hash, the data will not be |
124
|
|
|
|
|
|
|
updated in the backing store. You are encouraged to timestamp the session hash |
125
|
|
|
|
|
|
|
so that it is sure to be updated. |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
When you call the delete() method on the session object, the |
128
|
|
|
|
|
|
|
object is immediately removed from the object store, if possible. |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
When Session encounters an error, it calls die(). You will probably |
131
|
|
|
|
|
|
|
want to wrap your session logic in an eval block to trap these errors. |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
=head1 LOCKING AND TRANSACTIONS |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
By default, most Apache::Session implementations only do locking to prevent |
136
|
|
|
|
|
|
|
data corruption. The locking scheme does not provide transactional |
137
|
|
|
|
|
|
|
consistency, such as you might get from a relational database. If you desire |
138
|
|
|
|
|
|
|
transactional consistency, you must provide the Transaction argument with a |
139
|
|
|
|
|
|
|
true value when you tie the session hash. For example: |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
tie %s, 'Apache::Session::File', $id { |
142
|
|
|
|
|
|
|
Directory => '/tmp/sessions', |
143
|
|
|
|
|
|
|
LockDirectory => '/var/lock/sessions', |
144
|
|
|
|
|
|
|
Transaction => 1 |
145
|
|
|
|
|
|
|
}; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
Note that the Transaction argument has no practical effect on the MySQL and |
148
|
|
|
|
|
|
|
Postgres implementations. The MySQL implementation only supports exclusive |
149
|
|
|
|
|
|
|
locking, and the Postgres implementation uses the transaction features of that |
150
|
|
|
|
|
|
|
database. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=head1 IMPLEMENTATION |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
The way you implement Apache::Session depends on what you are |
155
|
|
|
|
|
|
|
trying to accomplish. Here are some hints on which classes to |
156
|
|
|
|
|
|
|
use in what situations |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=head1 STRATEGIES |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
Apache::Session is mainly designed to track user session between |
161
|
|
|
|
|
|
|
http requests. However, it can also be used for any situation |
162
|
|
|
|
|
|
|
where data persistence is desirable. For example, it could be |
163
|
|
|
|
|
|
|
used to share global data between your httpd processes. The |
164
|
|
|
|
|
|
|
following examples are short mod_perl programs which demonstrate |
165
|
|
|
|
|
|
|
some session handling basics. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
=head2 Sharing data between Apache processes |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
When you share data between Apache processes, you need to decide on a |
170
|
|
|
|
|
|
|
session ID number ahead of time and make sure that an object with that |
171
|
|
|
|
|
|
|
ID number is in your object store before starting your Apache. How you |
172
|
|
|
|
|
|
|
accomplish that is your own business. I use the session ID "1". Here |
173
|
|
|
|
|
|
|
is a short program in which we use Apache::Session to store out |
174
|
|
|
|
|
|
|
database access information. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
use Apache; |
177
|
|
|
|
|
|
|
use Apache::Session::File; |
178
|
|
|
|
|
|
|
use DBI; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
use strict; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
my %global_data; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
eval { |
185
|
|
|
|
|
|
|
tie %global_data, 'Apache::Session::File', 1, |
186
|
|
|
|
|
|
|
{Directory => '/tmp/sessiondata'}; |
187
|
|
|
|
|
|
|
}; |
188
|
|
|
|
|
|
|
if ($@) { |
189
|
|
|
|
|
|
|
die "Global data is not accessible: $@"; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
my $dbh = DBI->connect($global_data{datasource}, |
193
|
|
|
|
|
|
|
$global_data{username}, $global_data{password}) || die $DBI::errstr; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
undef %global_data; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
#program continues... |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
As shown in this example, you should undef or untie your session hash |
200
|
|
|
|
|
|
|
as soon as you are done with it. This will free up any locks associated |
201
|
|
|
|
|
|
|
with your process. |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
=head2 Tracking users with cookies |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
The choice of whether to use cookies or path info to track user IDs |
206
|
|
|
|
|
|
|
is a rather religious topic among Apache users. This example uses cookies. |
207
|
|
|
|
|
|
|
The implementation of a path info system is left as an exercise for the |
208
|
|
|
|
|
|
|
reader. |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
Note that Apache::Session::Generate::ModUsertrack uses Apache's mod_usertrack |
211
|
|
|
|
|
|
|
cookies to generate and maintain session IDs. |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
use Apache::Session::MySQL; |
214
|
|
|
|
|
|
|
use Apache; |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
use strict; |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
#read in the cookie if this is an old session |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
my $r = Apache->request; |
221
|
|
|
|
|
|
|
my $cookie = $r->header_in('Cookie'); |
222
|
|
|
|
|
|
|
$cookie =~ s/SESSION_ID=(\w*)/$1/; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
#create a session object based on the cookie we got from the browser, |
225
|
|
|
|
|
|
|
#or a new session if we got no cookie |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
my %session; |
228
|
|
|
|
|
|
|
tie %session, 'Apache::Session::MySQL', $cookie, { |
229
|
|
|
|
|
|
|
DataSource => 'dbi:mysql:sessions', #these arguments are |
230
|
|
|
|
|
|
|
UserName => 'mySQL_user', #required when using |
231
|
|
|
|
|
|
|
Password => 'password', #MySQL.pm |
232
|
|
|
|
|
|
|
LockDataSource => 'dbi:mysql:sessions', |
233
|
|
|
|
|
|
|
LockUserName => 'mySQL_user', |
234
|
|
|
|
|
|
|
LockPassword => 'password' |
235
|
|
|
|
|
|
|
}; |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
#Might be a new session, so lets give them their cookie back |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
my $session_cookie = "SESSION_ID=$session{_session_id};"; |
240
|
|
|
|
|
|
|
$r->header_out("Set-Cookie" => $session_cookie); |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
#program continues... |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=head1 SEE ALSO |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Apache::Session::MySQL, Apache::Session::Postgres, Apache::Session::File, |
247
|
|
|
|
|
|
|
Apache::Session::DB_File, Apache::Session::Oracle, Apache::Session::Sybase |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
The O Reilly book "Apache Modules in Perl and C", by Doug MacEachern and |
250
|
|
|
|
|
|
|
Lincoln Stein, has a chapter on keeping state. |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
CGI::Session uses OO interface to do same thing. It is better maintained, |
253
|
|
|
|
|
|
|
but less possibilies. |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
Catalyst::Plugin::Session - support of sessions in Catalyst |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
Session - OO interface to Apache::Session |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=head1 LICENSE |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
Under the same terms as Perl itself. |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head1 AUTHORS |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
Alexandr Ciornii, L<http://chorny.net> - current maintainer |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
Jeffrey Baker <jwbaker@acm.org> is the author of |
268
|
|
|
|
|
|
|
Apache::Session. |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
Tatsuhiko Miyagawa <miyagawa@bulknews.net> is the author of |
271
|
|
|
|
|
|
|
Generate::ModUniqueID and Generate::ModUsertrack |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
Erik Rantapaa <rantapaa@fanbuzz.com> found errors in both Lock::File |
274
|
|
|
|
|
|
|
and Store::File |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
Bart Schaefer <schaefer@zanshin.com> notified me of a bug in |
277
|
|
|
|
|
|
|
Lock::File. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
Chris Winters <cwinters@intes.net> contributed the Sybase code. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Michael Schout <mschout@gkg.net> fixed a commit policy bug in 1.51. |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
Andreas J. Koenig <andreas.koenig@anima.de> contributed valuable CPAN |
284
|
|
|
|
|
|
|
advice and also Apache::Session::Tree and Apache::Session::Counted. |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
Gerald Richter <richter@ecos.de> had the idea for a tied hash interface |
287
|
|
|
|
|
|
|
and provided the initial code for it. He also uses Apache::Session in |
288
|
|
|
|
|
|
|
his Embperl module and is the author of Apache::Session::Embperl |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
Jochen Wiedmann <joe@ipsoft.de> contributed patches for bugs and |
291
|
|
|
|
|
|
|
improved performance. |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
Steve Shreeve <shreeve@uci.edu> squashed a bug in 0.99.0 whereby |
294
|
|
|
|
|
|
|
a cleared hash or deleted key failed to set the modified bit. |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Peter Kaas <Peter.Kaas@lunatech.com> sent quite a bit of feedback |
297
|
|
|
|
|
|
|
with ideas for interface improvements. |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
Randy Harmon <rjharmon@uptimecomputers.com> contributed the original |
300
|
|
|
|
|
|
|
storage-independent object interface with input from: |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
Bavo De Ridder <bavo@ace.ulyssis.student.kuleuven.ac.be> |
303
|
|
|
|
|
|
|
Jules Bean <jmlb2@hermes.cam.ac.uk> |
304
|
|
|
|
|
|
|
Lincoln Stein <lstein@cshl.org> |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
Jamie LeTaul <jletual@kmtechnologies.com> fixed file locking on Windows. |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
Scott McWhirter <scott@surreytech.co.uk> contributed verbose error messages for |
309
|
|
|
|
|
|
|
file locking. |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
Corris Randall <corris@line6.net> gave us the option to use any table name in |
312
|
|
|
|
|
|
|
the MySQL store. |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
Oliver Maul <oliver.maul@ixos.de> updated the Sybase modules |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
Innumerable users sent a patch for the reversed file age test in the file |
317
|
|
|
|
|
|
|
locking module. |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
Langen Mike <mike.langen@tamedia.ch> contributed Informix modules. |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
=cut |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
package Apache::Session; |
324
|
|
|
|
|
|
|
|
325
|
2
|
|
|
2
|
|
15
|
use strict; |
|
2
|
|
|
|
|
60
|
|
|
2
|
|
|
|
|
119
|
|
326
|
2
|
|
|
2
|
|
13
|
use vars qw($VERSION); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
4306
|
|
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
$VERSION = '1.93'; |
329
|
|
|
|
|
|
|
$VERSION = eval $VERSION; |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
#State constants |
332
|
|
|
|
|
|
|
# |
333
|
|
|
|
|
|
|
#These constants are used in a bitmask to store the |
334
|
|
|
|
|
|
|
#object's status. New indicates that the object |
335
|
|
|
|
|
|
|
#has not yet been inserted into the object store. |
336
|
|
|
|
|
|
|
#Modified indicates that a member value has been |
337
|
|
|
|
|
|
|
#changed. Deleted is set when delete() is called. |
338
|
|
|
|
|
|
|
#Synced indicates that an object has been materialized |
339
|
|
|
|
|
|
|
#from the datastore. |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
sub NEW () {1}; |
342
|
|
|
|
|
|
|
sub MODIFIED () {2}; |
343
|
|
|
|
|
|
|
sub DELETED () {4}; |
344
|
|
|
|
|
|
|
sub SYNCED () {8}; |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
#State methods |
349
|
|
|
|
|
|
|
# |
350
|
|
|
|
|
|
|
#These methods aren't used anymore for performance reasons. I'll |
351
|
|
|
|
|
|
|
#keep them around for reference |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
|
355
|
0
|
|
|
0
|
0
|
0
|
sub is_new { $_[0]->{status} & NEW } |
356
|
0
|
|
|
0
|
0
|
0
|
sub is_modified { $_[0]->{status} & MODIFIED } |
357
|
0
|
|
|
0
|
0
|
0
|
sub is_deleted { $_[0]->{status} & DELETED } |
358
|
0
|
|
|
0
|
0
|
0
|
sub is_synced { $_[0]->{status} & SYNCED } |
359
|
|
|
|
|
|
|
|
360
|
0
|
|
|
0
|
0
|
0
|
sub make_new { $_[0]->{status} |= NEW } |
361
|
0
|
|
|
0
|
0
|
0
|
sub make_modified { $_[0]->{status} |= MODIFIED } |
362
|
0
|
|
|
0
|
0
|
0
|
sub make_deleted { $_[0]->{status} |= DELETED } |
363
|
0
|
|
|
0
|
0
|
0
|
sub make_synced { $_[0]->{status} |= SYNCED } |
364
|
|
|
|
|
|
|
|
365
|
0
|
|
|
0
|
0
|
0
|
sub make_old { $_[0]->{status} &= ($_[0]->{status} ^ NEW) } |
366
|
0
|
|
|
0
|
0
|
0
|
sub make_unmodified { $_[0]->{status} &= ($_[0]->{status} ^ MODIFIED) } |
367
|
0
|
|
|
0
|
0
|
0
|
sub make_undeleted { $_[0]->{status} &= ($_[0]->{status} ^ DELETED) } |
368
|
0
|
|
|
0
|
0
|
0
|
sub make_unsynced { $_[0]->{status} &= ($_[0]->{status} ^ SYNCED) } |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
#Tie methods |
373
|
|
|
|
|
|
|
# |
374
|
|
|
|
|
|
|
#Here we are hiding our complex data persistence framework behind |
375
|
|
|
|
|
|
|
#a simple hash. See the perltie manpage. |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
sub TIEHASH { |
380
|
5
|
|
|
5
|
|
9244
|
my $class = shift; |
381
|
|
|
|
|
|
|
|
382
|
5
|
|
|
|
|
12
|
my $session_id = shift; |
383
|
5
|
|
50
|
|
|
19
|
my $args = shift || {}; |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
#Set-up the data structure and make it an object |
386
|
|
|
|
|
|
|
#of our class |
387
|
|
|
|
|
|
|
|
388
|
5
|
|
|
|
|
53
|
my $self = { |
389
|
|
|
|
|
|
|
args => $args, |
390
|
|
|
|
|
|
|
data => { _session_id => $session_id }, |
391
|
|
|
|
|
|
|
serialized => undef, |
392
|
|
|
|
|
|
|
lock => 0, |
393
|
|
|
|
|
|
|
status => 0, |
394
|
|
|
|
|
|
|
lock_manager => undef, # These two are object refs ... |
395
|
|
|
|
|
|
|
object_store => undef, |
396
|
|
|
|
|
|
|
generate => undef, # but these three are subroutine refs |
397
|
|
|
|
|
|
|
serialize => undef, |
398
|
|
|
|
|
|
|
unserialize => undef, |
399
|
|
|
|
|
|
|
}; |
400
|
|
|
|
|
|
|
|
401
|
5
|
|
|
|
|
18
|
bless $self, $class; |
402
|
|
|
|
|
|
|
|
403
|
5
|
|
|
|
|
22
|
$self->populate; |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
#If a session ID was passed in, this is an old hash. |
407
|
|
|
|
|
|
|
#If not, it is a fresh one. |
408
|
|
|
|
|
|
|
|
409
|
5
|
100
|
66
|
|
|
30
|
if (defined $session_id && $session_id) { |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
#check the session ID for remote exploitation attempts |
412
|
|
|
|
|
|
|
#this will die() on suspicious session IDs. |
413
|
|
|
|
|
|
|
|
414
|
2
|
|
|
|
|
3
|
&{$self->{validate}}($self); |
|
2
|
|
|
|
|
11
|
|
415
|
|
|
|
|
|
|
|
416
|
1
|
50
|
33
|
|
|
4
|
if (exists $args->{Transaction} && $args->{Transaction}) { |
417
|
0
|
|
|
|
|
0
|
$self->acquire_write_lock; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
1
|
|
|
|
|
3
|
$self->{status} &= ($self->{status} ^ NEW); |
421
|
1
|
|
|
|
|
13
|
$self->restore; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
else { |
424
|
3
|
|
|
|
|
8
|
$self->{status} |= NEW; |
425
|
3
|
|
|
|
|
5
|
&{$self->{generate}}($self); |
|
3
|
|
|
|
|
19
|
|
426
|
3
|
|
|
|
|
24
|
$self->save; |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
|
429
|
4
|
|
|
|
|
20
|
return $self; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub FETCH { |
433
|
5
|
|
|
5
|
|
1605
|
my $self = shift; |
434
|
5
|
|
|
|
|
7
|
my $key = shift; |
435
|
|
|
|
|
|
|
|
436
|
5
|
|
|
|
|
24
|
return $self->{data}->{$key}; |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
sub STORE { |
440
|
2
|
|
|
2
|
|
20
|
my $self = shift; |
441
|
2
|
|
|
|
|
3
|
my $key = shift; |
442
|
2
|
|
|
|
|
3
|
my $value = shift; |
443
|
|
|
|
|
|
|
|
444
|
2
|
|
|
|
|
5
|
$self->{data}->{$key} = $value; |
445
|
|
|
|
|
|
|
|
446
|
2
|
|
|
|
|
4
|
$self->{status} |= MODIFIED; |
447
|
|
|
|
|
|
|
|
448
|
2
|
|
|
|
|
8
|
return $self->{data}->{$key}; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
sub DELETE { |
452
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
453
|
0
|
|
|
|
|
0
|
my $key = shift; |
454
|
|
|
|
|
|
|
|
455
|
0
|
|
|
|
|
0
|
$self->{status} |= MODIFIED; |
456
|
|
|
|
|
|
|
|
457
|
0
|
|
|
|
|
0
|
delete $self->{data}->{$key}; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
sub CLEAR { |
461
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
462
|
|
|
|
|
|
|
|
463
|
0
|
|
|
|
|
0
|
$self->{status} |= MODIFIED; |
464
|
|
|
|
|
|
|
|
465
|
0
|
|
|
|
|
0
|
$self->{data} = {}; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
sub EXISTS { |
469
|
1
|
|
|
1
|
|
756
|
my $self = shift; |
470
|
1
|
|
|
|
|
3
|
my $key = shift; |
471
|
|
|
|
|
|
|
|
472
|
1
|
|
|
|
|
8
|
return exists $self->{data}->{$key}; |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
sub FIRSTKEY { |
476
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
477
|
|
|
|
|
|
|
|
478
|
0
|
|
|
|
|
0
|
my $reset = keys %{$self->{data}}; |
|
0
|
|
|
|
|
0
|
|
479
|
0
|
|
|
|
|
0
|
return each %{$self->{data}}; |
|
0
|
|
|
|
|
0
|
|
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub NEXTKEY { |
483
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
484
|
|
|
|
|
|
|
|
485
|
0
|
|
|
|
|
0
|
return each %{$self->{data}}; |
|
0
|
|
|
|
|
0
|
|
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub DESTROY { |
489
|
2
|
|
|
2
|
|
39
|
my $self = shift; |
490
|
|
|
|
|
|
|
|
491
|
2
|
|
|
|
|
6
|
$self->save; |
492
|
2
|
|
|
|
|
10
|
$self->release_all_locks; |
493
|
|
|
|
|
|
|
} |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
# |
498
|
|
|
|
|
|
|
#Persistence methods |
499
|
|
|
|
|
|
|
# |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub restore { |
503
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
504
|
|
|
|
|
|
|
|
505
|
1
|
50
|
|
|
|
4
|
return if ($self->{status} & SYNCED); |
506
|
1
|
50
|
|
|
|
3
|
return if ($self->{status} & NEW); |
507
|
|
|
|
|
|
|
|
508
|
1
|
|
|
|
|
8
|
$self->acquire_read_lock; |
509
|
|
|
|
|
|
|
|
510
|
1
|
|
|
|
|
7
|
$self->{object_store}->materialize($self); |
511
|
1
|
|
|
|
|
3
|
&{$self->{unserialize}}($self); |
|
1
|
|
|
|
|
6
|
|
512
|
|
|
|
|
|
|
|
513
|
1
|
|
|
|
|
3
|
$self->{status} &= ($self->{status} ^ MODIFIED); |
514
|
1
|
|
|
|
|
3
|
$self->{status} |= SYNCED; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
sub save { |
518
|
11
|
|
|
11
|
0
|
23
|
my $self = shift; |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
return unless ( |
521
|
11
|
100
|
100
|
|
|
106
|
$self->{status} & MODIFIED || |
|
|
|
100
|
|
|
|
|
522
|
|
|
|
|
|
|
$self->{status} & NEW || |
523
|
|
|
|
|
|
|
$self->{status} & DELETED |
524
|
|
|
|
|
|
|
); |
525
|
|
|
|
|
|
|
|
526
|
7
|
|
|
|
|
27
|
$self->acquire_write_lock; |
527
|
|
|
|
|
|
|
|
528
|
7
|
100
|
|
|
|
24
|
if ($self->{status} & DELETED) { |
529
|
3
|
|
|
|
|
26
|
$self->{object_store}->remove($self); |
530
|
3
|
|
|
|
|
8
|
$self->{status} |= SYNCED; |
531
|
3
|
|
|
|
|
9
|
$self->{status} &= ($self->{status} ^ MODIFIED); |
532
|
3
|
|
|
|
|
6
|
$self->{status} &= ($self->{status} ^ DELETED); |
533
|
3
|
|
|
|
|
17
|
return; |
534
|
|
|
|
|
|
|
} |
535
|
4
|
100
|
|
|
|
19
|
if ($self->{status} & MODIFIED) { |
536
|
1
|
|
|
|
|
1
|
&{$self->{serialize}}($self); |
|
1
|
|
|
|
|
5
|
|
537
|
1
|
|
|
|
|
79
|
$self->{object_store}->update($self); |
538
|
1
|
|
|
|
|
4
|
$self->{status} &= ($self->{status} ^ MODIFIED); |
539
|
1
|
|
|
|
|
2
|
$self->{status} |= SYNCED; |
540
|
1
|
|
|
|
|
3
|
return; |
541
|
|
|
|
|
|
|
} |
542
|
3
|
50
|
|
|
|
12
|
if ($self->{status} & NEW) { |
543
|
3
|
|
|
|
|
5
|
&{$self->{serialize}}($self); |
|
3
|
|
|
|
|
14
|
|
544
|
3
|
|
|
|
|
324
|
$self->{object_store}->insert($self); |
545
|
3
|
|
|
|
|
10
|
$self->{status} &= ($self->{status} ^ NEW); |
546
|
3
|
|
|
|
|
5
|
$self->{status} |= SYNCED; |
547
|
3
|
|
|
|
|
6
|
$self->{status} &= ($self->{status} ^ MODIFIED); |
548
|
3
|
|
|
|
|
10
|
return; |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
sub delete { |
553
|
3
|
|
|
3
|
0
|
19827
|
my $self = shift; |
554
|
|
|
|
|
|
|
|
555
|
3
|
50
|
|
|
|
18
|
return if ($self->{status} & NEW); |
556
|
|
|
|
|
|
|
|
557
|
3
|
|
|
|
|
6
|
$self->{status} |= DELETED; |
558
|
3
|
|
|
|
|
11
|
$self->save; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
# |
564
|
|
|
|
|
|
|
#Locking methods |
565
|
|
|
|
|
|
|
# |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
sub READ_LOCK () {1}; |
568
|
|
|
|
|
|
|
sub WRITE_LOCK () {2}; |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
#These methods aren't used anymore for performance reasons. I'll keep them |
572
|
|
|
|
|
|
|
#around for reference. |
573
|
|
|
|
|
|
|
|
574
|
0
|
|
|
0
|
0
|
0
|
sub has_read_lock { $_[0]->{lock} & READ_LOCK } |
575
|
0
|
|
|
0
|
0
|
0
|
sub has_write_lock { $_[0]->{lock} & WRITE_LOCK } |
576
|
|
|
|
|
|
|
|
577
|
0
|
|
|
0
|
0
|
0
|
sub set_read_lock { $_[0]->{lock} |= READ_LOCK } |
578
|
0
|
|
|
0
|
0
|
0
|
sub set_write_lock { $_[0]->{lock} |= WRITE_LOCK } |
579
|
|
|
|
|
|
|
|
580
|
0
|
|
|
0
|
0
|
0
|
sub unset_read_lock { $_[0]->{lock} &= ($_[0]->{lock} ^ READ_LOCK) } |
581
|
0
|
|
|
0
|
0
|
0
|
sub unset_write_lock { $_[0]->{lock} &= ($_[0]->{lock} ^ WRITE_LOCK) } |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
sub acquire_read_lock { |
584
|
1
|
|
|
1
|
0
|
2
|
my $self = shift; |
585
|
|
|
|
|
|
|
|
586
|
1
|
50
|
|
|
|
5
|
return if ($self->{lock} & READ_LOCK); |
587
|
|
|
|
|
|
|
|
588
|
1
|
|
|
|
|
6
|
$self->{lock_manager}->acquire_read_lock($self); |
589
|
|
|
|
|
|
|
|
590
|
1
|
|
|
|
|
2
|
$self->{lock} |= READ_LOCK; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
sub acquire_write_lock { |
594
|
7
|
|
|
7
|
0
|
14
|
my $self = shift; |
595
|
|
|
|
|
|
|
|
596
|
7
|
100
|
|
|
|
24
|
return if ($self->{lock} & WRITE_LOCK); |
597
|
|
|
|
|
|
|
|
598
|
4
|
|
|
|
|
32
|
$self->{lock_manager}->acquire_write_lock($self); |
599
|
|
|
|
|
|
|
|
600
|
4
|
|
|
|
|
9
|
$self->{lock} |= WRITE_LOCK; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
sub release_read_lock { |
604
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
605
|
|
|
|
|
|
|
|
606
|
0
|
0
|
|
|
|
0
|
return unless ($self->{lock} & READ_LOCK); |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
0
|
$self->{lock_manager}->release_read_lock($self); |
609
|
|
|
|
|
|
|
|
610
|
0
|
|
|
|
|
0
|
$self->{lock} &= ($self->{lock} ^ READ_LOCK); |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
sub release_write_lock { |
614
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
615
|
|
|
|
|
|
|
|
616
|
0
|
0
|
|
|
|
0
|
return unless ($self->{lock} & WRITE_LOCK); |
617
|
|
|
|
|
|
|
|
618
|
0
|
|
|
|
|
0
|
$self->{lock_manager}->release_write_lock($self); |
619
|
|
|
|
|
|
|
|
620
|
0
|
|
|
|
|
0
|
$self->{lock} &= ($self->{lock} ^ WRITE_LOCK); |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
sub release_all_locks { |
624
|
5
|
|
|
5
|
0
|
8
|
my $self = shift; |
625
|
|
|
|
|
|
|
|
626
|
5
|
100
|
100
|
|
|
41
|
return unless ($self->{lock} & READ_LOCK || $self->{lock} & WRITE_LOCK); |
627
|
|
|
|
|
|
|
|
628
|
4
|
|
|
|
|
28
|
$self->{lock_manager}->release_all_locks($self); |
629
|
|
|
|
|
|
|
|
630
|
4
|
|
|
|
|
10
|
$self->{lock} &= ($self->{lock} ^ READ_LOCK); |
631
|
4
|
|
|
|
|
37
|
$self->{lock} &= ($self->{lock} ^ WRITE_LOCK); |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
|
634
|
|
|
|
|
|
|
1; |