source: gs2-extensions/parallel-building/trunk/src/perllib/dbutil/gdbmserver.pm@ 24681

###########################################################################
#
# dbutil::gdbmserver -- utility functions for writing to gdbm databases but
#                       implemented as a server with a single, persistent
#                       connection
#
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the
# University of Waikato, New Zealand.
#
# Copyright (C) 2009
#
# 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 dbutil::gdbmserver;

use strict;
use warnings;

# We're going to have to delve into locking (a little) to prevent multiple
# threads trying to launch the server at once
use Fcntl qw(:flock);

use GDBMClient;
use util;

my $hyphen70 = '-' x 70;
my $debug = 0;

# We have a global reference to all of the GDBM Server lockfiles that this
# instance has created (as we'll be responsible for closing them)
my %created_server_lockfile_paths;
# Keep track of the lockfiles for server we have added ourselves as listeners
# to.
my %listener_server_lockfile_paths;
# We also have a global of all of the listeners we have assigned as we'll
# be responsible for removing them.
my %registered_listeners;

sub _spawnClient
{
  my ($infodb_file_path) = @_;
  # 1. Check whether the server is already running by trying to locate the
  #    server 'lock' file.
  my ($infodb_file, $extension) = $infodb_file_path =~ /([^\\\/]+)\.(db|gdb)/i;
  my $server_lockfile_path =  &util::filename_cat($ENV{'GSDLHOME'},'tmp','gdbmserver-' . $infodb_file . '.lock');
  #rint " * Searching for lockfile: " . $server_lockfile_path . "\n";
  # We need to lock here to ensure only one thread enters the following code,
  # sees a missing GDBMServer, and launches it
  my $tmp_lockfile_path = &util::filename_cat($ENV{'GSDLHOME'},'tmp','dbutil-gdbmserver.lock');
  open(TMPFH, '>', $tmp_lockfile_path) or die ("Error! Failed to open file for writing: " . $tmp_lockfile_path . "\nReason: " . $! . "\n");
  flock(TMPFH, LOCK_EX) or die("Error! Cannot lock file exclusively: " . $tmp_lockfile_path . "\nReason: " . $! . "\n");
  print TMPFH localtime();
  # - If the file doesn't exist...
  if (!-e $server_lockfile_path)
  {
    # ...start it!
    my $launch_cmd = 'GDBMServer.pl "' . $$ . '" "' . $infodb_file_path . '"';
    print "* Starting GDBMServer for: " . $infodb_file_path . "\n";
    # @note I once had the below pipe ending with 2>&1 |, but that then blocks
    #       indefinitely when looping and reading <SERVERIN>.
    open(SERVERIN, $launch_cmd . ' |') or die("Error! Failed to run launch command: " . $launch_cmd . "\nReason: " . $! . "\n");
    # read all the output from the server
    my $line = '';
    my $server_lock_file_created = 0;
    while ($line = <SERVERIN>)
    {
      # - watch for the line indicating a lock file has been created and
      #   populated with a sexy port number
      if ($line =~ /Server now listening/)
      {
        $server_lock_file_created = 1;
      }
      # - we could also watch for errors here
      if ($debug)
      {
        if ($line !~ /\n/)
        {
          $line .= "\n";
        }
        $|++; # autoflush
        print "[gdbmserver] $line";
        $|--; # disable autoflush
      }
    }
    close(SERVERIN);
    if (!$server_lock_file_created)
    {
      die("Error! GDBMServer failed to create lock file. Check server logs.");
    }
    # record this for later
    $created_server_lockfile_paths{$server_lockfile_path} = 1;
  }
  flock(TMPFH, LOCK_UN);
  close($tmp_lockfile_path);
  unlink($tmp_lockfile_path);
  # record this for later
  $listener_server_lockfile_paths{$server_lockfile_path} = $infodb_file_path;
  return GDBMClient->new($server_lockfile_path);
}

