source: gs2-extensions/tdb/trunk/perllib/DBDrivers/TDB.pm@ 30371

###############################################################################
#
# DBDrivers/TDB.pm -- utility functions for writing to tdb databases. Should be
#                     hauntingly similar to GDBM utility functions.
#
# A component of the Greenstone digital library software from the New Zealand
# Digital Library Project at the University of Waikato, New Zealand.
#
# Copyright (C) 2011-2015 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
# FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
# more details.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 675 Mass
# Ave, Cambridge, MA 02139, USA.
#
###############################################################################

package DBDrivers::TDB;

# Pragma
use strict;

# Libraries
use Cwd;
use Devel::Peek;
use ghtml;
use Scalar::Util 'refaddr';
use util;
# - OO inheritence
use parent 'DBDrivers::GDBM';

sub BEGIN
{
    if (!defined $ENV{'GSDLHOME'} || !defined $ENV{'GSDLOS'}) {
        die("Error! Environment not prepared. Have you sourced setup.bash?\n");
    }
    if (!defined $ENV{'GEXTTDBEDIT_INSTALLED'}) {
        die("Error! Path to TDB binaries not found. Have you sourced setup.bash?\n");
    }
}

sub new
{
    my $class = shift(@_);

    my $self = DBDrivers::GDBM->new(@_);

    # Default TDB file extension
    $self->{'default_file_extension'} = 'tdb';
    # Should the TDB used a specific affinity?
    $self->{'forced_affinity'} = -1; # zero upwards indicates the affinity
    # Ask TDB executables to display debugging information?
    $self->{'tdb_debug'} = 1; # 1 to enable

    # note: file separator agnostic
    $self->{'executable_path'} = $ENV{GEXTTDBEDIT_INSTALLED} . '/bin/';
    $self->{'read_executable'} = 'tdb2txt';
    $self->{'keyread_executable'} = 'tdbkeys';
    $self->{'write_executable'} = 'txt2tdb';

    # Optional Support
    $self->{'supports_persistentconnection'} = 1;
    $self->{'supports_set'} = 1;

    bless($self, $class);
    return $self;
}


## @function DESTROY
#
# Built-in destructor block that, unlike END, gets passed a reference to self.
# Responsible for properly closing any open database handles.
#
sub DESTROY
{
    my $self = shift(@_);
    # Close all remaining filehandles
    foreach my $infodb_file_path (keys(%{$self->{'handle_pool'}})) {
    my $infodb_handle = $self->{'handle_pool'}->{$infodb_file_path};
    # By passing the filepath as the second argument we instruct the driver
    # that we actually want to close the connection by passing a non-zero
    # value, but we sneakily optimize things a little as the close method
    # can now check to see if it's been provided a file_path rather than
    # having to search the handle pool for it. The file_path is needed to
    # remove the closed handle from the pool anyway.
    $self->close_infodb_write_handle($infodb_handle, $infodb_file_path);
    }
}
## DESTROY(void) => void ##


# -----------------------------------------------------------------------------
#   TDB IMPLEMENTATION
# -----------------------------------------------------------------------------

# Handled by BaseDBDriver
# sub debugPrint(string) => void
# sub debugPrintFunctionHeader(*) => void
# sub get_infodb_file_path(string, string) => string

# Handled by 70HyphenFormat
# sub read_infodb_entry(string, string) => hashmap
# sub read_infodb_file(string, hashmap) => void
# sub read_infodb_keys(string, hashmap) => void
# sub read_infodb_rawentry(string, string) => string
# sub set_infodb_entry(string, string, hashmap) => integer
# sub write_infodb_entry(filehandle, string, hashmap) => void
# sub write_infodb_rawentry(filehandle, string, string) => void


## @function close_infodb_write_handle(filehandle)
#
#  Some slight-of-hand here due to the way Perl passes variables to methods.
#  Most of the time (i.e. under all the existing calls in the Greenstone code)
#  this does nothing, as TDB handles can be left open and reused by multiple
#  writers/readers (the exception being complete file reads, but they are
#  handled in their own function anyway).
#
#  However TDB's version of this function will look for an extra variable and,
#  if true (non-zero), will actually close the handle. Several methods below
#  call close but also pass the infodb_file_path as the second argument, which
#  is enough to have the connections properly closed.
#
#  Note that when this class passes from scope all open handles will be
#  properly closed by the DESTROY block.
#
sub close_infodb_write_handle {
    my $self = shift(@_);
    $self->debugPrintFunctionHeader(@_);
    my $infodb_handle = shift(@_);
    my $actually_close = shift(@_); # Undefined most of the time
    if (defined($actually_close)) {
    # We'll need the file path so we can locate and remove the entry in the
    # handle pool
    my $infodb_file_path = undef;
    # Sometimes we can cheat, as the actually_close variable will have the
    # file_path in it thanks to the DESTROY block above. Doing a regex on
    # actually_close will treat it like a string no matter what it was, and
    # we can search for the appropriate file extension that should be there
    # for valid paths.
    my $pattern = '\.' . $self->{'default_file_extension'} . '(\s\[APPEND\])?$';
    if ($actually_close =~ /$pattern/) {
        $infodb_file_path = $actually_close;
    }
    # If we can't cheat then we are stuck finding which connection in the
    # handle_pool we are about to close. Need to compare objects using
    # refaddr()
    else {
        foreach my $possible_file_path (values(%{$self->{'handle_pool'}})) {
        my $possible_handle = $self->{'handle_pool'}->{$possible_file_path};
        if (ref($infodb_handle) && ref($possible_handle) && refaddr($infodb_handle) == refaddr($possible_handle)) {
            $infodb_file_path = $possible_file_path;
            last;
        }
        }
    }
    if (defined($infodb_file_path)) {
            $self->debugPrint('Closing connection: ' . $infodb_file_path);
        delete($self->{'handle_pool'}->{$infodb_file_path});
    }
    else {
        print STDERR "Warning! About to close TDB database handle, but couldn't locate in open handle pool.\n";
    }
    # Call GDBM's close to do the heavy-lifting
    $self->SUPER::close_infodb_write_handle($infodb_handle);
    }
    else {
    $self->debugPrint('Connection persists for later use.');
    }
}
## close_infodb_write_handle(filehandle) => void ##

# sub delete_infodb_entry {}


## @function open_infodb_write_handle(string, string)
#
sub open_infodb_write_handle
{
    my $self = shift(@_);
    if ($self->{'tdb_debug'}) {
        push(@_, '-debug');
    }
    my $handle = $self->SUPER::open_infodb_write_handle(@_);
    return $handle;
}
## open_infodb_write_handle(string, string) => filehandle ##

1;