my ($class, %parms) = @_;
my $self;
-
+
$parms{CQ_DATABASE} ||= $Clearquest::OPTS{CQ_DATABASE};
$parms{CQ_USERNAME} ||= $Clearquest::OPTS{CQ_USERNAME};
$parms{CQ_PASSWORD} ||= $Clearquest::OPTS{CQ_PASSWORD};
$parms{CQ_DBSET} ||= $Clearquest::OPTS{CQ_DBSET};
$parms{CQ_SERVER} ||= $Clearquest::OPTS{CQ_SERVER};
$parms{CQ_PORT} ||= $Clearquest::OPTS{CQ_PORT};
-
+
$parms{CQ_MULTITHREADED} = $Clearquest::OPTS{CQ_MULTITHREADED}
unless defined $parms{CQ_MULTITHREADED};
$self->{port} = $parms{CQ_PORT};
$self->{module} = $parms{CQ_MODULE};
$self->{multithreaded} = $parms{CQ_MULTITHREADED};
-
+
return bless $self, $class;
} # new
my $tag = YMDHMS;
$tag .= ' ';
$tag .= $self->{pid} ? '[' . abs ($self->{pid}) . '] ' : '';
-
+
return "$tag$msg";
} # _tag
my ($self, $msg) = @_;
verbose $self->_tag ($msg);
-
+
return;
} # _verbose
sub _debug ($) {
my ($self, $msg) = @_;
-
+
debug $self->_tag ($msg);
-
+
return;
} # _debug
sub _log ($) {
my ($self, $msg) = @_;
-
+
display $self->_tag ($msg);
-
+
return;
} # log
sub _funeral () {
debug "Entered _funeral";
-
+
while (my $childpid = waitpid (-1, WNOHANG) > 0) {
my $status = $?;
-
+
if ($childpid != -1) {
local $SIG{CHLD} = \&_funeral;
if $status;
} # if
} # while
-
+
return;
} # _funeral
sub _endServer () {
display "Clearquest::Server V$VERSION shutdown at " . localtime;
-
+
# Kill process group
kill 'TERM', -$$;
-
+
# Wait for all children to die
while (wait != -1) {
# do nothing
} # while
-
+
# Now that we are alone, we can simply exit
exit;
} # _endServer
sub _restartServer () {
# Not sure what to do on a restart server
display 'Entered _restartServer';
-
+
return;
} # _restartServer
sub _printStatus ($) {
my ($self, $client) = @_;
-
+
my $status = $self->{clearquest}->error;
-
+
$status ||= 0;
-
+
$self->_debug ("Printing status: " . __PACKAGE__ . " Status: $status");
-
+
print $client __PACKAGE__ . " Status: $status\n";
-
+
$self->_debug ("After print");
-
+
return;
} # printStatus
sub _connectToClearquest ($$$$) {
my ($self, $database, $username, $password, $dbset) = @_;
-
+
my %parms;
-
+
$parms{CQ_DATABASE} = $database;
$parms{CQ_USERNAME} = $username;
$parms{CQ_PASSWORD} = $password;
$parms{CQ_DBSET} = $dbset;
-
+
# The server always uses the standard Clearquest API
$parms{CQ_MODULE} = 'api';
-
+
# Connect to Clearquest database
$self->{clearquest} = Clearquest->new (%parms);
. " for $self->{clientname}");
$self->{loggedin} = $self->{clearquest}->connect;
-
+
return $self->{loggedin};
} # _connectToClearquest
sub _processCommand ($$@) {
my ($self, $client, $call, @parms) = @_;
-
+
$self->_debug ("Client wishes to execute $call");
if ($call eq 'end') {
$self->_verbose ("Serviced requests from $self->{clientname}");
-
+
close $client;
$self->disconnectFromClient;
-
+
return 1;
} elsif ($call eq 'open') {
debug "connectToClearquest";
$self->_printStatus ($client);
} elsif ($call eq 'get') {
my %record = $self->{clearquest}->get (@parms);
-
+
unless ($self->{clearquest}->error) {
foreach my $field (keys %record) {
# TODO: Need to handle field types better...
foreach (@{$record{$field}}) {
# Change \n's to
s/\r\n/ /gm;
-
+
print $client "$field\@\@$_\n";
} # foreach
} else {
# Change \n's to
$record{$field} =~ s/\r\n/ /gm;
-
+
print $client "$field\@\@$record{$field}\n";
} # if
} # foreach
} else {
print $client $self->{clearquest}->errmsg . "\n";
} # unless
-
+
$self->_printStatus ($client);
} elsif ($call eq 'find') {
my ($result, $nbrRecs) = $self->{clearquest}->find (@parms);
} else {
# Store away $result so we can use it later
$self->{result} = $result;
-
+
print $client "$result\n$nbrRecs\n";
} # if
$self->_printStatus ($client);
} elsif ($call eq 'getnext') {
my %record = $self->{clearquest}->getNext ($self->{result});
-
+
unless ($self->{clearquest}->error) {
foreach my $field (keys %record) {
# TODO: Need to handle field types better...
foreach (@{$record{$field}}) {
# Change \n's to
s/\r\n/ /gm;
-
+
print $client "$field\@\@$_\n";
} # foreach
} else {
# Change \n's to
$record{$field} =~ s/\r\n/ /gm;
-
+
print $client "$field\@\@$record{$field}\n";
} # if
} # foreach
} else {
print $client $self->{clearquest}->errmsg . "\n";
} # unless
-
+
$self->_printStatus ($client);
} elsif ($call eq 'getdynamiclist') {
# TODO Better error handling/testing
my @entry = $self->{clearquest}->getDynamicList (@parms);
-
+
print $client "$_\n" foreach @entry;
-
+
$self->_printStatus ($client);
} elsif ($call eq 'dbsets') {
# TODO Better error handling/testing
print $client "$_\n" foreach ($self->{clearquest}->DBSets);
-
+
$self->_printStatus ($client);
} elsif ($call eq 'key') {
# TODO Better error handling/testing
print $client $self->{clearquest}->key (@parms) . "\n";
-
+
$self->_printStatus ($client);
} elsif ($call eq 'modify' or $call eq 'modifyDBID') {
my $table = shift @parms;
my $action = shift @parms;
# Need to turn off strict for eval here...
- my ($values, @ordering);
+ my ($values, @ordering);
no strict;
eval $parms[0];
-
+
$values = $VAR1;
use strict;
-
+
@ordering = @{$parms[1]} if ref $parms[1] eq 'ARRAY';
-
+
my $errmsg;
-
+
if ($call eq 'modify') {
$errmsg = $self->{clearquest}->modify ($table, $key, $action, $values, @ordering);
} elsif ($call eq 'modifyDBID') {
$errmsg = $self->{clearquest}->modifyDBID ($table, $key, $action, $values, @ordering);
} # if
-
+
print $client "$errmsg\n" if $errmsg ne '';
$self->_printStatus ($client);
} elsif ($call eq 'add') {
my $dbid = $self->{clearquest}->add (@parms);
-
+
if ($self->{clearquest}->error) {
print $client 'ERROR: ' . $self->{clearquest}->errmsg () . "\n";
} # if
} else {
$self->{clearquest}->{errnbr} = -1;
$self->{clearquest}->{errmsg} = "Unknown call $call";
-
+
print $client $self->{clearquest}->errmsg . "\n";
-
+
$self->_printStatus ($client);
} # if
-
+
return;
} # _processCommand
# Set autoflush for client
$client->autoflush if $client;
-
+
my $line;
-
+
$self->_debug ("Reading request from client");
-
+
while ($line = <$client>) {
$self->_debug ("Request read: $line");
-
+
if ($line) {
chomp $line; chop $line if $line =~ /\r$/;
} else {
$self->_verbose ("Host $self->{clientname} went away!");
-
+
close $client;
-
+
return;
} # if
if ($line =~ /^shutdown/i) {
if ($self->{server}) {
$self->_verbose ("$self->{clientname} requested to shutdown the server");
-
+
print $client __PACKAGE__ . " Status: 0\n";
} # if
exit 1;
} # if
-
+
# Parse command line
my ($call, @parms);
-
+
if ($line =~ /^\s*(\S+)\s+(.*)/) {
$call = lc $1;
-
+
no strict;
eval $2;
-
+
@parms = @$VAR1;
use strict;
-
+
my $i = 0;
-
+
foreach (@parms) {
if (/^\$VAR1/) {
no strict;
eval;
-
+
$parms[$i++] = $VAR1;
use strict;
} else {
@parms = ();
} else {
my $errmsg = "Garbled command line: '$line'";
-
+
if ($self->{clearquest}) {
$self->{clearquest}->{errnbr} = -1;
$self->{clearquest}->{errmsg} = $errmsg;
} else {
print "$errmsg\n";
} # if
-
+
$self->_printStatus ($client);
-
+
return;
} # if
-
+
$self->_debug ("Processing command $call @parms");
-
+
last if $self->_processCommand ($client, $call, @parms);
} # while
-
+
return;
} # _serviceClient
my ($self, $newValue) = @_;
my $oldValue = $self->{multithreaded};
-
+
$self->{multithreaded} = $newValue if $newValue;
-
+
return $oldValue
} # multithreaded
$self->_verbose ("Disconnected from client $self->{clientname}")
if $self->{clientname};
-
+
undef $self->{clientname};
-
+
return;
} # disconnectFromClient
sub DESTROY () {
my ($self) = @_;
-
- $self->disconnectFromClient;
-
+
+ $self->disconnectFromClient;
+
if ($self->{socket}) {
- close $self->{socket};
-
- undef $self->{socket};
- } # if
+ close $self->{socket};
+
+ undef $self->{socket};
+ } # if
} # DESTROY
-
+
sub startServer () {
my ($self) = @_;
-
+
# Create new socket to communicate to clients with
$self->{socket} = IO::Socket::INET->new (
Proto => 'tcp',
# Announce ourselves
$self->_log (__PACKAGE__ . " V$VERSION accepting clients at " . localtime);
-
+
$SIG{HUP} = \&_endServer;
-
+
# Now wait for an incoming request
my $client;
} else {
error "Accept called failed (Error: $?) - $!", 1;
} # if
- } # if
-
+ } # if
+
my $hostinfo = gethostbyaddr $client->peeraddr;
-
+
$self->{clientname} = $hostinfo ? $hostinfo->name : $client->peerhost;
$self->_verbose ("$self->{clientname} is requesting service");
error "Can't fork: $!"
unless defined ($childpid = fork);
-
+
if ($childpid) {
$self->{pid} = $$;
} else {
# In child process - ServiceClient
$self->{pid} = $$;
-
+
# Now exec the caller but set STDIN to be the socket. Also pass
# -serviceClient to the caller which will need to handle that and call
# _serviceClient.
$self->_debug ("Client: $client");
open STDIN, '+<&', $client
or croak "Unable to dup client";
-
+
my $cmd = "cqperl \"$FindBin::Bin/$FindBin::Script -serviceClient=$self->{clientname} -verbose -debug";
-
+
$self->_debug ("Execing: $cmd");
-
+
exec 'cqperl', "\"$FindBin::Bin/$FindBin::Script\"", "-serviceClient=$self->{clientname}", '-verbose', '-debug'
or croak "Unable to exec $cmd";
} # if
$self->_serviceClient ($client);
} # if
} # while
-
+
# On Windows we can't catch SIGCHLD so we need to loop around. Ugly!
goto LOOP if $^O =~ /win/i;
} # startServer
projects / clearscm.git / blobdiff