END
{
  # we ask the server to shutdown, but only the 'creator' thread will actually
  # be able to, and only once all listeners have deregistered.
  foreach my $server_lockfile_path (keys (%listener_server_lockfile_paths))
  {
    my $infodb_file_path = $listener_server_lockfile_paths{$server_lockfile_path};
    my $gdbm_client_handle = GDBMClient->new($server_lockfile_path);
    # Deregister all of our registered listeners
    foreach my $listener_suffix (keys(%registered_listeners))
    {
      $gdbm_client_handle->removeListener($listener_suffix);
    }
    # ask the servers we created to shut down (all other threads will have
    # this request ignored)
    if (defined $created_server_lockfile_paths{$infodb_file_path})
    {
      print "* Attempting to stop GDBMServer for: " . $infodb_file_path . "\n";
    }
    $gdbm_client_handle->query('!stop:' . $$);
  }
  # we should now wait until all of our server_lockfiles have actually been
  # removed (otherwise people could mistakenly run import/build again
  # immediately and things *might* go pearshaped).
  foreach my $server_lockfile_path (keys (%created_server_lockfile_paths))
  {
    # While the file exists, we should wait
    print "* Waiting for GDBMServer [" . $server_lockfile_path . "] to exit...";
    if (-e $server_lockfile_path)
    {
      while (-e $server_lockfile_path)
      {
        print ".";
        sleep(1);
      }
    }
    print " Done!\n";
  }
}

# -----------------------------------------------------------------------------
#   GDBM SERVER IMPLEMENTATION
# -----------------------------------------------------------------------------
sub open_infodb_write_handle
{
  my $infodb_file_path = shift(@_);
  my $opt_append = shift(@_);
  if (defined $opt_append && $opt_append ne "append")
  {
    print "Warning! GDBM modes other than 'append' not supported for GDBMServer.\n";
  }
  my $gdbm_client_handle = &_spawnClient($infodb_file_path);
  # Register this client on the server if necessary
  $gdbm_client_handle->addListener('w');
  $registered_listeners{'w'} = 1;
  # and pass the handle to client around
  return $gdbm_client_handle;
}

# /** Destructor or near enough.
#  /*
sub close_infodb_write_handle
{
  my $gdbm_client_handle = shift(@_);
}
# /** close_infodb_write_handle($infodb_handle) **/

# /** @function get_info_db_file_path
#  *  Exactly the same as vanilla GDBM - as we are still using a GDBM database
#  *  just accessing it via a persistant server
#  */
sub get_infodb_file_path
{
  my $collection_name = shift(@_);
  my $infodb_directory_path = shift(@_);
  my $create_server = shift(@_);

  my $infodb_file_extension = ".gdb";
  my $infodb_file_name = &util::get_dirsep_tail($collection_name) . $infodb_file_extension;
  my $infodb_file_path = &util::filename_cat($infodb_directory_path, $infodb_file_name);

  # Special Case for GDBMServer
  if (defined $create_server && $create_server == 1)
  {
    my $gdbm_client_handle = &_spawnClient($infodb_file_path);
    # Register this client on the server if necessary
    $gdbm_client_handle->addListener('i');
    $registered_listeners{'i'} = 1;
  }

  # Resuming our regular programming
  return $infodb_file_path;
}

sub read_infodb_file
{
  my $infodb_file_path = shift(@_);
  my $infodb_map = shift(@_);
  my $gdbm_client_handle = &_spawnClient($infodb_file_path);
  $gdbm_client_handle->addListener('r');
  $registered_listeners{'r'} = 1;
  # retrieves all the keys in the form:
  # [key1]\n[key2]\n[key3]\n...[keyn]
  my $raw_infodb_keys = $gdbm_client_handle->query('[*]?');

  my @infodb_keys = split(/\r?\n/, $raw_infodb_keys);
  foreach my $infodb_key (@infodb_keys)
  {
    if ($infodb_key =~ /.+/ && $infodb_key !~ /-{70}/)
    {
      # lookup each key
      my $infodb_value = $gdbm_client_handle->query('[' . $infodb_key . ']?');
      # store it
      $infodb_map->{$infodb_key} = $infodb_value;
    }
  }
}

