line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
######################################################################## |
2
|
|
|
|
|
|
|
# File: Memory.pm |
3
|
|
|
|
|
|
|
# Author: David Winters |
4
|
|
|
|
|
|
|
# RCS: $Id: Memory.pm,v 1.10 2000/02/08 02:35:02 winters Exp $ |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# A class that implements object persistence using memory (RAM). |
7
|
|
|
|
|
|
|
# This class inherits from other persistent classes. |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# This file contains POD documentation that may be viewed with the |
10
|
|
|
|
|
|
|
# perldoc, pod2man, or pod2html utilities. |
11
|
|
|
|
|
|
|
# |
12
|
|
|
|
|
|
|
# Copyright (c) 1998-2000 David Winters. All rights reserved. |
13
|
|
|
|
|
|
|
# This program is free software; you can redistribute it |
14
|
|
|
|
|
|
|
# and/or modify it under the same terms as Perl itself. |
15
|
|
|
|
|
|
|
######################################################################## |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
package Persistent::Memory; |
18
|
|
|
|
|
|
|
require 5.004; |
19
|
|
|
|
|
|
|
|
20
|
6
|
|
|
6
|
|
37
|
use strict; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
265
|
|
21
|
6
|
|
|
6
|
|
33
|
use vars qw(@ISA $VERSION $REVISION); |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
366
|
|
22
|
|
|
|
|
|
|
|
23
|
6
|
|
|
6
|
|
33
|
use Carp; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
355
|
|
24
|
6
|
|
|
6
|
|
32
|
use English; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
35
|
|
25
|
6
|
|
|
6
|
|
2858
|
use Fcntl ':flock'; # import LOCK_* constants |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
622
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
### we are a subclass of the all-powerful Persistent::Base class ### |
28
|
6
|
|
|
6
|
|
16028
|
use Persistent::Base; |
|
6
|
|
|
|
|
20
|
|
|
6
|
|
|
|
|
10928
|
|
29
|
|
|
|
|
|
|
@ISA = qw(Persistent::Base); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
### copy version number from superclass ### |
32
|
|
|
|
|
|
|
$VERSION = $Persistent::Base::VERSION; |
33
|
|
|
|
|
|
|
$REVISION = (qw$Revision: 1.10 $)[1]; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
=head1 NAME |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
Persistent::Memory - A Persistent Class implemented using Memory (RAM) |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 SYNOPSIS |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
use Persistent::Memory; |
42
|
|
|
|
|
|
|
use English; # import readable variable names like $EVAL_ERROR |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
eval { ### in case an exception is thrown ### |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
### allocate a persistent object ### |
47
|
|
|
|
|
|
|
my $person = new Persistent::Memory(); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
### define attributes of the object ### |
50
|
|
|
|
|
|
|
$person->add_attribute('firstname', 'ID', 'VarChar', undef, 10); |
51
|
|
|
|
|
|
|
$person->add_attribute('lastname', 'ID', 'VarChar', undef, 20); |
52
|
|
|
|
|
|
|
$person->add_attribute('telnum', 'Persistent', |
53
|
|
|
|
|
|
|
'VarChar', undef, 15); |
54
|
|
|
|
|
|
|
$person->add_attribute('bday', 'Persistent', 'DateTime', undef); |
55
|
|
|
|
|
|
|
$person->add_attribute('age', 'Transient', 'Number', undef, 2); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
### query the datastore for some objects ### |
58
|
|
|
|
|
|
|
$person->restore_where(qq{ |
59
|
|
|
|
|
|
|
lastname = 'Flintstone' and |
60
|
|
|
|
|
|
|
telnum =~ /^[(]?650/ |
61
|
|
|
|
|
|
|
}); |
62
|
|
|
|
|
|
|
while ($person->restore_next()) { |
63
|
|
|
|
|
|
|
printf "name = %s, tel# = %s\n", |
64
|
|
|
|
|
|
|
$person->firstname . ' ' . $person->lastname, |
65
|
|
|
|
|
|
|
$person->telnum; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
}; |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
if ($EVAL_ERROR) { ### catch those exceptions! ### |
70
|
|
|
|
|
|
|
print "An error occurred: $EVAL_ERROR\n"; |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=head1 ABSTRACT |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
This is a Persistent class that uses memory (RAM) to store and |
76
|
|
|
|
|
|
|
retrieve objects. This can be useful when you want to create a cache |
77
|
|
|
|
|
|
|
of objects (i.e. a server-side web cache). This class can be |
78
|
|
|
|
|
|
|
instantiated directly or subclassed. The methods described below are |
79
|
|
|
|
|
|
|
unique to this class, and all other methods that are provided by this |
80
|
|
|
|
|
|
|
class are documented in the L documentation. The |
81
|
|
|
|
|
|
|
L documentation has a very thorough introduction to using |
82
|
|
|
|
|
|
|
the Persistent framework of classes. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
This class is part of the Persistent base package which is available |
85
|
|
|
|
|
|
|
from: |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
http://www.bigsnow.org/persistent |
88
|
|
|
|
|
|
|
ftp://ftp.bigsnow.org/pub/persistent |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=head1 DESCRIPTION |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
Before we get started describing the methods in detail, it should be |
93
|
|
|
|
|
|
|
noted that all error handling in this class is done with exceptions. |
94
|
|
|
|
|
|
|
So you should wrap an eval block around all of your code. Please see |
95
|
|
|
|
|
|
|
the L documentation for more information on exception |
96
|
|
|
|
|
|
|
handling in Perl. |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
=head1 METHODS |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=cut |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
######################################################################## |
103
|
|
|
|
|
|
|
# |
104
|
|
|
|
|
|
|
# ----------------------------------------------------------- |
105
|
|
|
|
|
|
|
# PUBLIC METHODS OVERRIDDEN (REDEFINED) FROM THE PARENT CLASS |
106
|
|
|
|
|
|
|
# ----------------------------------------------------------- |
107
|
|
|
|
|
|
|
# |
108
|
|
|
|
|
|
|
######################################################################## |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
######################################################################## |
111
|
|
|
|
|
|
|
# initialize |
112
|
|
|
|
|
|
|
######################################################################## |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=head2 new -- Object Constructor |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
use Persistent::Memory; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
eval { |
119
|
|
|
|
|
|
|
my $person = new Persistent::Memory($field_delimiter); |
120
|
|
|
|
|
|
|
}; |
121
|
|
|
|
|
|
|
croak "Exception caught: $@" if $@; |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
Allocates an object. This method throws Perl execeptions so use it |
124
|
|
|
|
|
|
|
with an eval block. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Parameters: |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=over 4 |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=item These are the same as for the I method below. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=back |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=cut |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
######################################################################## |
137
|
|
|
|
|
|
|
# datastore |
138
|
|
|
|
|
|
|
######################################################################## |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head2 datastore -- Sets/Returns the Data Store Parameters |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
eval { |
143
|
|
|
|
|
|
|
### set the data store ### |
144
|
|
|
|
|
|
|
$person->datastore($field_delimiter); |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
### get the data store ### |
147
|
|
|
|
|
|
|
$href = $person->datastore(); |
148
|
|
|
|
|
|
|
}; |
149
|
|
|
|
|
|
|
croak "Exception caught: $@" if $@; |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
Returns (and optionally sets) the data store of the object. This |
152
|
|
|
|
|
|
|
method throws Perl execeptions so use it with an eval block. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
Parameters: |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=over 4 |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=item I<$field_delimiter> |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
Delimiter used to separate the attributes of the object in the data |
161
|
|
|
|
|
|
|
store. This argument is optional and will be initialized to the value |
162
|
|
|
|
|
|
|
of the special Perl variable I<$;> (or I<$SUBSCRIPT_SEPARATOR> if you |
163
|
|
|
|
|
|
|
are using the English module) as a default. |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=back |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
Returns: |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
=over 4 |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=item I<$href> |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
Reference to the hash used as the data store. |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
=back |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=cut |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub datastore { |
180
|
0
|
0
|
|
0
|
1
|
0
|
(@_ > 0) or croak 'Usage: $obj->datastore()'; |
181
|
0
|
|
|
|
|
0
|
my $this = shift; |
182
|
0
|
0
|
|
|
|
0
|
ref($this) or croak "$this is not an object"; |
183
|
|
|
|
|
|
|
|
184
|
0
|
|
|
|
|
0
|
$this->_trace(); |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
### set it ### |
187
|
0
|
0
|
|
|
|
0
|
$this->{DataStore}->{Hash} = {} if !defined($this->{DataStore}->{Hash}); |
188
|
0
|
0
|
|
|
|
0
|
$this->field_delimiter(shift) if @_; |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
### return it ### |
191
|
0
|
|
|
|
|
0
|
$this->{DataStore}->{Hash}; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
######################################################################## |
195
|
|
|
|
|
|
|
# insert |
196
|
|
|
|
|
|
|
######################################################################## |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=head2 insert -- Insert an Object into the Data Store |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
eval { |
201
|
|
|
|
|
|
|
$person->insert(); |
202
|
|
|
|
|
|
|
}; |
203
|
|
|
|
|
|
|
croak "Exception caught: $@" if $@; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
Inserts an object into the data store. This method throws Perl |
206
|
|
|
|
|
|
|
execeptions so use it with an eval block. |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Parameters: |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
=over 4 |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=item None. |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=back |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
Returns: |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=over 4 |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
=item None. |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
=back |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
See the L documentation for more information. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
=cut |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
sub insert { |
229
|
11
|
50
|
|
11
|
1
|
49
|
(@_ == 1) or croak 'Usage: $obj->insert()'; |
230
|
11
|
|
|
|
|
17
|
my $this = shift; |
231
|
11
|
50
|
|
|
|
43
|
ref($this) or croak "$this is not an object"; |
232
|
|
|
|
|
|
|
|
233
|
11
|
|
|
|
|
32
|
$this->_trace(); |
234
|
|
|
|
|
|
|
|
235
|
11
|
|
|
|
|
51
|
$this->_check_id(); ### check validity of object ID ### |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
### get ID of object ### |
238
|
11
|
|
|
|
|
45
|
my @id = $this->_id(); |
239
|
11
|
|
|
|
|
35
|
my $delimiter = $this->field_delimiter(); ### datastore field delimiter ### |
240
|
11
|
|
|
|
|
26
|
my $id = join($delimiter, @id); |
241
|
|
|
|
|
|
|
|
242
|
11
|
|
|
|
|
45
|
$this->_lock_datastore('MUTEX'); ### start of critical section ### |
243
|
11
|
|
|
|
|
34
|
my $href = $this->_load_datastore(); ### get hash ref to data store ### |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
### check for previous existence of object in data store ### |
246
|
11
|
50
|
|
|
|
85
|
if (defined $href->{$id}) { |
247
|
0
|
|
|
|
|
0
|
croak(sprintf("An object with this ID (%s) already exists " . |
248
|
|
|
|
|
|
|
"in the data store", |
249
|
|
|
|
|
|
|
join(', ', @id))); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
### join attributes together ### |
253
|
11
|
|
|
|
|
15
|
my @data; |
254
|
11
|
|
|
|
|
16
|
foreach my $attr (@{$this->{DataOrder}}) { |
|
11
|
|
|
|
|
24
|
|
255
|
55
|
|
|
|
|
131
|
my $value = $this->value($attr); |
256
|
55
|
50
|
|
|
|
156
|
push(@data, defined $value ? $value : ''); |
257
|
|
|
|
|
|
|
} |
258
|
11
|
|
|
|
|
40
|
my $data = join($delimiter, @data); |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
### store object ### |
261
|
11
|
|
|
|
|
114
|
$href->{$id} = $data; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
### save the object ID ### |
264
|
11
|
|
|
|
|
57
|
$this->_prev_id(@id); |
265
|
|
|
|
|
|
|
|
266
|
11
|
|
|
|
|
34
|
$this->_flush_datastore(); |
267
|
11
|
|
|
|
|
38
|
$this->_unlock_datastore(); ### end of critical section ### |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
######################################################################## |
271
|
|
|
|
|
|
|
# delete |
272
|
|
|
|
|
|
|
######################################################################## |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=head2 delete -- Delete an Object from the Data Store |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
eval { |
277
|
|
|
|
|
|
|
$person->delete(); |
278
|
|
|
|
|
|
|
}; |
279
|
|
|
|
|
|
|
croak "Exception caught: $@" if $@; |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Deletes an object from the data store. This method throws Perl |
282
|
|
|
|
|
|
|
execeptions so use it with an eval block. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
Parameters: |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
=over 4 |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=item I<@id> |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
Values of the Identity attributes of the object. This argument is |
291
|
|
|
|
|
|
|
optional and will default to the Identifier values of the object as |
292
|
|
|
|
|
|
|
the default. |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=back |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Returns: |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
=over 4 |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
=item I<$flag> |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
A true value if the object previously existed in the data store (it |
303
|
|
|
|
|
|
|
was deleted), and a false value if not (nothing to delete). |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
=back |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
See the L documentation for more information. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
=cut |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub delete { |
312
|
3
|
50
|
|
3
|
1
|
17
|
(@_ > 0) or croak 'Usage: $obj->delete([@id])'; |
313
|
3
|
|
|
|
|
5
|
my ($this, @id) = @_; |
314
|
3
|
50
|
|
|
|
11
|
ref($this) or croak "$this is not an object"; |
315
|
|
|
|
|
|
|
|
316
|
3
|
|
|
|
|
10
|
$this->_trace(); |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
### get ID of object ### |
319
|
3
|
50
|
|
|
|
15
|
@id = $this->_prev_id() if !@id; |
320
|
3
|
|
|
|
|
14
|
$this->_check_id(@id); ### check that the ID is valid ### |
321
|
3
|
|
|
|
|
9
|
my $delimiter = $this->field_delimiter(); ### datastore field delimiter ### |
322
|
3
|
|
|
|
|
9
|
my $id = join($delimiter, @id); |
323
|
|
|
|
|
|
|
|
324
|
3
|
|
|
|
|
17
|
$this->_lock_datastore('MUTEX'); ### start of critical section ### |
325
|
3
|
|
|
|
|
12
|
my $href = $this->_load_datastore(); ### get hash ref to data store ### |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
### check for previous existence of object in data store ### |
328
|
3
|
50
|
|
|
|
14
|
my $rc = defined $href->{$id} ? 1 : 0; |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
### delete object from data store ### |
331
|
3
|
|
|
|
|
8
|
delete $href->{$id}; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
### clear the previous ID ### |
334
|
3
|
|
|
|
|
4
|
undef(%{$this->{PrevId}}); |
|
3
|
|
|
|
|
8
|
|
335
|
|
|
|
|
|
|
|
336
|
3
|
|
|
|
|
12
|
$this->_flush_datastore(); |
337
|
3
|
|
|
|
|
10
|
$this->_unlock_datastore(); ### end of critical section ### |
338
|
|
|
|
|
|
|
|
339
|
3
|
|
|
|
|
15
|
$rc; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
######################################################################## |
343
|
|
|
|
|
|
|
# restore |
344
|
|
|
|
|
|
|
######################################################################## |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=head2 restore -- Restore an Object from the Data Store |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
eval { |
349
|
|
|
|
|
|
|
$person->restore(@id); |
350
|
|
|
|
|
|
|
}; |
351
|
|
|
|
|
|
|
croak "Exception caught: $@" if $@; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
Restores an object from the data store. This method throws Perl |
354
|
|
|
|
|
|
|
execeptions so use it with an eval block. |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
Parameters: |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=over 4 |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
=item I<@id> |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
Values of the Identity attributes of the object. This method throws |
363
|
|
|
|
|
|
|
Perl execeptions so use it with an eval block. |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
=back |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
Returns: |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
=over 4 |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
=item I<$flag> |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
A true value if the object previously existed in the data store (it |
374
|
|
|
|
|
|
|
was restored), and a false value if not (nothing to restore). |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
=back |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
See the L documentation for more information. |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
=cut |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
sub restore { |
383
|
1
|
50
|
|
1
|
1
|
16
|
(@_ > 1) or croak 'Usage: $obj->restore()'; |
384
|
1
|
|
|
|
|
2
|
my ($this, @id) = @_; |
385
|
1
|
50
|
|
|
|
4
|
ref($this) or croak "$this is not an object"; |
386
|
|
|
|
|
|
|
|
387
|
1
|
|
|
|
|
4
|
$this->_trace(); |
388
|
|
|
|
|
|
|
|
389
|
1
|
|
|
|
|
8
|
$this->_check_id(@id); ### check validity of object ID ### |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
### get hash key of object ### |
392
|
1
|
|
|
|
|
4
|
my $delimiter = $this->field_delimiter(); ### datastore field delimiter ### |
393
|
1
|
|
|
|
|
4
|
my $id = join($delimiter, @id); |
394
|
|
|
|
|
|
|
|
395
|
1
|
|
|
|
|
5
|
$this->_lock_datastore('SHARED'); ### start of critical section ### |
396
|
1
|
|
|
|
|
5
|
my $href = $this->_load_datastore(); ### get hash ref to data store ### |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
### check for previous existence of object in data store ### |
399
|
1
|
|
|
|
|
1
|
my $rc; |
400
|
1
|
50
|
|
|
|
5
|
if (defined $href->{$id}) { ### found an object ### |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
### clear the transient data ### |
403
|
1
|
|
|
|
|
1
|
foreach my $attr (keys %{$this->{TempData}}) { |
|
1
|
|
|
|
|
5
|
|
404
|
0
|
|
|
|
|
0
|
$this->value($attr, undef); |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
### load the persistent data ### |
408
|
1
|
|
|
|
|
12
|
my @data = split("\Q$delimiter\E", $href->{$id}); ### quote metachars ### |
409
|
1
|
|
|
|
|
2
|
foreach my $attr (@{$this->{DataOrder}}) { |
|
1
|
|
|
|
|
3
|
|
410
|
5
|
|
|
|
|
20
|
$this->value($attr, shift @data); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
### save the object ID ### |
414
|
1
|
|
|
|
|
11
|
$this->_prev_id($this->_id()); |
415
|
|
|
|
|
|
|
|
416
|
1
|
|
|
|
|
13
|
$rc = 1; |
417
|
|
|
|
|
|
|
} else { ### no more objects left ### |
418
|
0
|
|
|
|
|
0
|
$rc = 0; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
1
|
|
|
|
|
4
|
$this->_close_datastore(); |
422
|
1
|
|
|
|
|
4
|
$this->_unlock_datastore(); ### end of critical section ### |
423
|
|
|
|
|
|
|
|
424
|
1
|
|
|
|
|
4
|
$rc; |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
######################################################################## |
428
|
|
|
|
|
|
|
# restore_where |
429
|
|
|
|
|
|
|
######################################################################## |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=head2 restore_where -- Conditionally Restoring Objects |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
use Persistent::Memory; |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
eval { |
436
|
|
|
|
|
|
|
my $person = new Persistent::Memory('|'); |
437
|
|
|
|
|
|
|
$person->restore_where( |
438
|
|
|
|
|
|
|
"lastname = 'Flintstone' and telnum =~ /^[(]?650/", |
439
|
|
|
|
|
|
|
"lastname, firstname, telnum DESC" |
440
|
|
|
|
|
|
|
); |
441
|
|
|
|
|
|
|
while ($person->restore_next()) { |
442
|
|
|
|
|
|
|
print "Restored: "; print_person($person); |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
}; |
445
|
|
|
|
|
|
|
croak "Exception caught: $@" if $@; |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
Restores objects from the data store that meet the specified |
448
|
|
|
|
|
|
|
conditions. The objects are returned one at a time by using the |
449
|
|
|
|
|
|
|
I method and in a sorted order if specified. This |
450
|
|
|
|
|
|
|
method throws Perl execeptions so use it with an eval block. |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
Since this is a Perl based Persistent class, the I |
453
|
|
|
|
|
|
|
method expects the I<$where> argument to use Perl expressions. |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
Parameters: |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
=over 4 |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
=item I<$where> |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
Conditional expression for the requested objects. The format of this |
462
|
|
|
|
|
|
|
expression is similar to a SQL WHERE clause. This argument is |
463
|
|
|
|
|
|
|
optional. |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
=item I<$order_by> |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
Sort expression for the requested objects. The format of this |
468
|
|
|
|
|
|
|
expression is similar to a SQL ORDER BY clause. This argument is |
469
|
|
|
|
|
|
|
optional. |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=back |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
Returns: |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=over 4 |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=item I<$num_of_objs> |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
The number of objects that match the conditions. |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
=back |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
See the L documentation for more information. |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
=cut |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
sub restore_where { |
488
|
7
|
50
|
|
7
|
1
|
26
|
(@_ < 4) or croak 'Usage: $obj->restore_where([$where], [$order_by])'; |
489
|
7
|
|
|
|
|
15
|
my ($this, $where, $order_by) = @_; |
490
|
7
|
50
|
|
|
|
46
|
ref($this) or croak "$this is not an object"; |
491
|
|
|
|
|
|
|
|
492
|
7
|
|
|
|
|
26
|
$this->_trace(); |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
### iterate through all of the objects in the datastore ### |
495
|
|
|
|
|
|
|
### and check if they satisfy the boolean expression (WHERE clause) ### |
496
|
7
|
|
|
|
|
11
|
my @objs_data; |
497
|
7
|
|
|
|
|
57
|
my $bool_expr = $this->_parse_query($where); |
498
|
7
|
|
|
|
|
24
|
my $delimiter = $this->field_delimiter(); ### datastore field delimiter ### |
499
|
|
|
|
|
|
|
|
500
|
7
|
|
|
|
|
63
|
$this->_lock_datastore('SHARED'); ### start of critical section ### |
501
|
7
|
|
|
|
|
33
|
my $href = $this->_load_datastore(); ### get hash ref to datastore ### |
502
|
|
|
|
|
|
|
|
503
|
7
|
|
|
|
|
62
|
while (my($key, $data) = each %$href) { |
504
|
29
|
|
|
|
|
191
|
my @data = split("\Q$delimiter\E", $data); ### quote regexp metachars ### |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
### save the object data that satisfies the boolean expression ### |
507
|
29
|
|
|
|
|
214
|
my $my_stmt = |
508
|
29
|
|
|
|
|
44
|
"my(" . join(", ", map("\$$_", @{$this->{DataOrder}})) . ') = @data;'; |
509
|
29
|
|
|
|
|
90
|
my $eval_str = qq{ |
510
|
|
|
|
|
|
|
$my_stmt |
511
|
|
|
|
|
|
|
push(\@objs_data, [\@data]) if ($bool_expr); |
512
|
|
|
|
|
|
|
}; |
513
|
29
|
|
|
|
|
2491
|
eval($eval_str); |
514
|
29
|
50
|
|
|
|
269
|
if ($EVAL_ERROR) { |
515
|
0
|
|
|
|
|
0
|
croak "Query statement failed: $eval_str\nError: $EVAL_ERROR"; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
### sort the objects ### |
520
|
7
|
100
|
|
|
|
41
|
$this->_sort_objects($order_by, \@objs_data) if $order_by; |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
### save the restored objects ### |
523
|
7
|
|
|
|
|
28
|
$this->{RestoredData} = \@objs_data; |
524
|
|
|
|
|
|
|
|
525
|
7
|
|
|
|
|
43
|
$this->_close_datastore(); |
526
|
7
|
|
|
|
|
27
|
$this->_unlock_datastore(); ### end of critical section ### |
527
|
|
|
|
|
|
|
|
528
|
7
|
|
|
|
|
31
|
scalar @objs_data; |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
######################################################################## |
532
|
|
|
|
|
|
|
# |
533
|
|
|
|
|
|
|
# ------------------ |
534
|
|
|
|
|
|
|
# NEW PUBLIC METHODS |
535
|
|
|
|
|
|
|
# ------------------ |
536
|
|
|
|
|
|
|
# |
537
|
|
|
|
|
|
|
######################################################################## |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
######################################################################## |
540
|
|
|
|
|
|
|
# Function: field_delimiter |
541
|
|
|
|
|
|
|
# Description: Gets/sets the delimiter used to join the fields together |
542
|
|
|
|
|
|
|
# for storage in the datastore. |
543
|
|
|
|
|
|
|
# Parameters: None. |
544
|
|
|
|
|
|
|
# Returns: $delimiter = field delimiter of the datastore |
545
|
|
|
|
|
|
|
######################################################################## |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
sub field_delimiter { |
548
|
53
|
50
|
|
53
|
0
|
125
|
(@_ > 0) or croak 'Usage: $obj->field_delimiter([$delimiter])'; |
549
|
53
|
|
|
|
|
64
|
my $this = shift; |
550
|
53
|
50
|
|
|
|
109
|
ref($this) or croak "$this is not an object"; |
551
|
|
|
|
|
|
|
|
552
|
53
|
|
|
|
|
139
|
$this->_trace(); |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
### set it ### |
555
|
53
|
100
|
|
|
|
128
|
$this->{DataStore}->{Delimiter} = shift if @_; |
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
### return it ### |
558
|
53
|
100
|
|
|
|
126
|
if (defined $this->{DataStore}->{Delimiter}) { |
559
|
43
|
|
|
|
|
111
|
$this->{DataStore}->{Delimiter}; |
560
|
|
|
|
|
|
|
} else { |
561
|
10
|
|
|
|
|
30
|
$SUBSCRIPT_SEPARATOR; |
562
|
|
|
|
|
|
|
} |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
######################################################################## |
566
|
|
|
|
|
|
|
# |
567
|
|
|
|
|
|
|
# --------------- |
568
|
|
|
|
|
|
|
# PRIVATE METHODS |
569
|
|
|
|
|
|
|
# --------------- |
570
|
|
|
|
|
|
|
# |
571
|
|
|
|
|
|
|
######################################################################## |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
######################################################################## |
574
|
|
|
|
|
|
|
# Function: _load_datastore |
575
|
|
|
|
|
|
|
# Description: No loading of the datastore into a hash is needed, so |
576
|
|
|
|
|
|
|
# just a reference to it is returned. |
577
|
|
|
|
|
|
|
# Parameters: None. |
578
|
|
|
|
|
|
|
# Returns: $href = hash reference to the datstore |
579
|
|
|
|
|
|
|
######################################################################## |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
sub _load_datastore { |
582
|
0
|
0
|
|
0
|
|
|
(@_ > 0) or croak 'Usage: $obj->_load_datastore()'; |
583
|
0
|
|
|
|
|
|
my $this = shift; |
584
|
0
|
0
|
|
|
|
|
ref($this) or croak "$this is not an object"; |
585
|
|
|
|
|
|
|
|
586
|
0
|
|
|
|
|
|
$this->_trace(); |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
### return the hash ref to the datastore ### |
589
|
0
|
|
|
|
|
|
$this->{DataStore}->{Hash}; |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
######################################################################## |
593
|
|
|
|
|
|
|
# Function: _flush_datastore |
594
|
|
|
|
|
|
|
# Description: Flushes the hash containing the data back to the |
595
|
|
|
|
|
|
|
# datastore. |
596
|
|
|
|
|
|
|
# In this case, the method does nothing for this module. |
597
|
|
|
|
|
|
|
# Parameters: None. |
598
|
|
|
|
|
|
|
# Returns: None. |
599
|
|
|
|
|
|
|
######################################################################## |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
sub _flush_datastore { |
602
|
0
|
0
|
|
0
|
|
|
(@_ > 0) or croak 'Usage: $obj->_flush_datastore()'; |
603
|
0
|
|
|
|
|
|
my $this = shift; |
604
|
0
|
0
|
|
|
|
|
ref($this) or croak "$this is not an object"; |
605
|
|
|
|
|
|
|
|
606
|
0
|
|
|
|
|
|
$this->_trace(); |
607
|
|
|
|
|
|
|
|
608
|
0
|
|
|
|
|
|
0; |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
######################################################################## |
612
|
|
|
|
|
|
|
# Function: _close_datastore |
613
|
|
|
|
|
|
|
# Description: Closes the datastore. |
614
|
|
|
|
|
|
|
# In this case, the method does nothing for this module. |
615
|
|
|
|
|
|
|
# Parameters: None. |
616
|
|
|
|
|
|
|
# Returns: None. |
617
|
|
|
|
|
|
|
######################################################################## |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
sub _close_datastore { |
620
|
0
|
0
|
|
0
|
|
|
(@_ > 0) or croak 'Usage: $obj->_close_datastore()'; |
621
|
0
|
|
|
|
|
|
my $this = shift; |
622
|
0
|
0
|
|
|
|
|
ref($this) or croak "$this is not an object"; |
623
|
|
|
|
|
|
|
|
624
|
0
|
|
|
|
|
|
$this->_trace(); |
625
|
|
|
|
|
|
|
|
626
|
0
|
|
|
|
|
|
0; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
######################################################################## |
630
|
|
|
|
|
|
|
# Function: _lock_datastore |
631
|
|
|
|
|
|
|
# Description: Locks the datastore for query or update. |
632
|
|
|
|
|
|
|
# For datastore query, use a 'SHARED' lock. |
633
|
|
|
|
|
|
|
# For datastore update, use a 'MUTEX' lock. |
634
|
|
|
|
|
|
|
# NOTE: Does nothing for this module. |
635
|
|
|
|
|
|
|
# Parameters: $lock_type = 'SHARED' or 'MUTEX' |
636
|
|
|
|
|
|
|
# 'SHARED' is for read-only. |
637
|
|
|
|
|
|
|
# 'MUTEX' is for read/write. |
638
|
|
|
|
|
|
|
# Returns: None. |
639
|
|
|
|
|
|
|
######################################################################## |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
sub _lock_datastore { |
642
|
0
|
0
|
|
0
|
|
|
(@_ > 0) or croak 'Usage: $obj->_lock_datastore($lock_type)'; |
643
|
0
|
|
|
|
|
|
my($this, $lock_type) = @_; |
644
|
0
|
0
|
|
|
|
|
ref($this) or croak "$this is not an object"; |
645
|
|
|
|
|
|
|
|
646
|
0
|
|
|
|
|
|
$this->_trace(); |
647
|
|
|
|
|
|
|
|
648
|
0
|
|
|
|
|
|
0; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
######################################################################## |
652
|
|
|
|
|
|
|
# Function: _unlock_datastore |
653
|
|
|
|
|
|
|
# Description: Unlocks the datastore. |
654
|
|
|
|
|
|
|
# Unlocks both types of locks, 'SHARED' and 'MUTEX'. |
655
|
|
|
|
|
|
|
# In this case, the method does nothing for this module. |
656
|
|
|
|
|
|
|
# Parameters: None. |
657
|
|
|
|
|
|
|
# Returns: None. |
658
|
|
|
|
|
|
|
######################################################################## |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
sub _unlock_datastore { |
661
|
0
|
0
|
|
0
|
|
|
(@_ > 0) or croak 'Usage: $obj->_unlock_datastore()'; |
662
|
0
|
|
|
|
|
|
my $this = shift; |
663
|
0
|
0
|
|
|
|
|
ref($this) or croak "$this is not an object"; |
664
|
|
|
|
|
|
|
|
665
|
0
|
|
|
|
|
|
$this->_trace(); |
666
|
|
|
|
|
|
|
|
667
|
0
|
|
|
|
|
|
0; |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
### end of library ### |
671
|
|
|
|
|
|
|
1; |
672
|
|
|
|
|
|
|
__END__ |