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