lib/Clearquest/Server.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: Server.pm,v $
   4
   5 Clearquest Server - Provide access to Clearquest database
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@ClearSCM.com>
  14
  15 =item Revision
  16
  17 $Revision: 2.6 $
  18
  19 =item Created
  20
  21 Monday, October 10, 2011  5:02:07 PM PDT
  22
  23 =item Modified
  24
  25 $Date: 2013/03/14 23:13:33 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Provides an interface to the Clearquest database over the network.
  32
  33 This library implements both the daemon portion of the server and the client
  34 API.
  35
  36 =head1 DESCRIPTION
  37
  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.
  41
  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").
  47
  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.
  51
  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.
  54
  55 =head1 ROUTINES
  56
  57 The following methods are available:
  58
  59 =cut
  60
  61 package Clearquest::Server;
  62
  63 use strict;
  64 use warnings;
  65
  66 use Carp;
  67 use File::Basename;
  68 use FindBin;
  69 use IO::Socket;
  70 use Net::hostent;
  71 use POSIX qw(:sys_wait_h :signal_h);
  72
  73 use DateUtils;
  74 use Display;
  75 use GetConfig;
  76
  77 use Clearquest;
  78
  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';
  82
  83 our $VERSION  = '$Revision: 2.6 $';
  84    ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
  85
  86 sub new (;%) {
  87   my ($class, %parms) = @_;
  88
  89   my $self;
  90
  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};
  97
  98   $parms{CQ_MULTITHREADED} = $Clearquest::OPTS{CQ_MULTITHREADED}
  99     unless defined $parms{CQ_MULTITHREADED};
 100
 101   # The server always uses the standard Clearquest API
 102   $parms{CQ_MODULE} = 'api';
 103
 104   # Set data members
 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};
 113
 114   return bless $self, $class;
 115 } # new
 116
 117 sub _tag ($) {
 118   my ($self, $msg) = @_;
 119
 120   my $tag  = YMDHMS;
 121      $tag .= ' ';
 122      $tag .= $self->{pid} ? '[' . abs ($self->{pid}) . '] ' : '';
 123
 124   return "$tag$msg";
 125 } # _tag
 126
 127 sub _verbose ($) {
 128   my ($self, $msg) = @_;
 129
 130   verbose $self->_tag ($msg);
 131
 132   return;
 133 } # _verbose
 134
 135 sub _debug ($) {
 136   my ($self, $msg) = @_;
 137
 138   debug $self->_tag ($msg);
 139
 140   return;
 141 } # _debug
 142
 143 sub _log ($) {
 144   my ($self, $msg) = @_;
 145
 146   display $self->_tag ($msg);
 147
 148   return;
 149 } # log
 150
 151 sub _funeral () {
 152   debug "Entered _funeral";
 153
 154   while (my $childpid = waitpid (-1, WNOHANG) > 0) {
 155     my $status = $?;
 156
 157     if ($childpid != -1) {
 158       local $SIG{CHLD} = \&_funeral;
 159
 160       my $msg  = 'Child has died';
 161          $msg .= $status ? " with status $status" : '';
 162
 163       verbose "[$childpid] $msg"
 164         if $status;
 165     } # if
 166   } # while
 167
 168   return;
 169 } # _funeral
 170
 171 sub _endServer () {
 172   display "Clearquest::Server V$VERSION shutdown at " . localtime;
 173
 174   # Kill process group
 175   kill 'TERM', -$$;
 176
 177   # Wait for all children to die
 178   while (wait != -1) {
 179     # do nothing
 180   } # while
 181
 182   # Now that we are alone, we can simply exit
 183   exit;
 184 } # _endServer
 185
 186 sub _restartServer () {
 187   # Not sure what to do on a restart server
 188   display 'Entered _restartServer';
 189
 190   return;
 191 } # _restartServer
 192
 193 sub _printStatus ($) {
 194   my ($self, $client) = @_;
 195
 196   my $status = $self->{clearquest}->error;
 197
 198   $status ||= 0;
 199
 200   $self->_debug ("Printing status: " . __PACKAGE__ . " Status: $status");
 201
 202   print $client __PACKAGE__ . " Status: $status\n";
 203
 204   $self->_debug ("After print");
 205
 206   return;
 207 } # printStatus
 208
 209 sub _connectToClearquest ($$$$) {
 210   my ($self, $database, $username, $password, $dbset) = @_;
 211
 212   my %parms;
 213
 214   $parms{CQ_DATABASE} = $database;
 215   $parms{CQ_USERNAME} = $username;
 216   $parms{CQ_PASSWORD} = $password;
 217   $parms{CQ_DBSET}    = $dbset;
 218
 219   # The server always uses the standard Clearquest API
 220   $parms{CQ_MODULE} = 'api';
 221
 222   # Connect to Clearquest database
 223   $self->{clearquest} = Clearquest->new (%parms);
 224
 225   $self->_verbose ("Connecting to "
 226         . "$parms{CQ_USERNAME}\@$parms{CQ_DATABASE}/$parms{CQ_DBSET}"
 227         . " for $self->{clientname}");
 228
 229   $self->{loggedin} = $self->{clearquest}->connect;
 230
 231   return $self->{loggedin};
 232 } # _connectToClearquest
 233
 234 sub _processCommand ($$@) {
 235   my ($self, $client, $call, @parms) = @_;
 236
 237   $self->_debug ("Client wishes to execute $call");
 238
 239   if ($call eq 'end') {
 240     $self->_verbose ("Serviced requests from $self->{clientname}");
 241
 242     close $client;
 243
 244     $self->disconnectFromClient;
 245
 246     return 1;
 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";
 252     } else {
 253       debug "Success!";
 254       print $client 'Connected to '
 255                   . $self->username () . '@'
 256                   . $self->database () . '/'
 257                   . $self->dbset    () . "\n";
 258     } # if
 259
 260     debug "Calling _printStatus";
 261     $self->_printStatus ($client);
 262   } elsif ($call eq 'get') {
 263     my %record = $self->{clearquest}->get (@parms);
 264
 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 &#10;
 271             s/\r\n/&#10;/gm;
 272
 273             print $client "$field\@\@$_\n";
 274           } # foreach
 275         } else {
 276           # Change \n's to &#10;
 277           $record{$field} =~ s/\r\n/&#10;/gm;
 278
 279           print $client "$field\@\@$record{$field}\n";
 280         } # if
 281       } # foreach
 282     } else {
 283       print $client $self->{clearquest}->errmsg . "\n";
 284     } # unless
 285
 286     $self->_printStatus ($client);
 287   } elsif ($call eq 'find') {
 288     my ($result, $nbrRecs) = $self->{clearquest}->find (@parms);
 289
 290     if ($self->{clearquest}->error != 0) {
 291       print $client $self->{clearquest}->errmsg . "\n";
 292     } else {
 293       # Store away $result so we can use it later
 294       $self->{result} = $result;
 295
 296       print $client "$result\n$nbrRecs\n";
 297     } # if
 298
 299     $self->_printStatus ($client);
 300   } elsif ($call eq 'getnext') {
 301     my %record = $self->{clearquest}->getNext ($self->{result});
 302
 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 &#10;
 309             s/\r\n/&#10;/gm;
 310
 311             print $client "$field\@\@$_\n";
 312           } # foreach
 313         } else {
 314           # Change \n's to &#10;
 315           $record{$field} =~ s/\r\n/&#10;/gm;
 316
 317           print $client "$field\@\@$record{$field}\n";
 318         } # if
 319       } # foreach
 320     } else {
 321       print $client $self->{clearquest}->errmsg . "\n";
 322     } # unless
 323
 324     $self->_printStatus ($client);
 325   } elsif ($call eq 'getdynamiclist') {
 326     # TODO Better error handling/testing
 327     my @entry = $self->{clearquest}->getDynamicList (@parms);
 328
 329     print $client "$_\n" foreach @entry;
 330
 331     $self->_printStatus ($client);
 332   } elsif ($call eq 'dbsets') {
 333     # TODO Better error handling/testing
 334     print $client "$_\n" foreach ($self->{clearquest}->DBSets);
 335
 336     $self->_printStatus ($client);
 337   } elsif ($call eq 'key') {
 338     # TODO Better error handling/testing
 339     print $client $self->{clearquest}->key (@parms) . "\n";
 340
 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;
 346
 347     # Need to turn off strict for eval here...
 348     my ($values, @ordering);
 349     no strict;
 350     eval $parms[0];
 351
 352     $values = $VAR1;
 353     use strict;
 354
 355     @ordering = @{$parms[1]} if ref $parms[1] eq 'ARRAY';
 356
 357     my $errmsg;
 358
 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);
 363     } # if
 364
 365     print $client "$errmsg\n" if $errmsg ne '';
 366
 367     $self->_printStatus ($client);
 368   } elsif ($call eq 'add') {
 369     my $dbid = $self->{clearquest}->add (@parms);
 370
 371     if ($self->{clearquest}->error) {
 372       print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
 373     } # if
 374
 375     $self->_printStatus ($client);
 376   } elsif ($call eq 'delete') {
 377     $self->{clearquest}->delete (@parms);
 378
 379     if ($self->{clearquest}->error) {
 380       print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
 381     } # if
 382
 383     $self->_printStatus ($client);
 384   } else {
 385     $self->{clearquest}->{errnbr} = -1;
 386     $self->{clearquest}->{errmsg} = "Unknown call $call";
 387
 388     print $client $self->{clearquest}->errmsg . "\n";
 389
 390     $self->_printStatus ($client);
 391   } # if
 392
 393   return;
 394 } # _processCommand
 395
 396 sub _serviceClient ($) {
 397   my ($self, $client) = @_;
 398
 399   $self->_verbose ("Servicing requests from $self->{clientname}");
 400
 401   # Set autoflush for client
 402   $client->autoflush if $client;
 403
 404   my $line;
 405
 406   $self->_debug ("Reading request from client");
 407
 408   while ($line = <$client>) {
 409     $self->_debug ("Request read: $line");
 410
 411     if ($line) {
 412       chomp $line; chop $line if $line =~ /\r$/;
 413     } else {
 414       $self->_verbose ("Host $self->{clientname} went away!");
 415
 416       close $client;
 417
 418       return;
 419     } # if
 420
 421     if ($line =~ /^shutdown/i) {
 422       if ($self->{server}) {
 423         $self->_verbose ("$self->{clientname} requested to shutdown the server");
 424
 425         print $client __PACKAGE__ . " Status: 0\n";
 426       } # if
 427
 428       # TODO: This is not working because getppid is not implemented on Windows!
 429       #kill HUP => getppid;
 430
 431       exit 1;
 432     } # if
 433
 434     # Parse command line
 435     my ($call, @parms);
 436
 437     if ($line =~ /^\s*(\S+)\s+(.*)/) {
 438       $call = lc $1;
 439
 440       no strict;
 441       eval $2;
 442
 443       @parms = @$VAR1;
 444       use strict;
 445
 446       my $i = 0;
 447
 448       foreach (@parms) {
 449         if (/^\$VAR1/) {
 450           no strict;
 451           eval;
 452
 453           $parms[$i++] = $VAR1;
 454           use strict;
 455         } else {
 456           $i++;
 457         } # if
 458       } # foreach
 459     } elsif ($line =~ /^\s*(\S+)/) {
 460       $call = lc $1;
 461       @parms = ();
 462     } else {
 463       my $errmsg = "Garbled command line: '$line'";
 464
 465       if ($self->{clearquest}) {
 466         $self->{clearquest}->{errnbr} = -1;
 467         $self->{clearquest}->{errmsg} = $errmsg;
 468
 469         print $client $self->{clearquest}->errmsg . "\n";
 470       } else {
 471         print "$errmsg\n";
 472       } # if
 473
 474       $self->_printStatus ($client);
 475
 476       return;
 477     } # if
 478
 479     $self->_debug ("Processing command $call @parms");
 480
 481     last if $self->_processCommand ($client, $call, @parms);
 482   } # while
 483
 484   return;
 485 }  # _serviceClient
 486
 487 sub multithreaded (;$) {
 488   my ($self, $newValue) = @_;
 489
 490   my $oldValue = $self->{multithreaded};
 491
 492   $self->{multithreaded} = $newValue if $newValue;
 493
 494   return $oldValue
 495 } # multithreaded
 496
 497 sub disconnectFromClient () {
 498   my ($self) = @_;
 499
 500   # Destroy Clearquest object so we disconnect from Clearquest.
 501   undef $self->{clearquest};
 502
 503   $self->_verbose ("Disconnected from client $self->{clientname}")
 504     if $self->{clientname};
 505
 506   undef $self->{clientname};
 507
 508   return;
 509 } # disconnectFromClient
 510
 511 sub DESTROY () {
 512   my ($self) = @_;
 513
 514     $self->disconnectFromClient;
 515
 516   if ($self->{socket}) {
 517    close $self->{socket};
 518
 519    undef $self->{socket};
 520   } # if
 521 } # DESTROY
 522
 523 sub startServer () {
 524   my ($self) = @_;
 525
 526   # Create new socket to communicate to clients with
 527   $self->{socket} = IO::Socket::INET->new (
 528     Proto     => 'tcp',
 529     LocalPort => $self->{port},
 530     Listen    => SOMAXCONN,
 531     ReuseAddr => 1,
 532   );
 533
 534   error "Could not create socket - $!", 1
 535     unless $self->{socket};
 536
 537   # Announce ourselves
 538   $self->_log (__PACKAGE__ . " V$VERSION accepting clients at " . localtime);
 539
 540   $SIG{HUP}  = \&_endServer;
 541
 542   # Now wait for an incoming request
 543   my $client;
 544
 545   LOOP: while () {
 546     $client = $self->{socket}->accept;
 547
 548     if ($? == -1) {
 549       if ($!{EINTR}) {
 550         next;
 551       } else {
 552         error "Accept called failed (Error: $?) - $!", 1;
 553       } # if
 554     } # if
 555
 556     my $hostinfo = gethostbyaddr $client->peeraddr;
 557
 558     $self->{clientname} = $hostinfo ? $hostinfo->name : $client->peerhost;
 559
 560     $self->_verbose ("$self->{clientname} is requesting service");
 561
 562     if ($self->multithreaded) {
 563       $self->{pid} = $$;
 564
 565       my $childpid;
 566
 567       $self->_debug ("Spawning child to handle request");
 568
 569       error "Can't fork: $!"
 570         unless defined ($childpid = fork);
 571
 572       if ($childpid) {
 573         $self->{pid} = $$;
 574
 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
 578         # Windows! ;-)
 579         unless ($^O =~ /win/i) {
 580           my $sigset = POSIX::SigSet->new (&POSIX::SIGCHLD);
 581           my $sigaction = POSIX::SigAction->new (\&_funeral, $sigset, &POSIX::SA_RESTART);
 582         } # unless
 583
 584         $self->_debug ("Parent produced child [$childpid]");
 585       } else {
 586         # In child process - ServiceClient
 587         $self->{pid} = $$;
 588
 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
 591         # _serviceClient.
 592         $self->_debug ("Client: $client");
 593         open STDIN, '+<&', $client
 594           or croak "Unable to dup client";
 595
 596         my $cmd = "cqperl \"$FindBin::Bin/$FindBin::Script -serviceClient=$self->{clientname} -verbose -debug";
 597
 598         $self->_debug ("Execing: $cmd");
 599
 600         exec 'cqperl', "\"$FindBin::Bin/$FindBin::Script\"", "-serviceClient=$self->{clientname}", '-verbose', '-debug'
 601           or croak "Unable to exec $cmd";
 602       } # if
 603     } else {
 604       $self->_serviceClient ($client);
 605     } # if
 606   } # while
 607
 608   # On Windows we can't catch SIGCHLD so we need to loop around. Ugly!
 609   goto LOOP if $^O =~ /win/i;
 610 } # startServer
 611
 612 1;
 613
 614 =pod
 615
 616 =head1 CONFIGURATION AND ENVIRONMENT
 617
 618 DEBUG: If set then $debug is set to this level.
 619
 620 VERBOSE: If set then $verbose is set to this level.
 621
 622 TRACE: If set then $trace is set to this level.
 623
 624 =head1 DEPENDENCIES
 625
 626 =head2 Perl Modules
 627
 628 L<Carp>
 629
 630 L<File::Basename|File::Basename>
 631
 632 L<FindBin>
 633
 634 L<IO::Socket|IO::Socket>
 635
 636 L<Net::hostent|Net::hostent>
 637
 638 L<POSIX>
 639
 640 =head2 ClearSCM Perl Modules
 641
 642 =begin man
 643
 644  DateUtils
 645  Display
 646  GetConfig
 647
 648 =end man
 649
 650 =begin html
 651
 652 <blockquote>
 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>
 656 </blockquote>
 657
 658 =end html
 659
 660 =head1 SEE ALSO
 661
 662 =head1 BUGS AND LIMITATIONS
 663
 664 There are no known bugs in this module.
 665
 666 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
 667
 668 =head1 LICENSE AND COPYRIGHT
 669
 670 Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
 671
 672 =cut