source: gs2-extensions/tdb-edit/trunk/src/perllib/dbutil/tdbserver.pm@ 28774

Last change on this file since 28774 was 28774, checked in by jmt12, 8 years ago

Meh - forgot to add utime functions to module definition

File size: 13.1 KB
Line 
1###########################################################################
2#
3# dbutil::tdbserver -- utility functions for writing to tdb databases but
4# implemented as a server with a single, persistent
5# connection
6#
7# A component of the Greenstone digital library software
8# from the New Zealand Digital Library Project at the
9# University of Waikato, New Zealand.
10#
11# Copyright (C) 2012
12#
13# This program is free software; you can redistribute it and/or modify
14# it under the terms of the GNU General Public License as published by
15# the Free Software Foundation; either version 2 of the License, or
16# (at your option) any later version.
17#
18# This program is distributed in the hope that it will be useful,
19# but WITHOUT ANY WARRANTY; without even the implied warranty of
20# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21# GNU General Public License for more details.
22#
23# You should have received a copy of the GNU General Public License
24# along with this program; if not, write to the Free Software
25# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
26#
27###########################################################################
28
29package dbutil::tdbserver;
30
31# Pragma
32use strict;
33use warnings;
34
35# Modules
36# - we're going to have to delve into locking (a little) to prevent
37# multiple threads trying to launch the server at once
38use Fcntl qw(:flock);
39# - we'll also need to wait around for an indeterminate amount of time for the
40# TDBServer to exit (detected by its lockfile disappearing)
41use Time::HiRes qw( gettimeofday tv_interval usleep );
42
43# Greenstone modules
44use TDBClient;
45use util;
46
47my $hyphen70 = '-' x 70;
48my $debug = 0;
49
50# We have a global reference to all of the TDB Server lockfiles that this
51# instance has created (as we'll be responsible for closing them)
52my %created_server_lockfile_paths;
53# Keep track of the lockfiles for server we have added ourselves as listeners
54# to.
55my %listener_server_lockfile_paths;
56# We also have a global of all of the listeners we have assigned as we'll
57# be responsible for removing them.
58my %registered_listeners;
59
60sub _spawnClient
61{
62 my ($infodb_file_path) = @_;
63 # 1. Check whether the server is already running by trying to locate the
64 # server 'lock' file.
65
66 my ($collection) = $infodb_file_path =~ /collect[\\\/]([^\\\/]+)/i;
67 my ($infodb_file, $extension) = $infodb_file_path =~ /([^\\\/]+)\.(t?db)/i;
68
69 my $tmp_dir = &util::filename_cat($ENV{'GSDLHOME'},'tmp');
70 if (!-d $tmp_dir)
71 {
72 mkdir($tmp_dir, 0755);
73 }
74
75 my $we_started_server = 0;
76 my $server_lockfile_path = &util::filename_cat($ENV{'GSDLHOME'},'collect',$collection,'tmp','tdbserver.lock');
77 print " * Searching for TDBServer lockfile...\n" if ($debug);
78 if (!-e $server_lockfile_path)
79 {
80 print "Not found.\n" if ($debug);
81 # We need to lock here to ensure only one thread enters the following code,
82 # sees a missing TDBServer, and launches it
83 my $tmp_lockfile_path = &util::filename_cat($ENV{'GSDLHOME'},'tmp','dbutil-tdbserver.lock');
84 open(TMPFH, '>', $tmp_lockfile_path) or die("Warning! Failed to open file for writing: " . $tmp_lockfile_path . "\nReason: " . $! . "\n");
85 flock(TMPFH, LOCK_EX) or die("Error! Cannot lock file exclusively: " . $tmp_lockfile_path . "\nReason: " . $! . "\n");
86 print TMPFH localtime();
87 # - If the file still doesn't exist...
88 if (!-e $server_lockfile_path)
89 {
90 $we_started_server = 1;
91 # ...start it!
92 my $launch_cmd = 'TDBServer.pl "' . $$ . '" "' . $collection . '"';
93 print "* Starting TDBServer for: " . $collection . " [" . $launch_cmd . "]...\n";
94 # @note I once had the below pipe ending with 2>&1 |, but that then blocks
95 # indefinitely when looping and reading <SERVERIN>.
96 open(SERVERIN, $launch_cmd . ' |') or die("Error! Failed to run launch command: " . $launch_cmd . "\nReason: " . $! . "\n");
97 # read all the output from the server
98 my $line = '';
99 my $server_lock_file_created = 0;
100 autoflush STDOUT 1;
101 print "* Waiting for TDBServer to start";
102 my $server_host = '';
103 my $server_port = '';
104 while ($line = <SERVERIN>)
105 {
106 print ".";
107 # - watch for the line indicating a lock file has been created and
108 # populated with a sexy port number
109 if ($line =~ /Server now listening on ([^:]+):(\d+)/)
110 {
111 $server_host = $1;
112 $server_port = $2;
113 $server_lock_file_created = 1;
114 }
115 # - we could also watch for errors here
116 if ($debug)
117 {
118 if ($line !~ /\n/)
119 {
120 $line .= "\n";
121 }
122 $|++; # autoflush
123 print "[tdbserver] $line";
124 $|--; # disable autoflush
125 }
126 }
127 close(SERVERIN);
128 print "\n";
129 if (!$server_lock_file_created)
130 {
131 die("Error! TDBServer failed to create lock file. Check server logs.");
132 }
133 elsif ($debug)
134 {
135 print "* Server now running on " . $server_host . ":" . $server_port . "\n";
136 }
137 # record this for later
138 $created_server_lockfile_paths{$server_lockfile_path} = 1;
139 }
140 flock(TMPFH, LOCK_UN);
141 close($tmp_lockfile_path);
142 unlink($tmp_lockfile_path);
143 }
144 else
145 {
146 print "Found!\n" if ($debug);
147 }
148 # record this for later
149 $listener_server_lockfile_paths{$server_lockfile_path} = $infodb_file_path;
150 return TDBClient->new($server_lockfile_path, $infodb_file, $we_started_server);
151}
152
153END
154{
155 # we ask the server to shutdown, but only the 'creator' thread will actually
156 # be able to, and only once all listeners have deregistered.
157 foreach my $server_lockfile_path (keys (%listener_server_lockfile_paths))
158 {
159 my $infodb_file_path = $listener_server_lockfile_paths{$server_lockfile_path};
160 my $tdb_client_handle = TDBClient->new($server_lockfile_path, '');
161 # Deregister all of our registered listeners
162 foreach my $listener_suffix (keys(%registered_listeners))
163 {
164 $tdb_client_handle->removeListener($listener_suffix);
165 }
166 # ask the servers we created to shut down (all other threads will have
167 # this request ignored)
168 if (defined $created_server_lockfile_paths{$infodb_file_path})
169 {
170 print "* Attempting to stop TDBServer for: " . $infodb_file_path . "\n";
171 }
172 $tdb_client_handle->stopServer();
173 }
174 # we should now wait until all of our server_lockfiles have actually been
175 # removed (otherwise people could mistakenly run import/build again
176 # immediately and things *might* go pearshaped). (Subsequent testing shows it
177 # won't - a new Greenstone build can't start until the previous lockfile is
178 # removed - but I think, for ATOMic sake, I may as well make waiting a part
179 # of the Greenstone import/build time.
180 my $wait_for_exit = 1;
181 foreach my $server_lockfile_path (keys (%created_server_lockfile_paths))
182 {
183 my $shutdown_start;
184 my $shutdown_end;
185 if ($wait_for_exit)
186 {
187 # While the file exists, we should wait
188 autoflush STDOUT 1;
189 my $blurb = '';
190 if ($debug)
191 {
192 $blurb = '[' . $server_lockfile_path . ']';
193 }
194 print '* Waiting for TDBServer to exit... ';
195 $shutdown_start = [&gettimeofday()];
196 if (-e $server_lockfile_path)
197 {
198 while (-e $server_lockfile_path)
199 {
200 usleep(10000);
201 }
202 }
203 $shutdown_end = [&gettimeofday()];
204 }
205 else
206 {
207 print '* NOT Waiting for TDBServer to exit... ';
208 }
209 if (defined $shutdown_start)
210 {
211 my $duration = tv_interval($shutdown_start, $shutdown_end);
212 print sprintf(" Done (in %0.6f seconds)!\n", $duration);
213 }
214 else
215 {
216 print " Done!\n";
217 }
218 }
219}
220
221# -----------------------------------------------------------------------------
222# TDB SERVER IMPLEMENTATION
223# -----------------------------------------------------------------------------
224sub open_infodb_write_handle
225{
226 my $infodb_file_path = shift(@_);
227 my $opt_append = shift(@_);
228 if (defined $opt_append && $opt_append ne "append")
229 {
230 print "Warning! Modes other than 'append' not supported for TDBServer.\n";
231 }
232 my $tdb_client_handle = &_spawnClient($infodb_file_path);
233 # Register this client on the server if necessary
234 $tdb_client_handle->addListener('w');
235 $registered_listeners{'w'} = 1;
236 # and pass the handle to client around
237 return $tdb_client_handle;
238}
239
240# /** Destructor or near enough.
241# /*
242sub close_infodb_write_handle
243{
244 my $tdb_client_handle = shift(@_);
245 # @todo Is there meant to be something here?
246}
247# /** close_infodb_write_handle($infodb_handle) **/
248
249# /** @function get_info_db_file_path
250# * Exactly the same as vanilla TDB - as we are still using a TDB database
251# * just accessing it via a persistant server
252# */
253sub get_infodb_file_path
254{
255 my $collection_name = shift(@_);
256 my $infodb_directory_path = shift(@_);
257 my $create_server = shift(@_);
258
259 my $infodb_file_extension = ".tdb";
260 my $infodb_file_name = &util::get_dirsep_tail($collection_name) . $infodb_file_extension;
261 my $infodb_file_path = &util::filename_cat($infodb_directory_path, $infodb_file_name);
262
263 # Special Case for TDBServer
264 if (defined $create_server && $create_server == 1)
265 {
266 my $tdb_client_handle = &_spawnClient($infodb_file_path);
267 # Register this client on the server if necessary
268 $tdb_client_handle->addListener('i');
269 $registered_listeners{'i'} = 1;
270 }
271
272 # Resuming our regular programming
273 return $infodb_file_path;
274}
275
276sub read_infodb_file
277{
278 my $infodb_file_path = shift(@_);
279 my $infodb_map = shift(@_);
280
281 my $tdb_client_handle = &_spawnClient($infodb_file_path);
282 $tdb_client_handle->addListener('r');
283 $registered_listeners{'r'} = 1;
284 # retrieves all the keys in the form:
285 # [key1]\n[key2]\n[key3]\n...[keyn]
286 my $raw_infodb_keys = $tdb_client_handle->query('[*]?');
287
288 my @infodb_keys = split(/\r?\n/, $raw_infodb_keys);
289 foreach my $infodb_key (@infodb_keys)
290 {
291 if ($infodb_key =~ /.+/ && $infodb_key !~ /-{70}/)
292 {
293 # lookup each key
294 my $infodb_value = $tdb_client_handle->query('[' . $infodb_key . ']?');
295 # store it
296 $infodb_map->{$infodb_key} = $infodb_value;
297 }
298 }
299}
300
301sub read_infodb_keys
302{
303 my $infodb_file_path = shift(@_);
304 my $infodb_map = shift(@_);
305
306 # spawn client (creating server as necessary)
307 my $tdb_client_handle = &_spawnClient($infodb_file_path);
308 # register ourself as listener
309 $tdb_client_handle->addListener('k');
310 $registered_listeners{'k'} = 1;
311 # retrieves all the keys in the form:
312 # [key1]\n[key2]\n[key3]\n...[keyn]
313 my $raw_infodb_keys = $tdb_client_handle->query('[*]?');
314 my @infodb_keys = split(/\r?\n/, $raw_infodb_keys);
315 foreach my $infodb_key (@infodb_keys)
316 {
317 if ($infodb_key =~ /.+/ && $infodb_key !~ /-{70}/)
318 {
319 $infodb_map->{$infodb_key} = 1;
320 }
321 }
322}
323
324sub write_infodb_entry
325{
326 my $tdb_client_handle = shift(@_);
327 my $infodb_key = shift(@_);
328 my $infodb_map = shift(@_);
329 # - build up the tdb command
330 my $tdb_command = "[" . $infodb_key . "]+\n";
331 foreach my $infodb_value_key (keys(%$infodb_map))
332 {
333 foreach my $infodb_value (@{$infodb_map->{$infodb_value_key}})
334 {
335 if ($infodb_value =~ /-{70,}/)
336 {
337 # if value contains 70 or more hyphens in a row we need to escape them
338 # to prevent txt2db from treating them as a separator
339 $infodb_value =~ s/-/&\#045;/gi;
340 }
341 $tdb_command .= "<" . $infodb_value_key . ">" . $infodb_value . "\n";
342 }
343 }
344 $tdb_command .= $hyphen70 . "\n";
345 # - ask the client to transmit the command to the server
346 $tdb_client_handle->query($tdb_command);
347}
348
349sub write_infodb_rawentry
350{
351 my $tdb_client_handle = shift(@_);
352 my $infodb_key = shift(@_);
353 my $infodb_val = shift(@_);
354 # - build up the tdb command
355 my $tdb_command = "[" . $infodb_key . "]\n";
356 $tdb_command .= $infodb_val . "\n";
357 $tdb_command .= $hyphen70 . "\n";
358 # - ask the client to transmit the command to the server
359 $tdb_client_handle->query($tdb_command);
360 return 1;
361}
362
363sub set_infodb_entry
364{
365 my $infodb_file_path = shift(@_);
366 my $infodb_key = shift(@_);
367 my $infodb_map = shift(@_);
368 # spawn client (creating server as necessary)
369 my $tdb_client_handle = &_spawnClient($infodb_file_path);
370 $tdb_client_handle->addListener('s');
371 $registered_listeners{'s'} = 1;
372 # Protect metadata values that go inside quotes for tdbset
373 foreach my $k (keys %$infodb_map)
374 {
375 my @escaped_v = ();
376 foreach my $v (@{$infodb_map->{$k}})
377 {
378 if ($k eq "contains")
379 {
380 # protect quotes in ".2;".3 etc
381 $v =~ s/\"/\\\"/g;
382 push(@escaped_v, $v);
383 }
384 else
385 {
386 my $ev = &ghtml::unescape_html($v);
387 $ev =~ s/\"/\\\"/g;
388 push(@escaped_v, $ev);
389 }
390 }
391 $infodb_map->{$k} = \@escaped_v;
392 }
393 # Generate the record string (TDB command)
394 my $tdb_command = "[" . $infodb_key . "]\n";
395 $tdb_command .= &dbutil::convert_infodb_hash_to_string($infodb_map) . "\n";
396 $tdb_command .= $hyphen70 . "\n";
397 # Send command to server
398 $tdb_client_handle->query($tdb_command);
399}
400
401sub delete_infodb_entry
402{
403 my $tdb_client_handle = shift(@_);
404 my $infodb_key = shift(@_);
405 # - create command
406 my $tdb_command = "[" . $infodb_key . "]-\n";
407 # - and send
408 $tdb_client_handle->query($tdb_command);
409}
410
411
412
4131;
Note: See TracBrowser for help on using the repository browser.