3 =head1 NAME $RCSfile: Server.pm,v $
5 Clearquest Server - Provide access to Clearquest database
13 Andrew DeFaria <Andrew@ClearSCM.com>
21 Monday, October 10, 2011 5:02:07 PM PDT
25 $Date: 2013/03/14 23:13:33 $
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 cq.conf file. Note the username/password must be of a user who can write to
40 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::Server;
71 use POSIX qw(:sys_wait_h :signal_h);
79 # We cannot use parent here because CQPerl is used by the server. As such cqperl
80 # doesn't have parent.pm!
81 our @ISA = 'Clearquest';
83 our $VERSION = '$Revision: 2.6 $';
84 ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
87 my ($class, %parms) = @_;
91 $parms{CQ_DATABASE} ||= $Clearquest::OPTS{CQ_DATABASE};
92 $parms{CQ_USERNAME} ||= $Clearquest::OPTS{CQ_USERNAME};
93 $parms{CQ_PASSWORD} ||= $Clearquest::OPTS{CQ_PASSWORD};
94 $parms{CQ_DBSET} ||= $Clearquest::OPTS{CQ_DBSET};
95 $parms{CQ_SERVER} ||= $Clearquest::OPTS{CQ_SERVER};
96 $parms{CQ_PORT} ||= $Clearquest::OPTS{CQ_PORT};
98 $parms{CQ_MULTITHREADED} = $Clearquest::OPTS{CQ_MULTITHREADED}
99 unless defined $parms{CQ_MULTITHREADED};
101 # The server always uses the standard Clearquest API
102 $parms{CQ_MODULE} = 'api';
105 $self->{username} = $parms{CQ_USERNAME};
106 $self->{password} = $parms{CQ_PASSWORD};
107 $self->{database} = $parms{CQ_DATABASE};
108 $self->{dbset} = $parms{CQ_DBSET};
109 $self->{server} = $parms{CQ_SERVER};
110 $self->{port} = $parms{CQ_PORT};
111 $self->{module} = $parms{CQ_MODULE};
112 $self->{multithreaded} = $parms{CQ_MULTITHREADED};
114 return bless $self, $class;
118 my ($self, $msg) = @_;
122 $tag .= $self->{pid} ? '[' . abs ($self->{pid}) . '] ' : '';
128 my ($self, $msg) = @_;
130 verbose $self->_tag ($msg);
136 my ($self, $msg) = @_;
138 debug $self->_tag ($msg);
144 my ($self, $msg) = @_;
146 display $self->_tag ($msg);
152 debug "Entered _funeral";
154 while (my $childpid = waitpid (-1, WNOHANG) > 0) {
157 if ($childpid != -1) {
158 local $SIG{CHLD} = \&_funeral;
160 my $msg = 'Child has died';
161 $msg .= $status ? " with status $status" : '';
163 verbose "[$childpid] $msg"
172 display "Clearquest::Server 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 _printStatus ($) {
194 my ($self, $client) = @_;
196 my $status = $self->{clearquest}->error;
200 $self->_debug ("Printing status: " . __PACKAGE__ . " Status: $status");
202 print $client __PACKAGE__ . " Status: $status\n";
204 $self->_debug ("After print");
209 sub _connectToClearquest ($$$$) {
210 my ($self, $database, $username, $password, $dbset) = @_;
214 $parms{CQ_DATABASE} = $database;
215 $parms{CQ_USERNAME} = $username;
216 $parms{CQ_PASSWORD} = $password;
217 $parms{CQ_DBSET} = $dbset;
219 # The server always uses the standard Clearquest API
220 $parms{CQ_MODULE} = 'api';
222 # Connect to Clearquest database
223 $self->{clearquest} = Clearquest->new (%parms);
225 $self->_verbose ("Connecting to "
226 . "$parms{CQ_USERNAME}\@$parms{CQ_DATABASE}/$parms{CQ_DBSET}"
227 . " for $self->{clientname}");
229 $self->{loggedin} = $self->{clearquest}->connect;
231 return $self->{loggedin};
232 } # _connectToClearquest
234 sub _processCommand ($$@) {
235 my ($self, $client, $call, @parms) = @_;
237 $self->_debug ("Client wishes to execute $call");
239 if ($call eq 'end') {
240 $self->_verbose ("Serviced requests from $self->{clientname}");
244 $self->disconnectFromClient;
247 } elsif ($call eq 'open') {
248 debug "connectToClearquest";
249 unless ($self->_connectToClearquest (@parms)) {
250 debug "Error: " . $self->{clearquest}->errmsg;
251 print $client $self->{clearquest}->errmsg . "\n";
254 print $client 'Connected to '
255 . $self->username () . '@'
256 . $self->database () . '/'
257 . $self->dbset () . "\n";
260 debug "Calling _printStatus";
261 $self->_printStatus ($client);
262 } elsif ($call eq 'get') {
263 my %record = $self->{clearquest}->get (@parms);
265 unless ($self->{clearquest}->error) {
266 foreach my $field (keys %record) {
267 # TODO: Need to handle field types better...
268 if (ref $record{$field} eq 'ARRAY') {
269 foreach (@{$record{$field}}) {
270 # Change \n's to
273 print $client "$field\@\@$_\n";
276 # Change \n's to
277 $record{$field} =~ s/\r\n/ /gm;
279 print $client "$field\@\@$record{$field}\n";
283 print $client $self->{clearquest}->errmsg . "\n";
286 $self->_printStatus ($client);
287 } elsif ($call eq 'find') {
288 my ($result, $nbrRecs) = $self->{clearquest}->find (@parms);
290 if ($self->{clearquest}->error != 0) {
291 print $client $self->{clearquest}->errmsg . "\n";
293 # Store away $result so we can use it later
294 $self->{result} = $result;
296 print $client "$result\n$nbrRecs\n";
299 $self->_printStatus ($client);
300 } elsif ($call eq 'getnext') {
301 my %record = $self->{clearquest}->getNext ($self->{result});
303 unless ($self->{clearquest}->error) {
304 foreach my $field (keys %record) {
305 # TODO: Need to handle field types better...
306 if (ref $record{$field} eq 'ARRAY') {
307 foreach (@{$record{$field}}) {
308 # Change \n's to
311 print $client "$field\@\@$_\n";
314 # Change \n's to
315 $record{$field} =~ s/\r\n/ /gm;
317 print $client "$field\@\@$record{$field}\n";
321 print $client $self->{clearquest}->errmsg . "\n";
324 $self->_printStatus ($client);
325 } elsif ($call eq 'getdynamiclist') {
326 # TODO Better error handling/testing
327 my @entry = $self->{clearquest}->getDynamicList (@parms);
329 print $client "$_\n" foreach @entry;
331 $self->_printStatus ($client);
332 } elsif ($call eq 'dbsets') {
333 # TODO Better error handling/testing
334 print $client "$_\n" foreach ($self->{clearquest}->DBSets);
336 $self->_printStatus ($client);
337 } elsif ($call eq 'key') {
338 # TODO Better error handling/testing
339 print $client $self->{clearquest}->key (@parms) . "\n";
341 $self->_printStatus ($client);
342 } elsif ($call eq 'modify' or $call eq 'modifyDBID') {
343 my $table = shift @parms;
344 my $key = shift @parms;
345 my $action = shift @parms;
347 # Need to turn off strict for eval here...
348 my ($values, @ordering);
355 @ordering = @{$parms[1]} if ref $parms[1] eq 'ARRAY';
359 if ($call eq 'modify') {
360 $errmsg = $self->{clearquest}->modify ($table, $key, $action, $values, @ordering);
361 } elsif ($call eq 'modifyDBID') {
362 $errmsg = $self->{clearquest}->modifyDBID ($table, $key, $action, $values, @ordering);
365 print $client "$errmsg\n" if $errmsg ne '';
367 $self->_printStatus ($client);
368 } elsif ($call eq 'add') {
369 my $dbid = $self->{clearquest}->add (@parms);
371 if ($self->{clearquest}->error) {
372 print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
375 $self->_printStatus ($client);
376 } elsif ($call eq 'delete') {
377 $self->{clearquest}->delete (@parms);
379 if ($self->{clearquest}->error) {
380 print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
383 $self->_printStatus ($client);
385 $self->{clearquest}->{errnbr} = -1;
386 $self->{clearquest}->{errmsg} = "Unknown call $call";
388 print $client $self->{clearquest}->errmsg . "\n";
390 $self->_printStatus ($client);
396 sub _serviceClient ($) {
397 my ($self, $client) = @_;
399 $self->_verbose ("Servicing requests from $self->{clientname}");
401 # Set autoflush for client
402 $client->autoflush if $client;
406 $self->_debug ("Reading request from client");
408 while ($line = <$client>) {
409 $self->_debug ("Request read: $line");
412 chomp $line; chop $line if $line =~ /\r$/;
414 $self->_verbose ("Host $self->{clientname} went away!");
421 if ($line =~ /^shutdown/i) {
422 if ($self->{server}) {
423 $self->_verbose ("$self->{clientname} requested to shutdown the server");
425 print $client __PACKAGE__ . " Status: 0\n";
428 # TODO: This is not working because getppid is not implemented on Windows!
429 #kill HUP => getppid;
437 if ($line =~ /^\s*(\S+)\s+(.*)/) {
453 $parms[$i++] = $VAR1;
459 } elsif ($line =~ /^\s*(\S+)/) {
463 my $errmsg = "Garbled command line: '$line'";
465 if ($self->{clearquest}) {
466 $self->{clearquest}->{errnbr} = -1;
467 $self->{clearquest}->{errmsg} = $errmsg;
469 print $client $self->{clearquest}->errmsg . "\n";
474 $self->_printStatus ($client);
479 $self->_debug ("Processing command $call @parms");
481 last if $self->_processCommand ($client, $call, @parms);
487 sub multithreaded (;$) {
488 my ($self, $newValue) = @_;
490 my $oldValue = $self->{multithreaded};
492 $self->{multithreaded} = $newValue if $newValue;
497 sub disconnectFromClient () {
500 # Destroy Clearquest object so we disconnect from Clearquest.
501 undef $self->{clearquest};
503 $self->_verbose ("Disconnected from client $self->{clientname}")
504 if $self->{clientname};
506 undef $self->{clientname};
509 } # disconnectFromClient
514 $self->disconnectFromClient;
516 if ($self->{socket}) {
517 close $self->{socket};
519 undef $self->{socket};
526 # Create new socket to communicate to clients with
527 $self->{socket} = IO::Socket::INET->new (
529 LocalPort => $self->{port},
534 error "Could not create socket - $!", 1
535 unless $self->{socket};
538 $self->_log (__PACKAGE__ . " V$VERSION accepting clients at " . localtime);
540 $SIG{HUP} = \&_endServer;
542 # Now wait for an incoming request
546 $client = $self->{socket}->accept;
552 error "Accept called failed (Error: $?) - $!", 1;
556 my $hostinfo = gethostbyaddr $client->peeraddr;
558 $self->{clientname} = $hostinfo ? $hostinfo->name : $client->peerhost;
560 $self->_verbose ("$self->{clientname} is requesting service");
562 if ($self->multithreaded) {
567 $self->_debug ("Spawning child to handle request");
569 error "Can't fork: $!"
570 unless defined ($childpid = fork);
575 # Signal handling sucks under Windows. For example, we cannot catch
576 # SIGCHLD when using the ActiveState based cqperl when running on
577 # Windows. If there will be a zombie apocalypse it will start on
579 unless ($^O =~ /win/i) {
580 my $sigset = POSIX::SigSet->new (&POSIX::SIGCHLD);
581 my $sigaction = POSIX::SigAction->new (\&_funeral, $sigset, &POSIX::SA_RESTART);
584 $self->_debug ("Parent produced child [$childpid]");
586 # In child process - ServiceClient
589 # Now exec the caller but set STDIN to be the socket. Also pass
590 # -serviceClient to the caller which will need to handle that and call
592 $self->_debug ("Client: $client");
593 open STDIN, '+<&', $client
594 or croak "Unable to dup client";
596 my $cmd = "cqperl \"$FindBin::Bin/$FindBin::Script -serviceClient=$self->{clientname} -verbose -debug";
598 $self->_debug ("Execing: $cmd");
600 exec 'cqperl', "\"$FindBin::Bin/$FindBin::Script\"", "-serviceClient=$self->{clientname}", '-verbose', '-debug'
601 or croak "Unable to exec $cmd";
604 $self->_serviceClient ($client);
608 # On Windows we can't catch SIGCHLD so we need to loop around. Ugly!
609 goto LOOP if $^O =~ /win/i;
616 =head1 CONFIGURATION AND ENVIRONMENT
618 DEBUG: If set then $debug is set to this level.
620 VERBOSE: If set then $verbose is set to this level.
622 TRACE: If set then $trace is set to this level.
630 L<File::Basename|File::Basename>
634 L<IO::Socket|IO::Socket>
636 L<Net::hostent|Net::hostent>
640 =head2 ClearSCM Perl Modules
653 <a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
654 <a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
655 <a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
662 =head1 BUGS AND LIMITATIONS
664 There are no known bugs in this module.
666 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
668 =head1 LICENSE AND COPYRIGHT
670 Copyright (c) 2011, ClearSCM, Inc. All rights reserved.