File Coverage

lib/Search/InvertedIndex/DB/DB_File_SplitHash.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package Search::InvertedIndex::DB::DB_File_SplitHash;
2              
3             # $RCSfile: DB_File_SplitHash.pm,v $ $Revision: 1.5 $ $Date: 1999/10/20 16:51:00 $ $Author: snowhare $
4              
5 1     1   6 use strict;
  1         3  
  1         44  
6 1     1   6 use Carp;
  1         31  
  1         92  
7 1     1   6 use Fcntl qw (:flock);
  1         1  
  1         159  
8 1     1   758 use DB_File;
  0            
  0            
9             use Class::NamedParms;
10             use Class::ParmList;
11             use Tie::DB_File::SplitHash;
12             use vars qw (@ISA $VERSION);
13              
14             @ISA = qw(Class::NamedParms);
15             $VERSION = "1.07";
16              
17             # Used to catch attempts to open the same db
18             # to multiple objects simultaneously and to
19             # store the object refs for the db databases.
20              
21             my $open_maps = {};
22             my $FH_COUNT = 0;
23              
24             =head1 NAME
25              
26             Search::InvertedIndex::DB::DB_File_SplitHash - A Berkeley database interface object for Search::InvertedIndex
27              
28             =head1 SYNOPSIS
29              
30             use Search::InvertedIndex::DB::DB_File_SplitHash;
31              
32             my $db = Search::InvertedIndex::DB::DB_File_SplitHash->new({
33             -map_name => '/www/search-engine/databases/test-map_names/test',
34             -multi => 4,
35             -file_mode => 0644,
36             -lock_mode => 'EX',
37             -lock_timeout => 30,
38             -blocking_locks => 0,
39             -cachesize => 1000000,
40             -write_through => 0,
41             -read_write_mode => 'RDONLY';
42             });
43              
44             my $inv_map = Search::InvertedIndex->new({ -database => $db });
45              
46             my $query = Search::InvertedIndex::Query->new(...);
47             my $result = $inv_map->search({ -query => $query });
48              
49             my $update = Search::InvertedIndex::Update->new(...);
50             my $result = $inv_map->update({ -update => $update });
51              
52             $inv_map->close;
53              
54             =head1 DESCRIPTION
55              
56             Provides a standard interface to an underlaying database -
57             in this case Berkeley DB as extended by the Tie::DB_File::SplitHash
58             package.
59              
60             There are twelve standard API calls required of any database interface
61             used by the Search::InvertedIndex module:
62              
63             new - Takes all parameters required for initialization.
64             Free form parameters as required by the underlaying
65             database.
66             open - Actually opens the database. No parameters.
67             close - Closes the database. No parameters.
68             lock - Sets a lock state of (UN, SH or EX) and optionally allows setting/
69             changing the 'blocking/non-blocking' and timeouts for locking.
70             get - Fetches a string -value for a -key. Returns 'undef' if no -key matches in the database.
71             put - Stores a string -value for a -key. Returns true on success, false on failure.
72             exists - Returns true if the -key is defined in the database, false otherwise.
73             delete - Removes a -key and associated -value from database. Returns true on success, false on failure.
74             clear - Clears all keys/values from the database
75             status - Returns open and lock status messages.
76              
77             DESTROY - Used to dispose of the database object
78              
79             =head1 CHANGES
80              
81             1.00 1999.06.16 - Initial release.
82              
83             1.01 1999.06.17 - Bug fix to 'close' method. Failed to clear the filehandle used for locking.
84              
85             1.02 1999.06.18 - Major bugfix to locking system and performance tweaking
86              
87             1.03 1999.07.01 - Documentation corrections.
88              
89             1.04 1999.10.20 - Removed use of 'use attr' for portability improvement
90              
91             1.06 2000.01.25 - Bugfix (added 'use Tie::DB_File::SplitHash;' to initialization)
92              
93             1.07 2000.03.23 - Bugfix for disposal when database was never actually opened
94              
95             =head2 Public API
96              
97             =cut
98              
99             ####################################################################
100              
101             =over 4
102              
103             =item C
104              
105             Provides the interface for obtaining a new Search::InvertedIndex
106             object for manipulating a inverted database.
107              
108             Example 1: my $inv_map = Search::InvertedIndex->new;
109              
110             Example 2: my $inv_map = Search::InvertedIndex->new({
111             -map_name => '/tmp/imap', # file path to map
112             -multi => 4, # multiple DB file factor. Defaults to 4
113             -file_mode => 0644, # File permissions to open with. Defaults to 0666.
114             -cachesize => 1000000, # DB cache size. Defaults to 1000000
115             -lock_mode => 'EX', # DB lock mode. Defaults to EX
116             -lock_timeout => 30, # Seconds to try and get locks. Defaults to 30
117             -write_through => 0, # Write through on cache? Defaults to 0 (no)
118             -blocking_locks => 0, # Locks should block? Defaults to 0 (no)
119             -read_write_mode => 'RDWR', # RDONLY or RDWR? Defaults to 'RDWR'
120             });
121              
122             =back
123              
124             =cut
125              
126             sub new {
127             my $proto = shift;
128             my $class = ref ($proto) || $proto;
129             my $self = Class::NamedParms->new(qw(-map_name -file_mode -write_through
130             -cachesize -lock_timeout -blocking_locks
131             -fd -filehandle -read_write_mode
132             -multi -lock_mode -open_status
133             -ident -hash));
134              
135             bless $self,$class;
136              
137             # Read any passed parms
138             my ($parm_ref) = {};
139             if ($#_ == 0) {
140             $parm_ref = shift;
141             } elsif ($#_ > 0) {
142             %$parm_ref = @_;
143             }
144              
145             # Check the passed parms and set defaults as necessary
146             my $parms = Class::ParmList->new({ -parms => $parm_ref,
147             -legal => [-map_name, -cachesize, -read_write_mode,
148             -multi, -write_through,
149             -lock_mode, -lock_timeout,
150             -file_mode, -blocking_locks,
151             ],
152             -required => [-map_name, -lock_mode ],
153             -defaults => { -multi => 4, -blocking_locks => 0,
154             -file_mode => 0666, -cachesize => 5000000,
155             -write_through => 0, -read_write_mode => 'RDWR',
156             -lock_timeout => 30,
157             },
158             });
159              
160             if (not defined $parms) {
161             my $error_message = Class::ParmList->error;
162             croak (__PACKAGE__ . "::new() - $error_message\n");
163             }
164             $self->SUPER::set($parms->all_parms);
165             my $map_name = $self->SUPER::get('-map_name');
166             $self->map_name($map_name);
167              
168             $self->SUPER::set({ -fd => undef,
169             -open_status => 0,
170             -filehandle => undef,
171             -ident => time,
172             });
173              
174             $self;
175             }
176              
177              
178             ###############################################################
179             # Special accessor for '-map_name' because it is referenced
180             # so frequently.
181             sub map_name {
182             my $self = shift;
183             my $package = __PACKAGE__;
184             if (@_ == 1) {
185             $self->{$package}->{-map_name} = shift;
186             return;
187             } else {
188             return $self->{$package}->{-map_name};
189             }
190             }
191             ###############################################################
192              
193             =over 4
194              
195             =item C
196              
197             Actually open the database for use.
198              
199             Example 1: $inv_map->open;
200              
201             =back
202              
203             =cut
204              
205             sub open {
206             my $self= shift;
207              
208             # use attrs qw(method);
209            
210             # Check if they have _already_ opened this map
211             my ($map) = $self->map_name;
212             if ($map eq '') {
213             croak (__PACKAGE__ . "::open() - Called without a -map_name specification\n");
214             }
215             if (defined $open_maps->{$map}) {
216             croak (__PACKAGE__ . "::open() - Attempted to open -map_name '$map' multiple times\n");
217             }
218              
219             # Do it.
220             $self->_open_multi_map;
221             if (not defined $open_maps->{$map}) {
222             croak (__PACKAGE__ . "::open() - failed to open '$map'. Reason unknown. $!\n");
223             }
224             my ($fd) = $self->SUPER::get(-fd);
225             if (not defined $fd) {
226             croak (__PACKAGE__ . "::open() - failed to open '$map' - bad file descriptor returned\n");
227             }
228             $self->SUPER::set({ -open_status => 1 });
229             }
230              
231             ####################################################################
232              
233             =over 4
234              
235             =item C
236              
237             Returns the requested status line for the database. Allowed requests
238             are '-open', and '-lock'.
239              
240             Example 1:
241             my $status = $db->status(-open); # Returns either '1' or '0'
242              
243             Example 2:
244             my $status = $db->status(-lock_mode); # Returns 'UN', 'SH' or 'EX'
245              
246             =back
247              
248             =cut
249              
250             sub status {
251             my $self = shift;
252              
253             my ($request) = @_;
254              
255             $request = lc ($request);
256             if ($request eq '-open') {
257             return $self->SUPER::get(-open_status);
258             }
259             if ($request eq '-lock_mode') {
260             return uc($self->SUPER::get(-lock_mode));
261             }
262             croak (__PACKAGE__ . "::status - Invalid status request of '$request' made. Only '-lock' and '-open' are legal.\n");
263             }
264              
265             ####################################################################
266              
267             =over 4
268              
269             =item C
270              
271             Sets or changes a filesystem lock on the underlaying database files.
272             Forces 'sync' if the stat is changed from 'EX' to a lower lock state
273             (i.e. 'SH' or 'UN'). Croaks on errors.
274              
275             Example:
276              
277             $inv->lock({ -lock_mode => 'EX',
278             -lock_timeout => 30,
279             -blocking_locks => 0,
280             });
281              
282             The only _required_ parameter is the -lock_mode. The other
283             parameters can be inherited from the object state. If the
284             other parameters are used, they change the object state
285             to match the new settings.
286              
287             =back
288              
289             =cut
290              
291             sub lock {
292             my $self = shift;
293              
294             my ($parm_ref) = {};
295             if ($#_ == 0) {
296             $parm_ref = shift;
297             } elsif ($#_ > 0) {
298             %$parm_ref = @_;
299             }
300             my $parms = Class::ParmList->new ({ -parms => $parm_ref,
301             -legal => [-blocking_locks, -lock_timeout],
302             -required => [-lock_mode],
303             });
304             if (not defined $parms) {
305             my $error_message = Class::ParmList->error;
306             croak (__PACKAGE__ . "::lock() - $error_message\n");
307             }
308             my $map = $self->map_name;
309             if (not defined $open_maps->{$map}) {
310             croak (__PACKAGE__ . "::lock() - attempted to lock a map '$map' that was not open.\n");
311             }
312             my ($new_lock_mode,$new_blocking_locks,$new_lock_timeout) = $parms->get(-lock_mode,-blocking_locks,-lock_timeout);
313             my ($old_lock_mode) = $self->SUPER::get(-lock_mode);
314             $old_lock_mode = uc ($old_lock_mode);
315              
316             if (defined $new_blocking_locks) {
317             $self->SUPER::set({ -blocking_locks => $new_blocking_locks });
318             }
319             if (defined $new_lock_timeout) {
320             $self->SUPER::set({ -lock_timeout => $new_lock_timeout });
321             }
322             my ($lock_timeout,$blocking_locks,$fh) = $self->SUPER::get(-lock_timeout,-blocking_locks,-filehandle);
323             if (not defined $fh) {
324             croak (__PACKAGE__ . "::lock() - no filehandle available for locking\n");
325             }
326             $new_lock_mode = uc ($new_lock_mode);
327             return if ($new_lock_mode eq $old_lock_mode);
328              
329             # Sync if leaving 'EX' mode for another mode
330             if (($new_lock_mode ne 'EX') and ($old_lock_mode eq 'EX')) {
331             if (not defined $map) {
332             croak (__PACKAGE__ . "::lock() - no database open for locking\n");
333             }
334             my $db_object = $open_maps->{$map};
335             if (not defined $db_object) {
336             croak (__PACKAGE__ . "::lock() - no database object available for syncing $map\n");
337             }
338             $db_object->sync;
339             }
340              
341             # Assemble the locking flags
342             my $operation = 0;
343             if (not $blocking_locks) {
344             $operation |= LOCK_NB();
345             }
346             if ($new_lock_mode eq 'EX') {
347             $operation |= LOCK_EX();
348             } elsif ($new_lock_mode eq 'SH') {
349             $operation |= LOCK_SH();
350             } elsif ($new_lock_mode eq 'UN') {
351             $operation |= LOCK_UN();
352             } else {
353             croak (__PACKAGE__ . "::lock() - Unknown locking mode of '$new_lock_mode' was specified\n");
354             }
355             # Get the new lock or die trying
356             $lock_timeout *= 10;
357             no strict 'refs';
358             until (flock ($fh,$operation)) {
359             if (0 >= $lock_timeout--) {
360             croak (__PACKAGE__ . "::lock() - Unable to obtain a '$new_lock_mode' lock on the map: $!");
361             }
362             select (undef,undef,undef,0.1); # Sleep 1/10th of a second
363             }
364             use strict 'refs';
365             # The idea is to never think we have a lock we don't actually have
366             $self->SUPER::set({ -lock_mode => $new_lock_mode });
367             }
368              
369             ####################################################################
370              
371             =over 4
372              
373             =item C
374              
375             Closes the currently open -map_name and flushes all associated buffers.
376              
377             =back
378              
379             =cut
380              
381             sub close {
382             my ($self) = shift;
383             $self->SUPER::set({ -open_status => 0 });
384             my ($map) = $self->map_name;
385             return if (not defined $map);
386             my $db_object = $open_maps->{$map};
387             return if (not defined $db_object);
388             $db_object->sync;
389             $db_object = undef;
390             my ($hash) = $self->SUPER::get(-hash);
391             $self->SUPER::clear(qw(-filehandle -fd -hash));
392             delete $open_maps->{$map};
393             if (not untie (%$hash)) {
394             croak(__PACKAGE__ . "::close() - failed to untie hash\n");
395             }
396             }
397              
398             ####################################################################
399              
400             =over 4
401              
402             =item C
403              
404             Closes the currently open -map_name and flushes all associated buffers.
405              
406             =back
407              
408             =cut
409              
410             sub DESTROY {
411             my ($self) = shift;
412             $self->close;
413             }
414              
415             ###############################################################
416              
417             =over 4
418              
419             =item C $key, -value => $value });>
420              
421             Stores the -value at the -key location in the database. No
422             serialization is performed - this is a pure 'store a string'
423             method. Returns '1' on success, '0' on failure.
424              
425             =back
426              
427             =cut
428              
429             sub put {
430             my ($self) = shift;
431              
432             # We *DON'T* use Class::ParmList here because this routine
433             # is called many thousands of times. Performance counts here.
434             my ($parm_ref) = {};
435             if ($#_ == 0) {
436             $parm_ref = shift;
437             } elsif ($#_ > 0) {
438             %$parm_ref = @_;
439             }
440             my $parms = {};
441             %$parms = map { (lc($_),$parm_ref->{$_}) } keys %$parm_ref;
442             my @key_list = keys %$parms;
443             if ($#key_list != 1) {
444             croak (__PACKAGE__ . "::put() - incorrect number of parameters\n");
445             }
446             my $key = $parms->{'-key'};
447             if (not defined $key) {
448             croak (__PACKAGE__ . "::put() - invalid passed -key. 'undef' not allowed as a key.\n");
449             }
450             my $value = $parms->{'-value'};
451             if (not defined $key) {
452             croak (__PACKAGE__ . "::delete() - invalid passed -value. 'undef' not allowed as a value.\n");
453             }
454             my ($map) = $self->map_name;
455             my ($db_object) = $open_maps->{$map};
456             my ($status) = $db_object->put($key,$value);
457             if ($status) {
458             return 0;
459             }
460             1;
461             }
462              
463             ####################################################################
464              
465             =over 4
466              
467             =item C $key });>
468              
469             Returns the -value at the -key location in the database. No
470             deserialization is performed - this is a pure 'fetch a string'
471             method. It returns 'undef' if no such key exists in the database.
472              
473             Example:
474              
475             my ($value) = $db->get({ -key => $key });
476              
477             =back
478              
479             =cut
480              
481             sub get {
482             my ($self) = shift;
483              
484             # We *DON'T* use Class::ParmList here because this routine
485             # is called many thousands of times. Performance counts here.
486             my ($parm_ref) = {};
487             if ($#_ == 0) {
488             $parm_ref = shift;
489             } elsif ($#_ > 0) {
490             %$parm_ref = @_;
491             }
492             my $parms = {};
493             %$parms = map { (lc($_),$parm_ref->{$_}) } keys %$parm_ref;
494             my @key_list = keys %$parms;
495             if ($#key_list != 0) {
496             croak (__PACKAGE__ . "::get() - incorrect number of parameters\n");
497             }
498             my $key = $parms->{'-key'};
499             if (not defined $key) {
500             croak (__PACKAGE__ . "::get() - invalid passed -key. 'undef' not allowed as a key.\n");
501             }
502             my ($value);
503             my ($map) = $self->map_name;
504             my ($db_object) = $open_maps->{$map};
505             my ($status) = $db_object->get($key,$value);
506             return undef if ($status);
507             $value;
508             }
509              
510             ####################################################################
511              
512             =over 4
513              
514             =item C $key });>
515              
516             Deletes the -value at the -key location in the database.
517              
518             =back
519              
520             =cut
521              
522             sub delete {
523             my ($self) = shift;
524             # use attrs qw (method);
525              
526             # We *DON'T* use Class::ParmList here because this routine
527             # is called many thousands of times. Performance counts here.
528             my ($parm_ref) = {};
529             if ($#_ == 0) {
530             $parm_ref = shift;
531             } elsif ($#_ > 0) {
532             %$parm_ref = @_;
533             }
534             my $parms = {};
535             %$parms = map { (lc($_),$parm_ref->{$_}) } keys %$parm_ref;
536             my @key_list = keys %$parms;
537             if ($#key_list != 0) {
538             croak (__PACKAGE__ . "::delete() - incorrect number of parameters\n");
539             }
540             if ($key_list[0] ne '-key') {
541             croak (__PACKAGE__ . "::delete() - invalid passed parameter name of '$key_list[0]'\n");
542             }
543             my $key = $parms->{'-key'};
544             if (not defined $key) {
545             croak (__PACKAGE__ . "::delete() - invalid passed -key value. 'undef' not allowed as a key.\n");
546             }
547             my ($map) = $self->map_name;
548             my ($db_object) = $open_maps->{$map};
549             my ($status) = $db_object->del($key);
550             return 0 if ($status);
551             1;
552             }
553             ####################################################################
554              
555             =over 4
556              
557             =item C $key});>
558              
559             Returns true if the -key exists in the database.
560             Returns false if the -key does not exist in the database.
561              
562             =back
563              
564             =cut
565              
566             sub exists {
567             my ($self) = shift;
568              
569             # We *DON'T* use Class::ParmList here because this routine
570             # is called many thousands of times. Performance counts here.
571             my ($parm_ref) = {};
572             if ($#_ == 0) {
573             $parm_ref = shift;
574             } elsif ($#_ > 0) {
575             %$parm_ref = @_;
576             }
577             my $parms = {};
578             %$parms = map { (lc($_),$parm_ref->{$_}) } keys %$parm_ref;
579             my @key_list = keys %$parms;
580             if ($#key_list != 0) {
581             croak (__PACKAGE__ . "::delete() - incorrect number of parameters\n");
582             }
583             if ($key_list[0] ne '-key') {
584             croak (__PACKAGE__ . "::delete() - invalid passed parameter name of '$key_list[0]'\n");
585             }
586             my $key = $parms->{'-key'};
587             if (not defined $key) {
588             croak (__PACKAGE__ . "::delete() - invalid passed -key value. 'undef' not allowed as a key.\n");
589             }
590             my ($map) = $self->map_name;
591             my ($db_object) = $open_maps->{$map};
592             $db_object->exists($key);
593             }
594              
595             ####################################################################
596              
597             =over 4
598              
599             =item C
600              
601             Internal method. Not for access outside of the module.
602              
603             Completely clears the map database.
604              
605             =back
606              
607             =cut
608              
609             sub clear {
610             my ($self) = shift;
611              
612             my ($map) = $self->map_name;
613             my ($db_object) = $open_maps->{$map};
614             $db_object->CLEAR;
615             }
616              
617             ###############################################################
618             # _open_multi_map;
619             #
620             #Internal method. Not for access outside of the module.
621             #
622             #Actually open the map for use using either DB_File or
623             #Tie::DB_File_SplitHash as appropriate.
624             #
625             #Example 1: $self->_open_multi_map;
626             #
627              
628             sub _open_multi_map {
629             my ($self) = shift;
630              
631             # Open the map
632             my $map = $self->map_name;
633             my ($cachesize,$file_mode,$lock_mode,$lock_timeout,$blocking_locks,
634             $multi,$write_through,$read_write_mode) = $self->SUPER::get(-cachesize,-file_mode,
635             -lock_mode,-lock_timeout,-blocking_locks,-multi,-write_through,-read_write_mode);
636              
637             # Cache tuning is allowed
638             $DB_HASH->{'cachesize'} = $cachesize;
639              
640             # Read/Write mode setup
641             my $flags = 0;
642             $read_write_mode = uc($read_write_mode);
643             if ($read_write_mode eq 'RDONLY') {
644             $flags |= O_RDONLY();
645             } elsif ($read_write_mode eq 'RDWR') {
646             $flags |= O_RDWR()|O_CREAT();
647             } else {
648             croak(__PACKAGE__ . "::_open_multi_map() - Unrecognized -read_write_mode of '$read_write_mode' (must be either 'RDWR' or 'RDONLY')\n");
649             }
650              
651             # Allow for 'write through'
652             if ($write_through) {
653             $flags |= O_SYNC();
654             }
655              
656             # Tie the map database
657             my $hash = {};
658             my $db_object;
659             if ($multi == 1) { # Performance hack. With only 1 it is 2-3x faster to just tie directly to DB_File.
660             eval {
661             $db_object = tie (%$hash,'DB_File',$map,$flags,$file_mode,$DB_HASH);
662             };
663             } else {
664             eval {
665             $db_object = tie (%$hash,'Tie::DB_File::SplitHash',$map,$flags,$file_mode,$DB_HASH,$multi);
666             };
667             }
668              
669             if ($@) {
670             croak (__PACKAGE__ . "::_open_multi_map() - Unable to tie -map_name '$map': $@\n");
671             }
672              
673             if (not defined $db_object) {
674             croak (__PACKAGE__ . "::_open_multi_map() - Unable to tie -map_name '$map': $!\n");
675             }
676             if (not ref $db_object) {
677             croak (__PACKAGE__ . "::_open_multi_map() - Returned object was not a reference: $!\n");
678             }
679             $open_maps->{$map} = $db_object;
680              
681             # Set locking up for the initial state
682             my $fd = $db_object->fd;
683             if (not defined $fd) {
684             croak (__PACKAGE__ . "::_open_multi_map() - Unable to get a file descriptor for the -map_name '$map': $!\n");
685             }
686             $FH_COUNT++;
687             my $fh = "FH_COUNTER_$FH_COUNT";
688             no strict 'refs';
689             CORE::open ($fh, "+<&=$fd") or croak (__PACKAGE__ . "::_open_multi_map() - unable to open file descriptor for locking: $!");
690             use strict 'refs';
691             $self->SUPER::set({ -filehandle => $fh,
692             -lock_mode => 'UN',
693             -hash => $hash,
694             -fd => $fd,
695             });
696             $lock_mode = 'SH' if (not defined $lock_mode);
697             $lock_mode = uc($lock_mode);
698             eval { $self->lock({ -lock_mode => $lock_mode }); }; # Lock gets its arguments from the object state by default
699             if ($@) {
700             my $error = $@;
701             $self->SUPER::clear(-filehandle,-hash,-fd);
702             delete $open_maps->{$map};
703             undef $hash;
704             undef $db_object;
705             croak (__PACKAGE__ . "::_open_multi_map() - Failed to lock the -map_name '$map' to lock mode '$lock_mode': $error\n");
706             }
707              
708             }
709              
710             ####################################################################
711              
712             =head1 COPYRIGHT
713              
714             Copyright 1999, Benjamin Franz () and
715             FreeRun Technologies, Inc. (). All Rights Reserved.
716             This software may be copied or redistributed under the same terms as Perl itelf.
717              
718             =head1 AUTHOR
719              
720             Benjamin Franz
721              
722             =head1 TODO
723              
724             Everything.
725              
726             =cut
727              
728             1;