Index: /gs2-extensions/parallel-building/trunk/src/perllib/dbutil/gdbmserver.pm
===================================================================
--- /gs2-extensions/parallel-building/trunk/src/perllib/dbutil/gdbmserver.pm	(revision 24674)
+++ /gs2-extensions/parallel-building/trunk/src/perllib/dbutil/gdbmserver.pm	(revision 24674)
@@ -0,0 +1,315 @@
+###########################################################################
+#
+# 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;
+
+my %server_lockfile_paths;
+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
+    $server_lockfile_paths{$server_lockfile_path} = $infodb_file_path;
+  }
+  flock(TMPFH, LOCK_UN);
+  close($tmp_lockfile_path);
+  unlink($tmp_lockfile_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 (%server_lockfile_paths))
+  {
+    my $infodb_file_path = $server_lockfile_paths{$server_lockfile_path};
+    my $gdbm_client_handle = GDBMClient->new($server_lockfile_path);
+    print "* Stopping GDBMServer for: " . $infodb_file_path . "\n";
+    $gdbm_client_handle->query('!stop:' . $$);
+  }
+  # we should now wait until all of the 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 (%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');
+  # 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(@_);
+  # we deregister as a listener
+  $gdbm_client_handle->removeListener('w');
+}
+# /** 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 $infodb_file_extension = ".gdb";
+  my $infodb_file_name = &util::get_dirsep_tail($collection_name) . $infodb_file_extension;
+  return &util::filename_cat($infodb_directory_path, $infodb_file_name);
+}
+
+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');
+  # 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;
+    }
+  }
+  # remove our listener
+  $gdbm_client_handle->removeListener('r');
+}
+
+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');
+  # 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;
+    }
+  }
+  # remove our listener
+  $gdbm_client_handle->removeListener('k');
+}
+
+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');
+  # 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);
+  # remove our listener
+  $gdbm_client_handle->removeListener('s');
+}
+
+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;
