root/main/trunk/greenstone2/perllib/dbutil.pm @ 30357

Revision 30357, 15.4 KB (checked in by jmt12, 5 years ago)

Wrapped the code that checks the path for the perllib in a 'not-windows' test, as something about the drive path breaks the Perl's regular expression engine

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    }
181        # Then initialise and return a new one
182        $dbdriver = $dbdriver_name->new($debug);
183        # Store it for later use
184        $dbdriver_pool->{$dbdriver_name} = $dbdriver;
185    }
186    return $dbdriver;
187}
188## _loadDBDriver(string, string) => BaseDBDriver ##
189
190
191## @function _printTest(string, integer) => void
192#
193sub _printTest
194{
195    my $title = shift(@_);
196    my $result = shift(@_);
197    $test_count++;
198    print " - Test: " . $title . "... ";
199    if ($result) {
200    print "Passed\n";
201    $pass_count++;
202    }
203    else {
204    print "Failed\n";
205    }
206}
207## _printTest(string, integer) => void ##
208
209
210sub _compareHash
211{
212    my $hash1 = shift(@_);
213    my $hash2 = shift(@_);
214    my $str1 = &_hash2str($hash1);
215    my $str2 = &_hash2str($hash2);
216    return ($str1 eq $str2);
217}
218
219sub _hash2str
220{
221    my $hash = shift(@_);
222    my $str = '';
223    foreach my $key (sort keys %{$hash}) {
224    $str .= '{' . $key . '=>{{' . join('},{', @{$hash->{$key}}) . '}}}';
225    }
226    return $str;
227}
228
229
230###############################################################################
231## Public
232###############################################################################
233
234
235## @function main(void) => void
236#
237sub main
238{
239    my $t0 = [gettimeofday()];
240    my $data1 = {'doh' => ['a deer, a female deer'],
241        'ray' => ['a drop of golden sun'],
242        'me'  => ['a name I call myself'],
243        'far' => ['a long, long way to run']};
244    my $data2 = {'sew' => ['a needle pulling thread'],
245         'lah' => ['a note to follow doh'],
246         'tea' => ['a drink with jam and bread'],
247         'doh' => ['which brings us back to']};
248    $test_count = 0;
249    $pass_count = 0;
250    $skip_count = 0;
251    print "===== DBUtils Testing Suite =====\n";
252    print "For each driver specified, run a battery of tests\n";
253    my @drivers;
254    foreach my $arg (@ARGV) {
255    if ($arg =~ /^-+([a-z]+)(=.+)?$/) {
256        my $arg_name = $1;
257        my $arg_value = $2;
258        if ($arg_name eq 'debug') {
259        $debug = 1;
260        }
261    }
262    else {
263        push(@drivers, $arg);
264    }
265    }
266    if (scalar(@drivers)) {
267    # Ensure the Perl can load the drivers from all the typical places
268    &_addPathsToINC();
269    foreach my $driver_name (@drivers) {
270        my $t1 = [gettimeofday()];
271        print "=== Testing: " . $driver_name . " ===\n";
272        my $driver = _loadDBDriver($driver_name);
273        my $db_path = $driver->get_infodb_file_path('test-doc','/tmp/');
274        print " - Path: " . $db_path . "\n";
275        # 1. Open handle
276        my $db_handle = $driver->open_infodb_write_handle($db_path);
277        &_printTest('opening handle', (defined $db_handle));
278        # 2a. Write entry
279        $driver->write_infodb_entry($db_handle, 'Alpha', $data1);
280        &_printTest('writing entry', 1);
281        # 2b. Write raw entry
282        my $raw_data = $driver->convert_infodb_hash_to_string($data1);
283        $driver->write_infodb_rawentry($db_handle, 'Beta', $raw_data);
284        &_printTest('writing raw entry', 1);
285        # 3. Close handle
286        $driver->close_infodb_write_handle($db_handle);
287        if ($driver->supportsPersistentConnection()) {
288        $test_count += 1;
289        $skip_count += 1;
290        print " - Skipping test as persistent drivers delay 'close'.\n";
291        }
292        else {
293        &_printTest('closing handle', (tell($db_handle) < 1));
294        }
295        if (!$driver->writeOnly()) {
296        # 4a. Read entry
297        my $data3 = $driver->read_infodb_entry($db_path, 'Alpha');
298        &_printTest('read entry', &_compareHash($data1, $data3));
299        # 4b. Read raw entry
300        my $raw_data4 = $driver->read_infodb_rawentry($db_path, 'Beta');
301        my $data4 = $driver->convert_infodb_string_to_hash($raw_data4);
302        &_printTest('read raw entry', &_compareHash($data1, $data4));
303        # 5. Read keys
304        my $keys1 = {};
305        $driver->read_infodb_keys($db_path, $keys1);
306        &_printTest('read keys', (defined $keys1->{'Alpha'} && defined $keys1->{'Beta'}));
307        # 6. Set entry
308        if ($driver->supportsSet()) {
309            my $status = $driver->set_infodb_entry($db_path, 'Alpha', $data2);
310            &_printTest('set entry (1)', ($status >= 0));
311            my $data5 = $driver->read_infodb_entry($db_path, 'Alpha');
312            &_printTest('set entry (2)', &_compareHash($data2, $data5));
313        }
314        else {
315            $test_count += 2;
316            $skip_count += 2;
317            print " - Skipping 2 tests as 'set' is not supported by this driver.\n";
318        }
319        # 7. Delete entry
320        my $db_handle2 = $driver->open_infodb_write_handle($db_path, 'append');
321        $driver->delete_infodb_entry($db_handle2, 'Alpha');
322        $driver->close_infodb_write_handle($db_handle2);
323        my $keys2 = {};
324        $driver->read_infodb_keys($db_path, $keys2);
325        &_printTest('delete entry', ((!defined $keys2->{'Alpha'}) && (defined $keys2->{'Beta'})));
326        }
327        else
328        {
329        $test_count += 6;
330        $skip_count += 6;
331        print " - Skipping 6 tests as driver is write-only.\n";
332        }
333        # 8. Remove test db
334        unlink($db_path);
335        my $t2 = [gettimeofday()];
336        my $elapsed1 = tv_interval($t1, $t2);
337        print " - Testing took " . $elapsed1 . " seconds\n";
338    }
339    print "===== Results =====\n";
340    print "Drivers Tested: " . scalar(@drivers) . "\n";
341    print "Tests Run:      " . $test_count . "\n";
342    print "Tests Passed:   " . $pass_count . "\n";
343    print "Tests Failed:   " . ($test_count - $pass_count - $skip_count) . "\n";
344    print "Tests Skipped:  " . $skip_count . "\n";
345    }
346    else
347    {
348    print "Warning! No drivers specified - expected as arguments to call\n";
349    }
350    my $t3 = [gettimeofday()];
351    my $elapsed2 = tv_interval($t0, $t3);
352    print "===== Complete in " . $elapsed2 . " seconds =====\n";
353    print "\n";
354    exit(0);
355}
356## main(void) => void
357
358
359## @function close_infodb_write_handle(string, *) => void
360#
361sub close_infodb_write_handle
362{
363  my $infodb_type = shift(@_);
364  my $driver = _loadDBDriver($infodb_type);
365  $driver->close_infodb_write_handle(@_);
366}
367## close_infodb_write_handle(string, *) => void ##
368
369
370## @function delete_infodb_entry(string, *) => void
371#
372sub delete_infodb_entry
373{
374    my $infodb_type = shift(@_);
375    my $driver = _loadDBDriver($infodb_type);
376    $driver->delete_infodb_entry(@_);
377}
378## delete_infodb_entry(string, *) => void ##
379
380
381## @function mergeDatabases(string, *) => integer
382#
383sub mergeDatabases
384{
385    my $infodb_type = shift(@_);
386    my $driver = _loadDBDriver($infodb_type);
387    my $status = $driver->mergeDatabases(@_);
388    return $status;
389}
390## mergeDatabases(string, *) => integer ##
391
392
393## @function get_default_infodb_type(void) => string
394#
395sub get_default_infodb_type
396{
397  # The default is GDBM so everything works the same for existing collections
398  # To use something else, specify the "infodbtype" in the collection's collect.cfg file
399  return 'gdbm';
400}
401## get_default_infodb_type(void) => string ##
402
403
404## @function get_infodb_file_path(string, *) => string
405#
406sub get_infodb_file_path
407{
408    my $infodb_type = shift(@_);
409    my $driver = _loadDBDriver($infodb_type);
410    my $infodb_file_path = $driver->get_infodb_file_path(@_);
411    return $infodb_file_path;
412}
413## get_infodb_file_path(string, *) => string ##
414
415
416## @function open_infodb_write_handle(string, *) => filehandle
417#
418sub open_infodb_write_handle
419{
420    my $infodb_type = shift(@_);
421    my $driver = _loadDBDriver($infodb_type);
422    my $infodb_handle = $driver->open_infodb_write_handle(@_);
423    return $infodb_handle;
424}
425## open_infodb_write_handle(string, *) => filehandle ##
426
427
428## @function read_infodb_file(string, *) => void
429#
430sub read_infodb_file
431{
432    my $infodb_type = shift(@_);
433    my $driver = _loadDBDriver($infodb_type);
434    $driver->read_infodb_file(@_);
435}
436## read_infodb_file(string, *) => void ##
437
438
439## @function read_infodb_keys(string, *) => void
440#
441sub read_infodb_keys
442{
443    my $infodb_type = shift(@_);
444    my $driver = _loadDBDriver($infodb_type);
445    $driver->read_infodb_keys(@_);
446}
447## read_infodb_keys(string, *) => void ##
448
449
450## @function read_infodb_entry(string, *) => hashmap
451#
452sub read_infodb_entry
453{
454    my $infodb_type = shift(@_);
455    my $driver = _loadDBDriver($infodb_type);
456    my $infodb_entry = $driver->read_infodb_entry(@_);
457    return $infodb_entry;
458}
459## read_infodb_entry(string, *) => hashmap ##
460
461
462## @function read_infodb_rawentry(string, *) => string
463#
464sub read_infodb_rawentry
465{
466    my $infodb_type = shift(@_);
467    my $driver = _loadDBDriver($infodb_type);
468    my $raw_infodb_entry = $driver->read_infodb_rawentry(@_);
469    return $raw_infodb_entry;
470}
471## read_infodb_rawentry(string, *) => string ##
472
473
474## @function set_infodb_entry(string, *) => integer
475#
476sub set_infodb_entry
477{
478    my $infodb_type = shift(@_);
479    my $driver = _loadDBDriver($infodb_type);
480    my $status = $driver->set_infodb_entry(@_);
481    return $status;
482}
483## set_infodb_entry(string, *) => integer ##
484
485
486## @function supportDatestamp(string) => boolean
487#
488sub supportsDatestamp
489{
490    my $infodb_type = shift(@_);
491    my $driver = _loadDBDriver($infodb_type);
492    my $supports_datestamp = $driver->supportsDatestamp();
493    return $supports_datestamp;
494}
495## supportsDatestamp(string) => boolean ##
496
497
498## @function supportMerge(string) => boolean
499#
500sub supportsMerge
501{
502    my $infodb_type = shift(@_);
503    my $driver = _loadDBDriver($infodb_type);
504    my $supports_merge = $driver->supportsMerge();
505    return $supports_merge;
506}
507## supportsMerge(string) => boolean ##
508
509
510## @function supportRSS(string) => boolean
511#
512sub supportsRSS
513{
514    my $infodb_type = shift(@_);
515    my $driver = _loadDBDriver($infodb_type);
516    my $supports_rss = $driver->supportsRSS();
517    return $supports_rss;
518}
519## supportsRSS(string) => boolean ##
520
521
522## @function write_infodb_entry(string, *) => void
523#
524sub write_infodb_entry
525{
526    my $infodb_type = shift(@_);
527    my $driver = _loadDBDriver($infodb_type);
528    $driver->write_infodb_entry(@_);
529}
530## write_infodb_entry(string, *) => void ##
531
532
533## @function write_infodb_rawentry(string, *) => void
534#
535sub write_infodb_rawentry
536{
537    my $infodb_type = shift(@_);
538    my $driver = _loadDBDriver($infodb_type);
539    $driver->write_infodb_rawentry(@_);
540}
541## write_infodb_rawentry(string, *) => void ##
542
5431;
Note: See TracBrowser for help on using the browser.