sub read_infodb_keys
{
  my $infodb_file_path = shift(@_);
  my $infodb_map = shift(@_);
  # spawn client (creating server as necessary)
  my $gdbm_client_handle = &_spawnClient($infodb_file_path);
  # register ourself as listener
  $gdbm_client_handle->addListener('k');
  $registered_listeners{'k'} = 1;
  # retrieves all the keys in the form:
  # [key1]\n[key2]\n[key3]\n...[keyn]
  my $raw_infodb_keys = $gdbm_client_handle->query('[*]?');
  my @infodb_keys = split(/\r?\n/, $raw_infodb_keys);
  foreach my $infodb_key (@infodb_keys)
  {
    if ($infodb_key =~ /.+/ && $infodb_key !~ /-{70}/)
    {
      $infodb_map->{$infodb_key} = 1;
    }
  }
}

sub write_infodb_entry
{
  my $gdbm_client_handle = shift(@_);
  my $infodb_key = shift(@_);
  my $infodb_map = shift(@_);
  # - build up the gdbm command
  my $gdbm_command = "[" . $infodb_key . "]+\n";
  foreach my $infodb_value_key (keys(%$infodb_map))
  {
    foreach my $infodb_value (@{$infodb_map->{$infodb_value_key}})
    {
      if ($infodb_value =~ /-{70,}/)
      {
        # if value contains 70 or more hyphens in a row we need to escape them
        # to prevent txt2db from treating them as a separator
        $infodb_value =~ s/-/&\#045;/gi;
      }
      $gdbm_command .= "<" . $infodb_value_key . ">" . $infodb_value . "\n";
    }
  }
  $gdbm_command .= $hyphen70 . "\n";
  # - ask the client to transmit the command to the server
  $gdbm_client_handle->query($gdbm_command);
}

sub write_infodb_rawentry
{
  my $gdbm_client_handle = shift(@_);
  my $infodb_key = shift(@_);
  my $infodb_val = shift(@_);
  # - build up the gdbm command
  my $gdbm_command = "[" . $infodb_key . "]\n";
  $gdbm_command .= $infodb_val . "\n";
  $gdbm_command .= $hyphen70 . "\n";
  # - ask the client to transmit the command to the server
  $gdbm_client_handle->query($gdbm_command);
  return 1;
}

sub set_infodb_entry
{
  my $infodb_file_path = shift(@_);
  my $infodb_key = shift(@_);
  my $infodb_map = shift(@_);
  # spawn client (creating server as necessary)
  my $gdbm_client_handle = &_spawnClient($infodb_file_path);
  $gdbm_client_handle->addListener('s');
  $registered_listeners{'s'} = 1;
  # Protect metadata values that go inside quotes for gdbmset
  foreach my $k (keys %$infodb_map)
  {
    my @escaped_v = ();
    foreach my $v (@{$infodb_map->{$k}})
    {
      if ($k eq "contains")
      {
        # protect quotes in ".2;".3 etc
        $v =~ s/\"/\\\"/g;
        push(@escaped_v, $v);
      }
      else
      {
        my $ev = &ghtml::unescape_html($v);
        $ev =~ s/\"/\\\"/g;
        push(@escaped_v, $ev);
      }
    }
    $infodb_map->{$k} = \@escaped_v;
  }
  # Generate the record string (GDBM command)
  my $gdbm_command = "[" . $infodb_key . "]\n";
  $gdbm_command .= &dbutil::convert_infodb_hash_to_string($infodb_map) . "\n";
  $gdbm_command .= $hyphen70 . "\n";
  # Send command to server
  $gdbm_client_handle->query($gdbm_command);
}

sub delete_infodb_entry
{
  my $gdbm_client_handle = shift(@_);
  my $infodb_key = shift(@_);
  # - create command
  my $gdbm_command = "[" . $infodb_key . "]-\n";
  # - and send
  $gdbm_client_handle->query($gdbm_command);
}



1;