source: gsdl/trunk/perllib/GDBMUtils.pm@ 20610

package GDBMUtils;

use strict;
use util;

my $debug = 0;

# /** Global variables to hold a strings containing:
#  *    the last collection, oid and value
#  *  a gdbmCachedCollectionGet() was performed on.
#  */
my $gdbmget_previous_collection = "";
my $gdbmget_previous_oid = "";
my $gdbmget_previous_value = "";



sub gdbmDatabaseGet
{
    my ($database, $oid) = @_;

    # Are we in windows? Do we need .exe?
    my $exe = &util::get_os_exe();

    # Retrieve the raw document content
    print STDERR "#Get document\ncmd: gdbmget$exe \"$database\" \"$oid\"\n" if $debug;
    my $value = `gdbmget$exe "$database" "$oid"`;

    # Done
    return $value;
}

sub parseStringToHash
{
    my ($val) = @_;

    my $rec = {};

    while ($val =~ m/^<(.*?)>(.*)$/mg) {
    my $metaname = $1;
    my $metavalue = $2;

    if (!defined $rec->{$metaname}) {
        $rec->{$metaname} = [ $metavalue ];
    }
    else {
        push(@{$rec->{$metaname}},$metavalue);
    }
    }

    return $rec;
}

sub gdbmRecordToHash
{
    my ($database, $oid) = @_;

    my $val = gdbmDatabaseGet($database,$oid);

    return parseStringToHash($val);
}

sub serializeHash
{
    my ($hash) = @_;

    my $shash = "";
    
    foreach my $metaname (keys %$hash) {
    my $metavals = $hash->{$metaname};
    foreach my $metaval (@$metavals) {
        # need to escape chars HTML entities ??
        $shash .= "<$metaname>$metaval\n";
    }
    }

    return $shash;
}


sub gdbmDatabaseAppend
{
    my ($database, $oid, $value) = @_;

    # Are we in windows? Do we need .exe?
    my $exe = &util::get_os_exe();

    # Escape any speech marks in the value
    $value =~ s/\"/\\\"/g;
    # Set the document content
    print STDERR "#Set document\ncmd: gdbmset$exe \"$database\" \"$oid\" \"$value\" append\n" if $debug;
    `gdbmset$exe "$database" "$oid" "$value" append`;
}


sub gdbmDatabaseSet
  {
    my ($database, $oid, $value) = @_;

    # Are we in windows? Do we need .exe?
    my $exe = &util::get_os_exe();

    # Escape any speech marks in the value
    $value =~ s/\"/\\\"/g;
    # Set the document content
    print STDERR "#Set document\ncmd: gdbmset$exe \"$database\" \"$oid\" \"$value\"\n" if $debug;
    `gdbmset$exe "$database" "$oid" "$value"`;
}


sub gdbmDatabaseRemove
  {
    my ($database, $oid) = @_;

    # Are we in windows? Do we need .exe?
    my $exe = &util::get_os_exe();

    # Remove the document from the database

    my $cmd = "gdbmdel$exe \"$database\" \"$oid\"";
    print STDERR "#Delete document\ncmd: $cmd" if $debug;

    `$cmd`;

}



# /** This wraps John T's gdbmget executable to get the gdbm database entry for
#  *  a particular OID.
#  *
#  *  @param $collection is the collection name.
#  *  @param $oid is the internal document id.
#  *
#  *
#  *  @author John Rowe, DL Consulting Ltd.
#  *  @author John Thompson, DL Consulting Ltd.
#  */
sub gdbmCachedCollectionGet
  {
    my ($collection, $oid) = @_;
    # Start by checking if this request is the same as the previous one, and if
    # so return the cache version instead. This is an optimization to improve
    # performance when checking if a certain GDBM document exists before 
    # creating a new node object
    if($collection eq $gdbmget_previous_collection 
       && $oid eq $gdbmget_previous_oid)
      {
        print STDERR "#Get document - using cached value\n" if $debug;
        return $gdbmget_previous_value;
      }

    # Where's the database?
    my $database = _getDatabasePath($collection);

    my $value = gdbmDatabaseGet($database,$oid);

    # Tidy up the ever growing number of newlines at the end of the value
    $value =~ s/(\r?\n)+/$1/g;
    # Why do we need the above line?  At the very least it would seem
    # better that the data going in to the database through 'set' is
    # monitored for superfluous \r\n which are then removed before being
    # saved in GDBM

    # Cache this result
    $gdbmget_previous_collection = $collection;
    $gdbmget_previous_oid = $oid;
    $gdbmget_previous_value = $value;

    # Done
    return $value;
  }
# /** gdbmCachedCollectionGet **/

# /** This wraps John T's gdbmset executable to set the gdbm database entry for
#  *  a particular OID. This does not yet report errors.
#  *
#  *  @param $collection is the collection name.
#  *  @param $oid is the internal document id.
#  *  @param $value is the new value to set for the oid.
#  *
#  *  @author John Rowe, DL Consulting Ltd.
#  */
sub gdbmCachedCollectionSet
  {
    my ($collection, $oid, $value) = @_;

    # Where's the database?
    my $database = _getDatabasePath($collection);


    # Check whether value is set
    if (defined($value))
      {
      gdbmDatabaseSet($database,$oid,$value);
      }
    else
      {
      gdbmDatabaseRemove($database,$oid);
      }

    # Empty any cached values, as they may now be invalid

    # Cache this result
    $gdbmget_previous_collection = "";
    $gdbmget_previous_oid = "";
    $gdbmget_previous_value = 0;
  }
# /** gdbmCollectionSet **/

# /** This works out the database path and returns it to the calling
#  *  calling function.
#  *
#  *  @param $collection The current collection name
#  *
#  *  @author John Rowe, DL Consulting Ltd.
#  */

sub _getDatabasePath
  {
    my $collection = shift(@_);

    # Return the full filename of the database

    return &util::filename_cat($ENV{'GSDLHOME'}, "collect", $collection, "index", "text", "$collection.gdb");
  }
# /** getDatabasePath **/

1;