3 =head1 NAME $RCSfile: DBService.pm,v $
5 DB Service - Provide access to Clearquest database
13 Andrew DeFaria <Andrew@ClearSCM.com>
21 Monday, October 10, 2011 5:02:07 PM PDT
25 $Date: 2011/12/31 02:13:37 $
31 Provides an interface to the Clearquest database over the network.
33 This library implements both the daemon portion of the server and the client
38 The server allows both read and write access to a Clearquest database as defined
39 in cqdservice.conf file. Note the username/password must be of a user who can
40 write to the Clearquest database for write access to succeed.
42 A hash is passed into to the execute method, which the client should use to talk
43 to the server, that describes relatively simple protocol to tell the server what
44 action to perform. In both the read case and the read/write case a field named
45 id should be defined that has a value of "<record>=<id>" (e.g.
46 "defect=BUGDB00034429").
48 For the read case the rest of the keys are the names of the fields to retrieve
49 with values that are undef'ed. For read/write, the rest of hash contains name
50 value pairs of fields to set and their values.
52 Execute returns a status and a hash of name value pairs for the read case and an
53 array of lines for any error messages for the read/write case.
57 The following methods are available:
61 package Clearquest::DBService;
71 use POSIX ":sys_wait_h";
77 # Seed options from config file
78 my $config = $ENV{CQD_CONF} || dirname (__FILE__) . '/../../etc/cqdservice.conf';
80 croak "Unable to find config file $config" unless -r $config;
82 our %OPTS = GetConfig $config;
84 our $VERSION = '$Revision: 1.2 $';
85 ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
87 # Override options if in the environment
88 $OPTS{CQD_HOST} = $ENV{CQD_HOST}
90 $OPTS{CQD_PORT} = $ENV{CQD_PORT}
92 $OPTS{CQD_MULTITHREADED} = $ENV{CQD_MULTITHREADED}
93 if defined $ENV{CQD_MULTITHREADED};
94 $OPTS{CQD_DATABASE} = $ENV{CQD_DATABASE}
95 if $ENV{CQD_DATABASE};
96 $OPTS{CQD_USERNAME} = $ENV{CQD_USERNAME}
97 if $ENV{CQD_USERNAME};
98 $OPTS{CQD_PASSWORD} = $ENV{CQD_PASSWORD}
99 if $ENV{CQD_PASSWORD};
100 $OPTS{CQD_DBSET} = $ENV{CQD_DBSET}
106 my $cqdservice = bless {}, $class;
108 $cqdservice->{multithreaded} = $OPTS{CQD_MULTITHREADED};
114 my ($self, $msg) = @_;
118 $tag .= $self->{pid} ? "[$self->{pid}] " : '';
124 my ($self, $msg) = @_;
126 verbose $self->_tag ($msg);
132 my ($self, $msg) = @_;
134 debug $self->_tag ($msg);
140 my ($self, $msg) = @_;
142 display $self->_tag ($msg);
148 debug 'Entered _funeral';
150 while (my $childpid = waitpid (-1, WNOHANG) > 0) {
153 debug "childpid: $childpid - status: $status";
155 if ($childpid != -1) {
156 local $SIG{CHLD} = \&_funeral;
158 my $msg = 'Child has died';
159 $msg .= $status ? " with status $status" : '';
161 verbose "[$childpid] $msg"
164 debug "All children reaped";
172 display "CQDService V$VERSION shutdown at " . localtime;
177 # Wait for all children to die
182 # Now that we are alone, we can simply exit
186 sub _restartServer () {
187 # Not sure what to do on a restart server
188 display 'Entered _restartServer';
193 sub setMultithreaded ($) {
194 my ($self, $value) = @_;
196 my $oldValue = $self->{multithreaded};
198 $self->{multithreaded} = $value;
203 sub getMultithreaded () {
206 return $self->{multithreaded};
209 sub connectToServer (;$$) {
210 my ($self, $host, $port) = @_;
212 $host ||= $OPTS{CQD_HOST};
213 $port ||= $OPTS{CQD_PORT};
215 $self->{socket} = IO::Socket::INET->new (
221 return unless $self->{socket};
223 $self->{socket}->autoflush;
225 $self->{host} = $host;
226 $self->{port} = $port;
228 return $self->{socket} ? 1 : 0;
231 sub disconnectFromServer () {
234 if ($self->{socket}) {
235 close $self->{socket};
237 undef $self->{socket};
241 } # disconnectFromServer
243 # TODO: This function should not be internal and it should be overridable
244 sub _serviceClient ($$) {
245 my ($self, $host, $client) = @_;
247 $self->_verbose ("Serving requests from $host");
249 # Set autoflush for client
253 # Input is simple and consists of the following:
256 # <fieldname>=<fieldvalue>
257 # <fieldname>+=<fieldvalue>
261 # Notes: <ID> can be <ID_scope>. Also a += means append this fieldvalue to
262 # the existing value for the field.
264 # First get record line
265 my $line = <$client>;
268 chomp $line; chop $line if $line =~ /\r$/;
270 $self->_verbose ("Host $host went away!");
277 if ($line =~ /stopserver/i) {
278 if ($self->{server}) {
279 $self->_verbose ("$host requested to stop server [$self->{server}]");
281 # Send server hangup signal
282 kill 'HUP', $self->{server};
284 $self->_verbose ('Shutting down server');
286 print $client "CQDService Status: 0\n";
292 my ($record, $id) = split /=/, $line;
295 $self->_verbose ('Garbled record line - rejected request');
302 $self->_verbose ("Client wishes to deal with $id");
306 if ($id =~ /_(\S+)/) {
310 $self->_debug ("$host wants $record:$id");
314 # Now read name/value pairs
316 # Read command from client
320 chomp $line; chop $line if $line =~ /\r$/;
322 $self->_verbose ("Host $host went away!");
329 last if $line =~ /^end$/i;
331 # Collect name/values. Note if only names are requested then we will instead
333 my ($name, $value) = split /=/, $line;
336 # Transform %0A's back to \n
337 $value =~ s/\%0A/\n/g;
339 $self->_verbose ("Will set $name to $value");
342 $self->_verbose ("Will retrieve $name");
345 $fields{$name} = $value;
351 $self->_verbose ("Getting $record:$id");
353 eval { $entity = $self->{session}->GetEntity ($record, $id) };
356 print $client "Unable to GetEntity $record:$id\n";
364 print $client "$_@@" . $entity->GetFieldValue ($_)->GetValue . "\n"
366 print $client "CQD Status: 0\n";
374 $self->_verbose ("Editing $id");
376 $entity->EditEntity ('Backend');
380 for my $fieldName (keys %fields) {
381 if ($fieldName =~ /(.+)\*$/) {
382 my $newValue = delete $fields{$fieldName};
386 $fields{$fieldName} = $entity->GetFieldValue ($fieldName)->GetValue
390 $self->_verbose ("Setting $fieldName to $fields{$fieldName}");
392 $status = $entity->SetFieldValue ($fieldName, $fields{$fieldName});
395 $self->_verbose ($status);
397 print $client "$status\n";
398 print $client "CQD Status: 1\n";
406 $self->_verbose ("Validating $id");
408 $status = $entity->Validate;
411 $self->_verbose ('Committing');
414 print $client "Successfully updated $id\n";
415 print $client "CQD Status: 0\n";
417 $self->_verbose ('Reverting changes');
419 print $client "$status\n";
420 print $client "CQD Status: 1\n";
425 $self->_verbose ("Serviced requests from $host");
431 my ($self, %request) = @_;
433 $self->connectToServer or croak 'Unable to connect to CQD Service';
435 return (-1, 'Unable to talk to server')
436 unless $self->{socket};
438 my ($status, @output) = (-1, ());
440 my $server = $self->{socket};
442 my $id = delete $request{id};
444 print $server "$id\n";
448 for (keys %request) {
450 print $server "$_=$request{$_}\n";
453 print $server "$_\n";
457 print $server "end\n";
459 my ($response, %output);
461 while (defined ($response = <$server>)) {
462 if ($response =~ /CQD Status: (-*\d+)/) {
468 chomp $response; chop $response if $response =~ /\r$/;
470 my ($field, $value) = split /\@\@/, $response;
472 $output{$field} = $value;
474 push @output, $response;
478 chomp @output unless $read;
480 $self->disconnectFromServer;
482 if ($status != 0 or $read == 0) {
483 return ($status, @output);
485 return ($status, %output);
489 sub startServer (;$$$$$) {
491 require 'Clearquest.pm';
493 my ($self, $port, $username, $password, $db, $dbset) = @_;
495 $port ||= $OPTS{CQD_PORT};
496 $username ||= $OPTS{CQD_USERNAME};
497 $password ||= $OPTS{CQD_PASSWORD};
498 $db ||= $OPTS{CQD_DATABASE};
499 $dbset ||= $OPTS{CQD_DBSET};
501 # Create new socket to communicate to clients with
502 $self->{socket} = IO::Socket::INET->new(
509 error "Could not create socket - $!", 1
510 unless $self->{socket};
512 # Connect to Clearquest database
513 $self->{session} = CQSession::Build ();
515 verbose "Connecting to $username\@$db";
517 $self->{session}->UserLogon ($username, $password, $db, $dbset);
520 $self->_log ("CQD V$VERSION accepting clients at " . localtime);
522 # Now wait for an incoming request
526 while ($client = $self->{socket}->accept) {
527 my $hostinfo = gethostbyaddr $client->peeraddr;
528 my $host = $hostinfo ? $hostinfo->name : $client->peerhost;
530 $self->_verbose ("$host is requesting service");
532 if ($self->getMultithreaded) {
533 $self->{server} = $$;
537 $self->_debug ("Spawning child to handle request");
539 error "Can't fork: $!"
540 unless defined ($childpid = fork);
545 $SIG{CHLD} = \&_funeral;
546 $SIG{HUP} = \&_endServer;
547 $SIG{USR2} = \&_restartServer;
549 $self->_debug ("Parent produced child [$childpid]");
551 # In child process - ServiceClient
554 $self->_debug ("Calling _serviceClient");
555 $self->_serviceClient ($host, $client);
556 $self->_debug ("Returned from _serviceClient - exiting...");
561 $self->_serviceClient ($host, $client);
565 # This works but I really don't like it. The parent should have looped back to
566 # the while statement thus waiting for the next client. But it doesn't seem to
567 # do that. Instead, when multithreaded, the child exits above and then the
568 # parent breaks out of the while loop. I'm not sure why this is happening.
569 # This goto fixes this up but it's sooooo ugly!
577 =head1 CONFIGURATION AND ENVIRONMENT
579 DEBUG: If set then $debug is set to this level.
581 VERBOSE: If set then $verbose is set to this level.
583 TRACE: If set then $trace is set to this level.
591 L<File::Basename|File::Basename>
595 L<IO::Socket|IO::Socket>
597 L<Net::hostent|Net::hostent>
601 =head2 ClearSCM Perl Modules
614 <a href="http://clearscm.com/php/scm_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
615 <a href="http://clearscm.com/php/scm_man.php?file=lib/Display.pm">Display</a><br>
616 <a href="http://clearscm.com/php/scm_man.php?file=lib/GetConfig.pm">GetConf</a><br>
623 =head1 BUGS AND LIMITATIONS
625 There are no known bugs in this module.
627 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
629 =head1 LICENSE AND COPYRIGHT
631 Copyright (c) 2011, ClearSCM, Inc. All rights reserved.