source: main/trunk/greenstone2/perllib/dbutil.pm

Last change on this file was 35833, checked in by davidb, 2 years ago

Print statement to give more details about the error added
File size: 16.5 KB
Line 
1###############################################################################
2#
3# dbutil.pm -- functions to handle using dbdrivers
4#
5# Copyright (c) 2015 New Zealand Digital Library Project
6#
7# A component of the Greenstone digital library software from the New Zealand
8# Digital Library Project at the University of Waikato, New Zealand.
9#
10# This program is free software; you can redistribute it and/or modify it under
11# the terms of the GNU General Public License as published by the Free Software
12# Foundation; either version 2 of the License, or (at your option) any later
13# version.
14#
15# This program is distributed in the hope that it will be useful, but WITHOUT
16# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
17# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
18# details.
19#
20# You should have received a copy of the GNU General Public License along with
21# this program; if not, write to the Free Software Foundation, Inc., 675 Mass
22# Ave, Cambridge, MA 02139, USA.
23#
24###############################################################################
25
26package dbutil;
27
28# Pragma
29use strict;
30
31# DEBUGGING: You can enable a DBDriver one at a time to ensure they don't have
32# compilation errors.
33BEGIN
34{
35 if (!defined $ENV{'GSDLHOME'} || !defined $ENV{'GSDLOS'}) {
36 die("Error! Environment not prepared. Have you sourced setup.bash?\n");
37 }
38 # Are we running standalone? In which case the INC won't be correct
39 # - derp. Linux only sorry
40 if ($^O !~ /cygwin|MSWin32/) {
41 my $perllib_path = $ENV{'GSDLHOME'} . '/perllib';
42 my $all_inc = join(':', @INC);
43 if ($all_inc !~ /$perllib_path/) {
44 unshift(@INC, $perllib_path);
45 unshift(@INC, $ENV{'GSDLHOME'} . '/ext/parallel-building/perllib');
46 unshift(@INC, $ENV{'GSDLHOME'} . '/ext/tdb/perllib');
47 }
48 }
49 ## You can uncomment and name a Driver here to test it compiles
50 #require DBDrivers::TDBCLUSTER;
51 #my $driver = DBDrivers::TDBCLUSTER->new(1);
52}
53
54# Libraries
55use Devel::Peek;
56use Time::HiRes qw ( gettimeofday tv_interval );
57use FileUtils;
58use gsprintf 'gsprintf';
59use util;
60
61# Modulino pattern
62__PACKAGE__->main unless caller;
63
64###############################################################################
65## Private
66###############################################################################
67
68## Display debug messages?
69my $debug = 0; # Set to 1 to display
70
71## Keep track of the driver objects we have initialised
72my $dbdriver_pool = {};
73
74# Testing globals
75my $test_count = 0;
76my $pass_count = 0;
77my $skip_count = 0;
78
79
80## @function _addPathsToINC(void) => void
81#
82# A hopefully unused function to ensure the INC path contains all the available
83# perllib directories (from main, collection, and extensions)
84#
85sub _addPathsToINC
86{
87 &_debugPrint('_addPathsToINC() => ', 0);
88 my @possible_paths;
89 #... the main perllib directory...
90 push(@possible_paths, &FileUtils::filenameConcatenate());
91 #... a collection specific perllib directory...
92 if (defined $ENV{'GSDLCOLLECTDIR'} && $ENV{'GSDLCOLLECTION'}) {
93 push(@possible_paths, &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'}, 'collect', $ENV{'GSDLCOLLECTION'}, 'perllib'));
94 }
95 #... any registered extension may also have a perllib!
96 if (defined $ENV{'GSDLEXTS'} && defined $ENV{'GSDLHOME'}) {
97 foreach my $gs2_extension (split(/:/, $ENV{'GSDLEXTS'})) {
98 push(@possible_paths, &FileUtils::filenameConcatenate($ENV{'GSDLHOME'}, 'ext', $gs2_extension, 'perllib'));
99 }
100 }
101 if (defined $ENV{'GSDL3EXTS'} && defined $ENV{'GSDL3SRCHOME'}) {
102 foreach my $gs3_extension (split(/:/, $ENV{'GSDL3EXTS'})) {
103 push(@possible_paths, &FileUtils::filenameConcatenate($ENV{'GSDL3SRCHOME'}, 'ext', $gs3_extension, 'perllib'));
104 }
105 }
106 my $path_counter = 0;
107 foreach my $possible_path (@possible_paths) {
108 # we only try adding paths that actually exist
109 if (-d $possible_path) {
110 my $did_add_path = &util::augmentINC($possible_path);
111 if ($did_add_path) {
112 $path_counter++;
113 }
114 }
115 }
116 &_debugPrint('Added ' . $path_counter . ' paths');
117}
118## _addPathsToINC(void) => void #
119
120
121## @function _debugPrint(string, boolean)
122#
123sub _debugPrint
124{
125 my ($message, $newline) = @_;
126 if ($debug) {
127 if (!defined($newline)) {
128 $newline = 1;
129 }
130 print STDERR '[DEBUG] dbutil::' . $message;
131 if ($newline) {
132 print STDERR "\n";
133 }
134 }
135}
136## _debugPrint(string, boolean) => void ##
137
138
139## @function _isDriverLoaded(string) => boolean
140#
141sub _isDriverLoaded
142{
143 my ($dbdriver_name) = @_;
144 (my $dbdriver_file = $dbdriver_name) =~ s/::/\//g;
145 $dbdriver_file .= '.pm';
146 my $result = defined($INC{$dbdriver_file});
147 &_debugPrint('_isDriverLoaded("' . $dbdriver_name . '") => ' . $result);
148 return $result;
149}
150## _isDriverLoaded(string) => boolean ##
151
152## @function _loadDBDriver(string, string)
153#
154sub _loadDBDriver
155{
156 my ($dbdriver_name, $db_filepath) = @_;
157 my $dbdriver;
158 # I've decided (arbitrarily) to use uppercase for driver names since they
159 # are mostly acronyms
160 $dbdriver_name = uc($dbdriver_name);
161 # Ensure the driver has the correct package prefix
162 if ($dbdriver_name !~ /^DBDrivers/) {
163 $dbdriver_name = 'DBDrivers::' . $dbdriver_name;
164 }
165 # We only need to create each driver once
166 if (defined($dbdriver_pool->{$dbdriver_name})) {
167 $dbdriver = $dbdriver_pool->{$dbdriver_name};
168 }
169 else {
170 &_debugPrint('_loadDBDriver() => ' . $dbdriver_name);
171 # Assuming the INC is correctly setup, then this should work nicely
172 # - make sure we have required this dbdriver package
173 eval "require $dbdriver_name";
174 if (&_isDriverLoaded($dbdriver_name)) {
175 $dbdriver_name->import();
176 }
177 # What should we do about drivers that aren't there?
178 else {
179 print STDERR "Error! Failed to load: " . $dbdriver_name . "\n";
180 print STDERR $@;
181 }
182 # Then initialise and return a new one
183 $dbdriver = $dbdriver_name->new($debug);
184 # Store it for later use
185 $dbdriver_pool->{$dbdriver_name} = $dbdriver;
186 }
187 return $dbdriver;
188}
189## _loadDBDriver(string, string) => BaseDBDriver ##
190
191
192## @function _printTest(string, integer) => void
193#
194sub _printTest
195{
196 my $title = shift(@_);
197 my $result = shift(@_);
198 $test_count++;
199 print " - Test: " . $title . "... ";
200 if ($result) {
201 print "Passed\n";
202 $pass_count++;
203 }
204 else {
205 print "Failed\n";
206 }
207}
208## _printTest(string, integer) => void ##
209
210
211sub _compareHash
212{
213 my $hash1 = shift(@_);
214 my $hash2 = shift(@_);
215 my $str1 = &_hash2str($hash1);
216 my $str2 = &_hash2str($hash2);
217 return ($str1 eq $str2);
218}
219
220sub _hash2str
221{
222 my $hash = shift(@_);
223 my $str = '';
224 foreach my $key (sort keys %{$hash}) {
225 $str .= '{' . $key . '=>{{' . join('},{', @{$hash->{$key}}) . '}}}';
226 }
227 return $str;
228}
229
230
231###############################################################################
232## Public
233###############################################################################
234
235
236## @function main(void) => void
237#
238sub main
239{
240 my $t0 = [gettimeofday()];
241 my $data1 = {'doh' => ['a deer, a female deer'],
242 'ray' => ['a drop of golden sun'],
243 'me' => ['a name I call myself'],
244 'far' => ['a long, long way to run']};
245 my $data2 = {'sew' => ['a needle pulling thread'],
246 'lah' => ['a note to follow doh'],
247 'tea' => ['a drink with jam and bread'],
248 'doh' => ['which brings us back to']};
249 $test_count = 0;
250 $pass_count = 0;
251 $skip_count = 0;
252 print "===== DBUtils Testing Suite =====\n";
253 print "For each driver specified, run a battery of tests\n";
254 my @drivers;
255 foreach my $arg (@ARGV) {
256 if ($arg =~ /^-+([a-z]+)(=.+)?$/) {
257 my $arg_name = $1;
258 my $arg_value = $2;
259 if ($arg_name eq 'debug') {
260 $debug = 1;
261 }
262 }
263 else {
264 push(@drivers, $arg);
265 }
266 }
267 if (scalar(@drivers)) {
268 # Ensure the Perl can load the drivers from all the typical places
269 &_addPathsToINC();
270 foreach my $driver_name (@drivers) {
271 my $t1 = [gettimeofday()];
272 print "=== Testing: " . $driver_name . " ===\n";
273 my $driver = _loadDBDriver($driver_name);
274 my $db_path = $driver->get_infodb_file_path('test-doc','/tmp/');
275 print " - Path: " . $db_path . "\n";
276 # 1. Open handle
277 my $db_handle = $driver->open_infodb_write_handle($db_path);
278 &_printTest('opening handle', (defined $db_handle));
279 # 2a. Write entry
280 $driver->write_infodb_entry($db_handle, 'Alpha', $data1);
281 &_printTest('writing entry', 1);
282 # 2b. Write raw entry
283 my $raw_data = $driver->convert_infodb_hash_to_string($data1);
284 $driver->write_infodb_rawentry($db_handle, 'Beta', $raw_data);
285 &_printTest('writing raw entry', 1);
286 # 3. Close handle
287 $driver->close_infodb_write_handle($db_handle);
288 if ($driver->supportsPersistentConnection()) {
289 $test_count += 1;
290 $skip_count += 1;
291 print " - Skipping test as persistent drivers delay 'close'.\n";
292 }
293 else {
294 &_printTest('closing handle', (tell($db_handle) < 1));
295 }
296 if (!$driver->writeOnly()) {
297 # 4a. Read entry
298 my $data3 = $driver->read_infodb_entry($db_path, 'Alpha');
299 &_printTest('read entry', &_compareHash($data1, $data3));
300 # 4b. Read raw entry
301 my $raw_data4 = $driver->read_infodb_rawentry($db_path, 'Beta');
302 my $data4 = $driver->convert_infodb_string_to_hash($raw_data4);
303 &_printTest('read raw entry', &_compareHash($data1, $data4));
304 # 5. Read keys
305 my $keys1 = {};
306 $driver->read_infodb_keys($db_path, $keys1);
307 &_printTest('read keys', (defined $keys1->{'Alpha'} && defined $keys1->{'Beta'}));
308 # 6. Set entry
309 if ($driver->supportsSet()) {
310 my $status = $driver->set_infodb_entry($db_path, 'Alpha', $data2);
311 &_printTest('set entry (1)', ($status >= 0));
312 my $data5 = $driver->read_infodb_entry($db_path, 'Alpha');
313 &_printTest('set entry (2)', &_compareHash($data2, $data5));
314 }
315 else {
316 $test_count += 2;
317 $skip_count += 2;
318 print " - Skipping 2 tests as 'set' is not supported by this driver.\n";
319 }
320 # 7. Delete entry
321 my $db_handle2 = $driver->open_infodb_write_handle($db_path, 'append');
322 $driver->delete_infodb_entry($db_handle2, 'Alpha');
323 $driver->close_infodb_write_handle($db_handle2);
324 my $keys2 = {};
325 $driver->read_infodb_keys($db_path, $keys2);
326 &_printTest('delete entry', ((!defined $keys2->{'Alpha'}) && (defined $keys2->{'Beta'})));
327 }
328 else
329 {
330 $test_count += 6;
331 $skip_count += 6;
332 print " - Skipping 6 tests as driver is write-only.\n";
333 }
334 # 8. Remove test db
335 unlink($db_path);
336 my $t2 = [gettimeofday()];
337 my $elapsed1 = tv_interval($t1, $t2);
338 print " - Testing took " . $elapsed1 . " seconds\n";
339 }
340 print "===== Results =====\n";
341 print "Drivers Tested: " . scalar(@drivers) . "\n";
342 print "Tests Run: " . $test_count . "\n";
343 print "Tests Passed: " . $pass_count . "\n";
344 print "Tests Failed: " . ($test_count - $pass_count - $skip_count) . "\n";
345 print "Tests Skipped: " . $skip_count . "\n";
346 }
347 else
348 {
349 print "Warning! No drivers specified - expected as arguments to call\n";
350 }
351 my $t3 = [gettimeofday()];
352 my $elapsed2 = tv_interval($t0, $t3);
353 print "===== Complete in " . $elapsed2 . " seconds =====\n";
354 print "\n";
355 exit(0);
356}
357## main(void) => void
358
359
360## @function close_infodb_write_handle(string, *) => void
361#
362sub close_infodb_write_handle
363{
364 my $infodb_type = shift(@_);
365 my $driver = _loadDBDriver($infodb_type);
366 $driver->close_infodb_write_handle(@_);
367}
368## close_infodb_write_handle(string, *) => void ##
369
370
371## @function delete_infodb_entry(string, *) => void
372#
373sub delete_infodb_entry
374{
375 my $infodb_type = shift(@_);
376 my $driver = _loadDBDriver($infodb_type);
377 $driver->delete_infodb_entry(@_);
378}
379## delete_infodb_entry(string, *) => void ##
380
381
382## @function mergeDatabases(string, *) => integer
383#
384sub mergeDatabases
385{
386 my $infodb_type = shift(@_);
387 my $driver = _loadDBDriver($infodb_type);
388 my $status = $driver->mergeDatabases(@_);
389 return $status;
390}
391## mergeDatabases(string, *) => integer ##
392
393
394## @function get_default_infodb_type(void) => string
395#
396sub get_default_infodb_type
397{
398 # The default is GDBM so everything works the same for existing collections
399 # To use something else, specify the "infodbtype" in the collection's collect.cfg file
400 return 'gdbm';
401}
402## get_default_infodb_type(void) => string ##
403
404
405## @function get_infodb_file_path(string, *) => string
406#
407sub get_infodb_file_path
408{
409 my $infodb_type = shift(@_);
410 my $driver = _loadDBDriver($infodb_type);
411 my $infodb_file_path = $driver->get_infodb_file_path(@_);
412 return $infodb_file_path;
413}
414## get_infodb_file_path(string, *) => string ##
415
416
417## @function convert_infodb_string_to_hash(string,hashmap) => string
418#
419sub convert_infodb_string_to_hash
420{
421 my $infodb_type = shift(@_);
422 my $driver = _loadDBDriver($infodb_type);
423 my $infodb_handle = $driver->convert_infodb_string_to_hash(@_);
424 return $infodb_handle;
425}
426## open_infodb_write_handle(string,hashmap) => string ##
427
428
429## @function open_infodb_write_handle(string, *) => filehandle
430#
431sub open_infodb_write_handle
432{
433 my $infodb_type = shift(@_);
434 my $driver = _loadDBDriver($infodb_type);
435 my $infodb_handle = $driver->open_infodb_write_handle(@_);
436 return $infodb_handle;
437}
438## open_infodb_write_handle(string, *) => filehandle ##
439
440
441## @function read_infodb_file(string, *) => void
442#
443sub read_infodb_file
444{
445 my $infodb_type = shift(@_);
446 my $driver = _loadDBDriver($infodb_type);
447 $driver->read_infodb_file(@_);
448}
449## read_infodb_file(string, *) => void ##
450
451
452## @function read_infodb_keys(string, *) => void
453#
454sub read_infodb_keys
455{
456 my $infodb_type = shift(@_);
457 my $driver = _loadDBDriver($infodb_type);
458 $driver->read_infodb_keys(@_);
459}
460## read_infodb_keys(string, *) => void ##
461
462
463## @function read_infodb_entry(string, *) => hashmap
464#
465sub read_infodb_entry
466{
467 my $infodb_type = shift(@_);
468 my $driver = _loadDBDriver($infodb_type);
469 my $infodb_entry = $driver->read_infodb_entry(@_);
470 return $infodb_entry;
471}
472## read_infodb_entry(string, *) => hashmap ##
473
474
475## @function read_infodb_rawentry(string, *) => string
476#
477sub read_infodb_rawentry
478{
479 my $infodb_type = shift(@_);
480 my $driver = _loadDBDriver($infodb_type);
481 my $raw_infodb_entry = $driver->read_infodb_rawentry(@_);
482 return $raw_infodb_entry;
483}
484## read_infodb_rawentry(string, *) => string ##
485
486
487## @function set_infodb_entry(string, *) => integer
488#
489sub set_infodb_entry
490{
491 my $infodb_type = shift(@_);
492 my $driver = _loadDBDriver($infodb_type);
493 my $status = $driver->set_infodb_entry(@_);
494 return $status;
495}
496## set_infodb_entry(string, *) => integer ##
497
498
499## @function supportDatestamp(string) => boolean
500#
501sub supportsDatestamp
502{
503 my $infodb_type = shift(@_);
504 my $driver = _loadDBDriver($infodb_type);
505 my $supports_datestamp = $driver->supportsDatestamp();
506 return $supports_datestamp;
507}
508## supportsDatestamp(string) => boolean ##
509
510
511## @function supportMerge(string) => boolean
512#
513sub supportsMerge
514{
515 my $infodb_type = shift(@_);
516 my $driver = _loadDBDriver($infodb_type);
517 my $supports_merge = $driver->supportsMerge();
518 return $supports_merge;
519}
520## supportsMerge(string) => boolean ##
521
522
523## @function supportRSS(string) => boolean
524#
525sub supportsRSS
526{
527 my $infodb_type = shift(@_);
528 my $driver = _loadDBDriver($infodb_type);
529 my $supports_rss = $driver->supportsRSS();
530 return $supports_rss;
531}
532## supportsRSS(string) => boolean ##
533
534
535## @function supportsConcurrentReadAndWrite(string) => boolean
536#
537sub supportsConcurrentReadAndWrite
538{
539 my $infodb_type = shift(@_);
540 my $driver = _loadDBDriver($infodb_type);
541 return $driver->supportsConcurrentReadAndWrite();
542}
543## supportsConcurrentReadAndWrite(string) => boolean ##
544
545
546## @function write_infodb_entry(string, *) => void
547#
548sub write_infodb_entry
549{
550 my $infodb_type = shift(@_);
551 my $driver = _loadDBDriver($infodb_type);
552 $driver->write_infodb_entry(@_);
553}
554## write_infodb_entry(string, *) => void ##
555
556
557## @function write_infodb_rawentry(string, *) => void
558#
559sub write_infodb_rawentry
560{
561 my $infodb_type = shift(@_);
562 my $driver = _loadDBDriver($infodb_type);
563 $driver->write_infodb_rawentry(@_);
564}
565## write_infodb_rawentry(string, *) => void ##
566
567## @function rename_db_file_to(string, string) => void
568#
569sub rename_db_file_to {
570 my $infodb_type = shift(@_);
571 my $driver = _loadDBDriver($infodb_type);
572 $driver->rename_db_file_to(@_);
573}
574## rename_db_file_to(string, string) => void ##
575
576## @function remove_db_file(string) => void
577#
578sub remove_db_file {
579 my $infodb_type = shift(@_);
580 my $driver = _loadDBDriver($infodb_type);
581 $driver->remove_db_file(@_);
582}
583## remove_db_file(string, string) => void ##
584
5851;
Note: See TracBrowser for help on using the repository browser.