Commit | Line | Data |
ffed8b01 |
1 | package DBM::Deep; |
2 | |
2120a181 |
3 | use 5.006_000; |
460b1067 |
4 | |
ffed8b01 |
5 | use strict; |
065b45be |
6 | use warnings FATAL => 'all'; |
8b957036 |
7 | |
d426259c |
8 | our $VERSION = q(1.0015); |
86867f3a |
9 | |
ffed8b01 |
10 | use Scalar::Util (); |
ffed8b01 |
11 | |
51e9eee3 |
12 | use DBM::Deep::Engine::File (); |
95967a5e |
13 | |
4f0f6fff |
14 | use DBM::Deep::SQL::Util; |
15 | use DBM::Deep::SQL::Array; |
16 | use DBM::Deep::SQL::Hash; |
17 | |
c57b19c6 |
18 | use overload |
19 | '""' => sub { overload::StrVal( $_[0] ) }, |
20 | fallback => 1; |
21 | |
6e6789b0 |
22 | use constant DEBUG => 0; |
23 | |
2120a181 |
24 | sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH } |
25 | sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY } |
ffed8b01 |
26 | |
2120a181 |
27 | # This is used in all the children of this class in their TIE<type> methods. |
0ca7ea98 |
28 | sub _get_args { |
29 | my $proto = shift; |
30 | |
31 | my $args; |
32 | if (scalar(@_) > 1) { |
33 | if ( @_ % 2 ) { |
34 | $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] ); |
35 | } |
36 | $args = {@_}; |
37 | } |
d0b74c17 |
38 | elsif ( ref $_[0] ) { |
4d35d856 |
39 | unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) { |
0ca7ea98 |
40 | $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] ); |
41 | } |
42 | $args = $_[0]; |
43 | } |
d0b74c17 |
44 | else { |
0ca7ea98 |
45 | $args = { file => shift }; |
46 | } |
47 | |
48 | return $args; |
49 | } |
50 | |
d426259c |
51 | # Class constructor method for Perl OO interface. |
52 | # Calls tie() and returns blessed reference to tied hash or array, |
53 | # providing a hybrid OO/tie interface. |
ffed8b01 |
54 | sub new { |
d0b74c17 |
55 | my $class = shift; |
56 | my $args = $class->_get_args( @_ ); |
4f0f6fff |
57 | my $self; |
58 | |
4f0f6fff |
59 | if (exists $args->{dbi}) { |
60 | eval { |
61 | require DBIx::Abstract; |
62 | }; if ( $@ ) { |
2c70efe1 |
63 | __PACKAGE__->_throw_error('DBIx::Abstract not installed. You cannot use the SQL mode.'); |
4f0f6fff |
64 | } |
65 | unless (UNIVERSAL::isa($args->{dbi}, 'DBIx::Abstract')) { |
66 | $args->{dbi} = DBIx::Abstract->connect($args->{dbi}); |
67 | } |
68 | |
69 | if (defined $args->{id}) { |
70 | unless ($args->{id} =~ /^\d+$/ && $args->{id} > 0) { |
2c70efe1 |
71 | __PACKAGE__->_throw_error('Invalid SQL record id'); |
4f0f6fff |
72 | } |
73 | my $util = {dbi => $args->{dbi}}; |
74 | bless $util, 'DBM::Deep::SQL::Util'; |
75 | my $q = $util->_select( |
76 | table => 'rec_item', |
77 | fields => 'item_type', |
78 | where => {id => $args->{id}}, |
79 | ); |
80 | if ($q->[0]->[0] eq 'array') { |
81 | $args->{type} = TYPE_ARRAY; |
82 | } |
83 | elsif ($q->[0]->[0] eq 'hash') { |
84 | $args->{type} = TYPE_HASH; |
85 | } |
86 | else { |
87 | DBM::Deep->_throw_error('Unknown SQL record id'); |
88 | } |
89 | } |
90 | else { |
91 | my $util = {dbi => $args->{dbi}}; |
92 | bless $util, 'DBM::Deep::SQL::Util'; |
93 | if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { |
94 | $args->{id} = $util->_create('array'); |
95 | } |
96 | else { |
97 | $args->{id} = $util->_create('hash'); |
98 | } |
99 | } |
100 | |
101 | if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { |
102 | $class = 'DBM::Deep::SQL::Array'; |
103 | require DBM::Deep::SQL::Array; |
104 | tie @$self, $class, %$args; |
105 | if ($args->{prefetch}) { |
106 | (tied(@$self))->_prefetch(); |
107 | } |
108 | return bless $self, $class; |
109 | } |
110 | else { |
111 | $class = 'DBM::Deep::SQL::Hash'; |
112 | require DBM::Deep::SQL::Hash; |
113 | tie %$self, $class, %$args; |
114 | if ($args->{prefetch}) { |
115 | (tied(%$self))->_prefetch(); |
116 | } |
117 | return bless $self, $class; |
118 | } |
119 | } |
d0b74c17 |
120 | |
121 | ## |
122 | # Check if we want a tied hash or array. |
123 | ## |
d0b74c17 |
124 | if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { |
6fe26b29 |
125 | $class = 'DBM::Deep::Array'; |
126 | require DBM::Deep::Array; |
d0b74c17 |
127 | tie @$self, $class, %$args; |
128 | } |
129 | else { |
6fe26b29 |
130 | $class = 'DBM::Deep::Hash'; |
131 | require DBM::Deep::Hash; |
d0b74c17 |
132 | tie %$self, $class, %$args; |
133 | } |
ffed8b01 |
134 | |
d0b74c17 |
135 | return bless $self, $class; |
ffed8b01 |
136 | } |
137 | |
96041a25 |
138 | # This initializer is called from the various TIE* methods. new() calls tie(), |
139 | # which allows for a single point of entry. |
0795f290 |
140 | sub _init { |
0795f290 |
141 | my $class = shift; |
994ccd8e |
142 | my ($args) = @_; |
0795f290 |
143 | |
460b1067 |
144 | # locking implicitly enables autoflush |
145 | if ($args->{locking}) { $args->{autoflush} = 1; } |
146 | |
0795f290 |
147 | # These are the defaults to be optionally overridden below |
148 | my $self = bless { |
95967a5e |
149 | type => TYPE_HASH, |
e06824f8 |
150 | base_offset => undef, |
2120a181 |
151 | staleness => undef, |
2120a181 |
152 | engine => undef, |
0795f290 |
153 | }, $class; |
2120a181 |
154 | |
2c70efe1 |
155 | unless ( exists $args->{engine} ) { |
156 | my $class = exists $args->{dbi} |
157 | ? 'DBM::Deep::Engine::DBI' |
158 | : 'DBM::Deep::Engine::File'; |
159 | |
160 | $args->{engine} = $class->new({ |
161 | %{$args}, |
162 | obj => $self, |
163 | }); |
164 | } |
8db25060 |
165 | |
fde3db1a |
166 | # Grab the parameters we want to use |
0795f290 |
167 | foreach my $param ( keys %$self ) { |
168 | next unless exists $args->{$param}; |
3e9498a1 |
169 | $self->{$param} = $args->{$param}; |
ffed8b01 |
170 | } |
d0b74c17 |
171 | |
2120a181 |
172 | eval { |
2c70efe1 |
173 | local $SIG{'__DIE__'}; |
0795f290 |
174 | |
2c70efe1 |
175 | $self->lock_exclusive; |
176 | $self->_engine->setup( $self ); |
177 | $self->unlock; |
2120a181 |
178 | }; if ( $@ ) { |
2c70efe1 |
179 | my $e = $@; |
180 | eval { local $SIG{'__DIE__'}; $self->unlock; }; |
181 | die $e; |
2120a181 |
182 | } |
359a01ac |
183 | |
0795f290 |
184 | return $self; |
ffed8b01 |
185 | } |
186 | |
ffed8b01 |
187 | sub TIEHASH { |
6fe26b29 |
188 | shift; |
189 | require DBM::Deep::Hash; |
190 | return DBM::Deep::Hash->TIEHASH( @_ ); |
ffed8b01 |
191 | } |
192 | |
193 | sub TIEARRAY { |
6fe26b29 |
194 | shift; |
195 | require DBM::Deep::Array; |
196 | return DBM::Deep::Array->TIEARRAY( @_ ); |
ffed8b01 |
197 | } |
198 | |
5c0756fc |
199 | sub lock_exclusive { |
994ccd8e |
200 | my $self = shift->_get_self; |
9c87a079 |
201 | return $self->_engine->lock_exclusive( $self, @_ ); |
5c0756fc |
202 | } |
203 | *lock = \&lock_exclusive; |
204 | sub lock_shared { |
205 | my $self = shift->_get_self; |
9c87a079 |
206 | return $self->_engine->lock_shared( $self, @_ ); |
ffed8b01 |
207 | } |
208 | |
209 | sub unlock { |
994ccd8e |
210 | my $self = shift->_get_self; |
9c87a079 |
211 | return $self->_engine->unlock( $self, @_ ); |
ffed8b01 |
212 | } |
213 | |
906c8e01 |
214 | sub _copy_value { |
215 | my $self = shift->_get_self; |
216 | my ($spot, $value) = @_; |
217 | |
218 | if ( !ref $value ) { |
219 | ${$spot} = $value; |
220 | } |
906c8e01 |
221 | else { |
222 | my $r = Scalar::Util::reftype( $value ); |
edd45134 |
223 | my $tied; |
906c8e01 |
224 | if ( $r eq 'ARRAY' ) { |
edd45134 |
225 | $tied = tied(@$value); |
906c8e01 |
226 | } |
2c70efe1 |
227 | elsif ( $r eq 'HASH' ) { |
edd45134 |
228 | $tied = tied(%$value); |
229 | } |
2c70efe1 |
230 | else { |
231 | __PACKAGE__->_throw_error( "Unknown type for '$value'" ); |
232 | } |
edd45134 |
233 | |
2c70efe1 |
234 | if ( eval { local $SIG{__DIE__}; $tied->isa( __PACKAGE__ ) } ) { |
edd45134 |
235 | ${$spot} = $tied->_repr; |
236 | $tied->_copy_node( ${$spot} ); |
237 | } |
238 | else { |
239 | if ( $r eq 'ARRAY' ) { |
240 | ${$spot} = [ @{$value} ]; |
241 | } |
242 | else { |
243 | ${$spot} = { %{$value} }; |
244 | } |
245 | } |
246 | |
247 | my $c = Scalar::Util::blessed( $value ); |
2c70efe1 |
248 | if ( defined $c && !$c->isa( __PACKAGE__ ) ) { |
edd45134 |
249 | ${$spot} = bless ${$spot}, $c |
906c8e01 |
250 | } |
906c8e01 |
251 | } |
252 | |
253 | return 1; |
254 | } |
255 | |
2120a181 |
256 | #sub _copy_node { |
257 | # die "Must be implemented in a child class\n"; |
258 | #} |
259 | # |
260 | #sub _repr { |
261 | # die "Must be implemented in a child class\n"; |
262 | #} |
ffed8b01 |
263 | |
264 | sub export { |
994ccd8e |
265 | my $self = shift->_get_self; |
d0b74c17 |
266 | |
f9c33187 |
267 | my $temp = $self->_repr; |
d0b74c17 |
268 | |
5c0756fc |
269 | $self->lock_exclusive; |
d0b74c17 |
270 | $self->_copy_node( $temp ); |
5c0756fc |
271 | $self->unlock; |
d0b74c17 |
272 | |
2120a181 |
273 | my $classname = $self->_engine->get_classname( $self ); |
274 | if ( defined $classname ) { |
275 | bless $temp, $classname; |
68f943b3 |
276 | } |
277 | |
d0b74c17 |
278 | return $temp; |
ffed8b01 |
279 | } |
280 | |
e00d0eb3 |
281 | sub _check_legality { |
282 | my $self = shift; |
283 | my ($val) = @_; |
284 | |
285 | my $r = Scalar::Util::reftype( $val ); |
286 | |
287 | return $r if !defined $r || '' eq $r; |
288 | return $r if 'HASH' eq $r; |
289 | return $r if 'ARRAY' eq $r; |
290 | |
2c70efe1 |
291 | __PACKAGE__->_throw_error( |
e00d0eb3 |
292 | "Storage of references of type '$r' is not supported." |
293 | ); |
294 | } |
295 | |
ffed8b01 |
296 | sub import { |
d426259c |
297 | return if !ref $_[0]; # Perl calls import() on use -- ignore |
d0b74c17 |
298 | |
994ccd8e |
299 | my $self = shift->_get_self; |
300 | my ($struct) = @_; |
d0b74c17 |
301 | |
e00d0eb3 |
302 | my $type = $self->_check_legality( $struct ); |
303 | if ( !$type ) { |
2c70efe1 |
304 | __PACKAGE__->_throw_error( "Cannot import a scalar" ); |
d0b74c17 |
305 | } |
306 | |
e00d0eb3 |
307 | if ( substr( $type, 0, 1 ) ne $self->_type ) { |
2c70efe1 |
308 | __PACKAGE__->_throw_error( |
e00d0eb3 |
309 | "Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array') |
310 | . " into " . ('HASH' eq $type ? 'an array' : 'a hash') |
311 | ); |
7a960a12 |
312 | } |
313 | |
e00d0eb3 |
314 | my %seen; |
315 | my $recurse; |
316 | $recurse = sub { |
317 | my ($db, $val) = @_; |
318 | |
319 | my $obj = 'HASH' eq Scalar::Util::reftype( $db ) ? tied(%$db) : tied(@$db); |
320 | $obj ||= $db; |
321 | |
322 | my $r = $self->_check_legality( $val ); |
323 | if ( 'HASH' eq $r ) { |
324 | while ( my ($k, $v) = each %$val ) { |
325 | my $r = $self->_check_legality( $v ); |
326 | if ( $r ) { |
327 | my $temp = 'HASH' eq $r ? {} : []; |
328 | if ( my $c = Scalar::Util::blessed( $v ) ) { |
329 | bless $temp, $c; |
330 | } |
331 | $obj->put( $k, $temp ); |
332 | $recurse->( $temp, $v ); |
333 | } |
334 | else { |
335 | $obj->put( $k, $v ); |
336 | } |
337 | } |
338 | } |
339 | elsif ( 'ARRAY' eq $r ) { |
340 | foreach my $k ( 0 .. $#$val ) { |
341 | my $v = $val->[$k]; |
342 | my $r = $self->_check_legality( $v ); |
343 | if ( $r ) { |
344 | my $temp = 'HASH' eq $r ? {} : []; |
345 | if ( my $c = Scalar::Util::blessed( $v ) ) { |
346 | bless $temp, $c; |
347 | } |
348 | $obj->put( $k, $temp ); |
349 | $recurse->( $temp, $v ); |
350 | } |
351 | else { |
352 | $obj->put( $k, $v ); |
353 | } |
354 | } |
355 | } |
356 | }; |
357 | $recurse->( $self, $struct ); |
358 | |
7a960a12 |
359 | return 1; |
ffed8b01 |
360 | } |
361 | |
13ff93d5 |
362 | #XXX Need to keep track of who has a fh to this file in order to |
363 | #XXX close them all prior to optimize on Win32/cygwin |
d426259c |
364 | # Rebuild entire database into new file, then move |
365 | # it back on top of original. |
ffed8b01 |
366 | sub optimize { |
994ccd8e |
367 | my $self = shift->_get_self; |
cc4bef86 |
368 | |
d426259c |
369 | # Optimizing is only something we need to do when we're working with our |
370 | # own file format. Otherwise, let the other guy do the optimizations. |
51e9eee3 |
371 | return unless $self->_engine->isa( 'DBM::Deep::Engine::File' ); |
d426259c |
372 | |
cc4bef86 |
373 | #XXX Need to create a new test for this |
f1879fdc |
374 | # if ($self->_engine->storage->{links} > 1) { |
1400a48e |
375 | # $self->_throw_error("Cannot optimize: reference count is greater than 1"); |
d0b74c17 |
376 | # } |
377 | |
7a960a12 |
378 | #XXX Do we have to lock the tempfile? |
379 | |
e00d0eb3 |
380 | #XXX Should we use tempfile() here instead of a hard-coded name? |
f1879fdc |
381 | my $temp_filename = $self->_engine->storage->{file} . '.tmp'; |
2c70efe1 |
382 | my $db_temp = __PACKAGE__->new( |
6e6789b0 |
383 | file => $temp_filename, |
2120a181 |
384 | type => $self->_type, |
385 | |
386 | # Bring over all the parameters that we need to bring over |
888453b9 |
387 | ( map { $_ => $self->_engine->$_ } qw( |
388 | byte_size max_buckets data_sector_size num_txns |
389 | )), |
d0b74c17 |
390 | ); |
d0b74c17 |
391 | |
5c0756fc |
392 | $self->lock_exclusive; |
c57b19c6 |
393 | $self->_engine->clear_cache; |
d0b74c17 |
394 | $self->_copy_node( $db_temp ); |
f1879fdc |
395 | $db_temp->_engine->storage->close; |
d0b74c17 |
396 | undef $db_temp; |
397 | |
398 | ## |
399 | # Attempt to copy user, group and permissions over to new file |
400 | ## |
f1879fdc |
401 | $self->_engine->storage->copy_stats( $temp_filename ); |
d0b74c17 |
402 | |
ffed8b01 |
403 | # q.v. perlport for more information on this variable |
90f93b43 |
404 | if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { |
d0b74c17 |
405 | ## |
406 | # Potential race condition when optmizing on Win32 with locking. |
407 | # The Windows filesystem requires that the filehandle be closed |
408 | # before it is overwritten with rename(). This could be redone |
409 | # with a soft copy. |
410 | ## |
5c0756fc |
411 | $self->unlock; |
f1879fdc |
412 | $self->_engine->storage->close; |
d0b74c17 |
413 | } |
414 | |
f1879fdc |
415 | if (!rename $temp_filename, $self->_engine->storage->{file}) { |
6e6789b0 |
416 | unlink $temp_filename; |
5c0756fc |
417 | $self->unlock; |
1400a48e |
418 | $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!"); |
d0b74c17 |
419 | } |
420 | |
5c0756fc |
421 | $self->unlock; |
f1879fdc |
422 | $self->_engine->storage->close; |
2120a181 |
423 | |
f1879fdc |
424 | $self->_engine->storage->open; |
5c0756fc |
425 | $self->lock_exclusive; |
f4d0ac97 |
426 | $self->_engine->setup( $self ); |
5c0756fc |
427 | $self->unlock; |
70b55428 |
428 | |
d0b74c17 |
429 | return 1; |
ffed8b01 |
430 | } |
431 | |
432 | sub clone { |
d0b74c17 |
433 | ## |
434 | # Make copy of object and return |
435 | ## |
994ccd8e |
436 | my $self = shift->_get_self; |
d0b74c17 |
437 | |
2c70efe1 |
438 | return __PACKAGE__->new( |
c3aafc14 |
439 | type => $self->_type, |
d0b74c17 |
440 | base_offset => $self->_base_offset, |
2120a181 |
441 | staleness => $self->_staleness, |
2120a181 |
442 | engine => $self->_engine, |
d0b74c17 |
443 | ); |
ffed8b01 |
444 | } |
445 | |
2120a181 |
446 | #XXX Migrate this to the engine, where it really belongs and go through some |
447 | # API - stop poking in the innards of someone else.. |
ffed8b01 |
448 | { |
449 | my %is_legal_filter = map { |
450 | $_ => ~~1, |
451 | } qw( |
452 | store_key store_value |
453 | fetch_key fetch_value |
454 | ); |
455 | |
456 | sub set_filter { |
994ccd8e |
457 | my $self = shift->_get_self; |
458 | my $type = lc shift; |
459 | my $func = shift; |
d0b74c17 |
460 | |
ffed8b01 |
461 | if ( $is_legal_filter{$type} ) { |
f1879fdc |
462 | $self->_engine->storage->{"filter_$type"} = $func; |
ffed8b01 |
463 | return 1; |
464 | } |
465 | |
466 | return; |
467 | } |
888453b9 |
468 | |
469 | sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); } |
470 | sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); } |
471 | sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); } |
472 | sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); } |
ffed8b01 |
473 | } |
474 | |
fee0243f |
475 | sub begin_work { |
476 | my $self = shift->_get_self; |
db2eb673 |
477 | $self->lock_exclusive; |
c65299b4 |
478 | my $rv = eval { $self->_engine->begin_work( $self, @_ ) }; |
479 | my $e = $@; |
db2eb673 |
480 | $self->unlock; |
c65299b4 |
481 | die $e if $e; |
db2eb673 |
482 | return $rv; |
fee0243f |
483 | } |
484 | |
485 | sub rollback { |
486 | my $self = shift->_get_self; |
db2eb673 |
487 | $self->lock_exclusive; |
c65299b4 |
488 | my $rv = eval { $self->_engine->rollback( $self, @_ ) }; |
489 | my $e = $@; |
db2eb673 |
490 | $self->unlock; |
c65299b4 |
491 | die $e if $e; |
db2eb673 |
492 | return $rv; |
fee0243f |
493 | } |
494 | |
359a01ac |
495 | sub commit { |
496 | my $self = shift->_get_self; |
db2eb673 |
497 | $self->lock_exclusive; |
c65299b4 |
498 | my $rv = eval { $self->_engine->commit( $self, @_ ) }; |
499 | my $e = $@; |
db2eb673 |
500 | $self->unlock; |
c65299b4 |
501 | die $e if $e; |
db2eb673 |
502 | return $rv; |
359a01ac |
503 | } |
fee0243f |
504 | |
ffed8b01 |
505 | # Accessor methods |
72e315ac |
506 | sub _engine { |
507 | my $self = $_[0]->_get_self; |
508 | return $self->{engine}; |
509 | } |
510 | |
4d35d856 |
511 | sub _type { |
2ac02042 |
512 | my $self = $_[0]->_get_self; |
d0b74c17 |
513 | return $self->{type}; |
ffed8b01 |
514 | } |
515 | |
4d35d856 |
516 | sub _base_offset { |
2ac02042 |
517 | my $self = $_[0]->_get_self; |
d0b74c17 |
518 | return $self->{base_offset}; |
ffed8b01 |
519 | } |
520 | |
2120a181 |
521 | sub _staleness { |
522 | my $self = $_[0]->_get_self; |
523 | return $self->{staleness}; |
524 | } |
525 | |
ffed8b01 |
526 | # Utility methods |
261d1296 |
527 | sub _throw_error { |
807f63a7 |
528 | my $n = 0; |
529 | while( 1 ) { |
530 | my @caller = caller( ++$n ); |
531 | next if $caller[0] =~ m/^DBM::Deep/; |
532 | |
533 | die "DBM::Deep: $_[1] at $0 line $caller[2]\n"; |
807f63a7 |
534 | } |
ffed8b01 |
535 | } |
536 | |
d426259c |
537 | # Store single hash key/value or array element in database. |
ffed8b01 |
538 | sub STORE { |
d0b74c17 |
539 | my $self = shift->_get_self; |
2120a181 |
540 | my ($key, $value) = @_; |
c803879b |
541 | warn "STORE($self, '$key', '@{[defined$value?$value:'undef']}')\n" if DEBUG; |
81d3d316 |
542 | |
f1879fdc |
543 | unless ( $self->_engine->storage->is_writable ) { |
acd4faf2 |
544 | $self->_throw_error( 'Cannot write to a readonly filehandle' ); |
545 | } |
d0b74c17 |
546 | |
5c0756fc |
547 | $self->lock_exclusive; |
d0b74c17 |
548 | |
0cb639bd |
549 | # User may be storing a complex value, in which case we do not want it run |
550 | # through the filtering system. |
f1879fdc |
551 | if ( !ref($value) && $self->_engine->storage->{filter_store_value} ) { |
552 | $value = $self->_engine->storage->{filter_store_value}->( $value ); |
d0b74c17 |
553 | } |
554 | |
2c70efe1 |
555 | $self->_engine->write_value( $self, $key, $value ); |
d0b74c17 |
556 | |
5c0756fc |
557 | $self->unlock; |
d0b74c17 |
558 | |
86867f3a |
559 | return 1; |
ffed8b01 |
560 | } |
561 | |
d426259c |
562 | # Fetch single value or element given plain key or array index |
ffed8b01 |
563 | sub FETCH { |
cb79ec85 |
564 | my $self = shift->_get_self; |
2120a181 |
565 | my ($key) = @_; |
c803879b |
566 | warn "FETCH($self, '$key')\n" if DEBUG; |
ffed8b01 |
567 | |
5c0756fc |
568 | $self->lock_shared; |
d0b74c17 |
569 | |
2c70efe1 |
570 | my $result = $self->_engine->read_value( $self, $key ); |
d0b74c17 |
571 | |
5c0756fc |
572 | $self->unlock; |
d0b74c17 |
573 | |
a86430bd |
574 | # Filters only apply to scalar values, so the ref check is making |
575 | # sure the fetched bucket is a scalar, not a child hash or array. |
f1879fdc |
576 | return ($result && !ref($result) && $self->_engine->storage->{filter_fetch_value}) |
577 | ? $self->_engine->storage->{filter_fetch_value}->($result) |
cb79ec85 |
578 | : $result; |
ffed8b01 |
579 | } |
580 | |
d426259c |
581 | # Delete single key/value pair or element given plain key or array index |
ffed8b01 |
582 | sub DELETE { |
a97c8f67 |
583 | my $self = shift->_get_self; |
2120a181 |
584 | my ($key) = @_; |
c803879b |
585 | warn "DELETE($self, '$key')\n" if DEBUG; |
d0b74c17 |
586 | |
f1879fdc |
587 | unless ( $self->_engine->storage->is_writable ) { |
a86430bd |
588 | $self->_throw_error( 'Cannot write to a readonly filehandle' ); |
589 | } |
d0b74c17 |
590 | |
5c0756fc |
591 | $self->lock_exclusive; |
d0b74c17 |
592 | |
d0b74c17 |
593 | ## |
594 | # Delete bucket |
595 | ## |
2120a181 |
596 | my $value = $self->_engine->delete_key( $self, $key); |
a86430bd |
597 | |
f1879fdc |
598 | if (defined $value && !ref($value) && $self->_engine->storage->{filter_fetch_value}) { |
599 | $value = $self->_engine->storage->{filter_fetch_value}->($value); |
3b6a5056 |
600 | } |
601 | |
5c0756fc |
602 | $self->unlock; |
d0b74c17 |
603 | |
604 | return $value; |
ffed8b01 |
605 | } |
606 | |
d426259c |
607 | # Check if a single key or element exists given plain key or array index |
ffed8b01 |
608 | sub EXISTS { |
a97c8f67 |
609 | my $self = shift->_get_self; |
610 | my ($key) = @_; |
c803879b |
611 | warn "EXISTS($self, '$key')\n" if DEBUG; |
d0b74c17 |
612 | |
5c0756fc |
613 | $self->lock_shared; |
d0b74c17 |
614 | |
2120a181 |
615 | my $result = $self->_engine->key_exists( $self, $key ); |
d0b74c17 |
616 | |
5c0756fc |
617 | $self->unlock; |
d0b74c17 |
618 | |
619 | return $result; |
ffed8b01 |
620 | } |
621 | |
d426259c |
622 | # Clear all keys from hash, or all elements from array. |
ffed8b01 |
623 | sub CLEAR { |
a97c8f67 |
624 | my $self = shift->_get_self; |
6e6789b0 |
625 | warn "CLEAR($self)\n" if DEBUG; |
ffed8b01 |
626 | |
f1879fdc |
627 | unless ( $self->_engine->storage->is_writable ) { |
a86430bd |
628 | $self->_throw_error( 'Cannot write to a readonly filehandle' ); |
629 | } |
630 | |
5c0756fc |
631 | $self->lock_exclusive; |
d0b74c17 |
632 | |
2120a181 |
633 | #XXX Rewrite this dreck to do it in the engine as a tight loop vs. |
634 | # iterating over keys - such a WASTE - is this required for transactional |
635 | # clearning?! Surely that can be detected in the engine ... |
f9a320bb |
636 | if ( $self->_type eq TYPE_HASH ) { |
637 | my $key = $self->first_key; |
638 | while ( $key ) { |
83c43bb5 |
639 | # Retrieve the key before deleting because we depend on next_key |
f9a320bb |
640 | my $next_key = $self->next_key( $key ); |
2120a181 |
641 | $self->_engine->delete_key( $self, $key, $key ); |
f9a320bb |
642 | $key = $next_key; |
643 | } |
644 | } |
645 | else { |
646 | my $size = $self->FETCHSIZE; |
c3aafc14 |
647 | for my $key ( 0 .. $size - 1 ) { |
2120a181 |
648 | $self->_engine->delete_key( $self, $key, $key ); |
f9a320bb |
649 | } |
650 | $self->STORESIZE( 0 ); |
651 | } |
d0b74c17 |
652 | |
5c0756fc |
653 | $self->unlock; |
d0b74c17 |
654 | |
655 | return 1; |
ffed8b01 |
656 | } |
657 | |
ffed8b01 |
658 | # Public method aliases |
d426259c |
659 | sub put { (shift)->STORE( @_ ) } |
660 | sub get { (shift)->FETCH( @_ ) } |
661 | sub store { (shift)->STORE( @_ ) } |
662 | sub fetch { (shift)->FETCH( @_ ) } |
baa27ab6 |
663 | sub delete { (shift)->DELETE( @_ ) } |
664 | sub exists { (shift)->EXISTS( @_ ) } |
d426259c |
665 | sub clear { (shift)->CLEAR( @_ ) } |
ffed8b01 |
666 | |
888453b9 |
667 | sub _dump_file {shift->_get_self->_engine->_dump_file;} |
668 | |
ffed8b01 |
669 | 1; |
ffed8b01 |
670 | __END__ |