Provides an interface to the Clearquest database over the network.
-This library implements both the daemon portion of the server and the client
+This library implements both the daemon portion of the server and the client
API.
=head1 DESCRIPTION
A hash is passed into to the execute method, which the client should use to talk
to the server, that describes relatively simple protocol to tell the server what
action to perform. In both the read case and the read/write case a field named
-id should be defined that has a value of "<record>=<id>" (e.g.
+id should be defined that has a value of "<record>=<id>" (e.g.
"defect=BUGDB00034429").
For the read case the rest of the keys are the names of the fields to retrieve
value pairs of fields to set and their values.
Execute returns a status and a hash of name value pairs for the read case and an
-array of lines for any error messages for the read/write case.
+array of lines for any error messages for the read/write case.
=head1 ROUTINES
our $VERSION = '$Revision: 1.2 $';
($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
-
+
# Override options if in the environment
$OPTS{CQD_HOST} = $ENV{CQD_HOST}
if $ENV{CQD_HOST};
my $tag = YMDHMS;
$tag .= ' ';
$tag .= $self->{pid} ? "[$self->{pid}] " : '';
-
+
return "$tag$msg";
} # _tag
-sub _verbose ($) {
+ sub _verbose ($) {
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
while (my $childpid = waitpid (-1, WNOHANG) > 0) {
my $status = $?;
-
+
debug "childpid: $childpid - status: $status";
-
+
if ($childpid != -1) {
local $SIG{CHLD} = \&_funeral;
debug "All children reaped";
} # if
} # while
-
+
return;
} # _funeral
sub _endServer () {
display "CQDService V$VERSION shutdown at " . localtime;
-
+
# Kill process group
kill 'TERM', -$$;
-
+
# Wait for all children to die
while (wait != -1) {
# do nothing
- } # while
-
+ } # 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
$host ||= $OPTS{CQD_HOST};
$port ||= $OPTS{CQD_PORT};
-
+
$self->{socket} = IO::Socket::INET->new (
Proto => 'tcp',
PeerAddr => $host,
);
return unless $self->{socket};
-
+
$self->{socket}->autoflush;
$self->{host} = $host;
if ($self->{socket}) {
close $self->{socket};
-
+
undef $self->{socket};
} # if
-
+
return;
} # disconnectFromServer
# Set autoflush for client
$client->autoflush
if $client;
-
+
# Input is simple and consists of the following:
#
# <recordType>=<ID>
#
# Notes: <ID> can be <ID_scope>. Also a += means append this fieldvalue to
# the existing value for the field.
-
+
# First get record line
my $line = <$client>;
-
+
if ($line) {
chomp $line; chop $line if $line =~ /\r$/;
} else {
$self->_verbose ("Host $host went away!");
-
+
close $client;
-
+
return;
} # if
-
+
if ($line =~ /stopserver/i) {
if ($self->{server}) {
$self->_verbose ("$host requested to stop server [$self->{server}]");
-
+
# Send server hangup signal
kill 'HUP', $self->{server};
} else {
$self->_verbose ('Shutting down server');
-
+
print $client "CQDService Status: 0\n";
-
+
exit;
} # if
} # if
my ($record, $id) = split /=/, $line;
-
+
unless ($id) {
$self->_verbose ('Garbled record line - rejected request');
-
+
close $client;
-
+
return;
} # unless
-
+
$self->_verbose ("Client wishes to deal with $id");
-
+
my $scope;
-
+
if ($id =~ /_(\S+)/) {
$scope = $1;
} # if
-
+
$self->_debug ("$host wants $record:$id");
-
+
my ($read, %fields);
-
- # Now read name/value pairs
+
+ # Now read name/value pairs
while () {
# Read command from client
- $line = <$client>;
-
+ $line = <$client>;
+
if ($line) {
chomp $line; chop $line if $line =~ /\r$/;
} else {
$self->_verbose ("Host $host went away!");
-
+
close $client;
-
+
return;
} # if
# Collect name/values. Note if only names are requested then we will instead
# return data.
my ($name, $value) = split /=/, $line;
-
+
if ($value) {
# Transform %0A's back to \n
$value =~ s/\%0A/\n/g;
-
+
$self->_verbose ("Will set $name to $value");
} else {
$read = 1;
$self->_verbose ("Will retrieve $name");
- } # if
-
+ } # if
+
$fields{$name} = $value;
} # while
-
+
# Get record
my $entity;
-
+
$self->_verbose ("Getting $record:$id");
-
+
eval { $entity = $self->{session}->GetEntity ($record, $id) };
-
+
unless ($entity) {
print $client "Unable to GetEntity $record:$id\n";
-
+
close $client;
-
+
return;
} # unless
if ($read) {
print $client "$_@@" . $entity->GetFieldValue ($_)->GetValue . "\n"
- foreach (keys %fields);
+ for (keys %fields);
print $client "CQD Status: 0\n";
-
+
close $client;
-
+
return;
} # if
-
+
# Edit record
$self->_verbose ("Editing $id");
-
+
$entity->EditEntity ('Backend');
-
+
my $status;
-
- foreach my $fieldName (keys %fields) {
+
+ for my $fieldName (keys %fields) {
if ($fieldName =~ /(.+)\*$/) {
my $newValue = delete $fields{$fieldName};
$fieldName = $1;
-
+
$fields{$fieldName} = $entity->GetFieldValue ($fieldName)->GetValue
. $newValue;
} # if
$self->_verbose ("Setting $fieldName to $fields{$fieldName}");
-
+
$status = $entity->SetFieldValue ($fieldName, $fields{$fieldName});
-
+
if ($status ne '') {
$self->_verbose ($status);
-
+
print $client "$status\n";
print $client "CQD Status: 1\n";
-
+
close $client;
-
+
return;
} # if
- } # foreach
-
+ } # for
+
$self->_verbose ("Validating $id");
-
+
$status = $entity->Validate;
-
+
if ($status eq '') {
$self->_verbose ('Committing');
$entity->Commit;
-
+
print $client "Successfully updated $id\n";
print $client "CQD Status: 0\n";
} else {
print $client "$status\n";
print $client "CQD Status: 1\n";
} # if
-
+
close $client;
-
+
$self->_verbose ("Serviced requests from $host");
-
+
return;
} # _serviceClient
sub execute (%) {
my ($self, %request) = @_;
-
+
$self->connectToServer or croak 'Unable to connect to CQD Service';
return (-1, 'Unable to talk to server')
unless $self->{socket};
-
+
my ($status, @output) = (-1, ());
-
+
my $server = $self->{socket};
-
+
my $id = delete $request{id};
-
+
print $server "$id\n";
-
+
my $read;
-
- foreach (keys %request) {
+
+ for (keys %request) {
if ($request{$_}) {
print $server "$_=$request{$_}\n";
} else {
$read = 1;
print $server "$_\n";
} # if
- } # foreach
+ } # for
print $server "end\n";
-
+
my ($response, %output);
-
+
while (defined ($response = <$server>)) {
if ($response =~ /CQD Status: (-*\d+)/) {
$status = $1;
last;
} # if
-
+
if ($read) {
chomp $response; chop $response if $response =~ /\r$/;
-
+
my ($field, $value) = split /\@\@/, $response;
-
+
$output{$field} = $value;
} else {
push @output, $response;
} # if
} # while
-
+
chomp @output unless $read;
-
+
$self->disconnectFromServer;
-
+
if ($status != 0 or $read == 0) {
return ($status, @output);
} else {
} # execute
sub startServer (;$$$$$) {
-
+
require 'Clearquest.pm';
-
+
my ($self, $port, $username, $password, $db, $dbset) = @_;
$port ||= $OPTS{CQD_PORT};
$password ||= $OPTS{CQD_PASSWORD};
$db ||= $OPTS{CQD_DATABASE};
$dbset ||= $OPTS{CQD_DBSET};
-
+
# Create new socket to communicate to clients with
$self->{socket} = IO::Socket::INET->new(
Proto => 'tcp',
# Announce ourselves
$self->_log ("CQD V$VERSION accepting clients at " . localtime);
-
+
# Now wait for an incoming request
LOOP:
my $client;
error "Can't fork: $!"
unless defined ($childpid = fork);
-
+
if ($childpid) {
$self->{pid} = $$;
=head2 ClearSCM Perl Modules
-=begin man
+=begin man
DateUtils
Display
projects / clearscm.git / blobdiff