cq/cqd/cqc.pm

   1 #!/usr/bin/perl
   2 ################################################################################
   3 #
   4 # File:         cqc.pm,v
   5 # Revision:     1.1.1.1
   6 # Description:  Perl Module interface to cqd (ClearQuest Daemon). This is used
   7 #               by cqc and cgi script to talk to cqd.
   8 # Author:       Andrew@DeFaria.com
   9 # Created:      Fri May 31 15:34:50  2002
  10 # Modified:     2007/05/17 07:45:48
  11 # Language:     Perl
  12 #
  13 # (c) Copyright 2007, ClearSCM, Inc., all rights reserved.
  14 #
  15 ################################################################################
  16 use IO::Socket;
  17
  18 package cqc;
  19   require (Exporter);
  20   @ISA = qw (Exporter);
  21
  22   @EXPORT = qw (
  23     Connect
  24     GetBugRecord
  25     Disconnect
  26     %fields
  27     $command
  28     $verbose
  29   );
  30
  31   my $host;
  32   my $port = 1500;
  33   my $command;
  34   my $default_server = "sons-clearcase";
  35   my $verbose;
  36
  37   BEGIN {
  38     my $cqcversion = "1.0";
  39
  40     # Reopen STDOUT. This is because cqperl screws around with STDOUT in some
  41     # weird fashion
  42     open STDOUT, ">-" or die "Unable to reopen STDOUT\n";
  43     # Set unbuffered output for the same reason (cqperl)
  44     $| = 1;
  45   } # BEGIN
  46
  47   sub verbose {
  48     print "@_\n" if defined ($verbose);
  49   } # verbose
  50
  51   sub Connect {
  52     my $host = shift;
  53
  54     my $result;
  55
  56     if (!defined ($host)) {
  57       $host = "localhost";
  58     } # if
  59
  60     $cqserver = ConnectToServer ($host);
  61
  62     if ($cqserver) {
  63       verbose "Connected to $host";
  64       SendServerAck ($cqserver);
  65     } # if
  66
  67     return $cqserver;
  68   } # Connect
  69
  70   sub Disconnect {
  71     my $msg;
  72     if ($cqserver) {
  73       if ($cqc::command eq "shutdown") {
  74         $msg = "Disconnected from server - shutdown server";
  75       } else {
  76         $cqc::command = "quit";
  77         $msg          = "Disconnected from server";
  78       } # if
  79       SendServerCmd ($cqserver, $cqc::command);
  80       GetServerAck  ($cqserver);
  81       verbose "$msg";
  82       close ($cqserver);
  83       undef $cqserver;
  84     } # if
  85   } # Disconnect
  86
  87   sub GetBugRecord {
  88     my $bugid  = shift;
  89     %fields = @_;
  90
  91     my $result;
  92
  93     if (!$cqserver) {
  94       verbose "Not connected to server yet!\n";
  95       verbose "Attempting connection to $default_server...\n";
  96       $result = Connect ($default_server);
  97       return -1 if !defined ($result);
  98     } # if
  99
 100     SendServerCmd               ($cqserver, $bugid);
 101     GetServerAck                ($cqserver);
 102     $result = GetServerResponse ($cqserver, %fields);
 103     SendServerAck               ($cqserver);
 104
 105     return $result;
 106   } # GetBugRecord
 107
 108   END {
 109     Disconnect;
 110   } # END
 111
 112   sub ConnectToServer {
 113     my $host = shift;
 114
 115     # create a tcp connection to the specified host and port
 116     return IO::Socket::INET->new(Proto     => "tcp",
 117                                  PeerAddr  => $host,
 118                                  PeerPort  => $port);
 119   } # ConnectToServer
 120
 121   sub SendServerAck {
 122     my $server = shift;
 123
 124     print $server "ACK\n";
 125   } # SendServerAck
 126
 127   sub GetServerAck {
 128     my $server = shift;
 129     my $srvresp;
 130
 131     while (defined ($srvresp = <$server>)) {
 132       chomp $srvresp;
 133       if ($srvresp eq "ACK") {
 134         return;
 135       } # if
 136       print "Received $srvresp from server - expected ACK\n";
 137     } # while
 138   } # GetServerAck
 139
 140   sub GetServerResponse {
 141     my $server = shift;
 142     %fields    = @_;
 143
 144     %fields = ();
 145     my $srvresp;
 146     my $result = 0;
 147
 148     while (defined ($srvresp = <$server>)) {
 149       chomp $srvresp;
 150       last if $srvresp eq "ACK";
 151       if ($srvresp =~ m/Bug ID.*was not found/) {
 152         $result = 1;
 153       } else {
 154         $srvresp =~ /(^\w+):\s+(.*)/s;
 155         $fields {$1} = $2;
 156       } # if
 157     } # while
 158
 159     return $result;
 160   } # GetServerResponse
 161
 162   sub SendServerCmd {
 163     my $server  = shift;
 164     my $command = shift;
 165
 166     print $server "$command\n";
 167   } # SendServerCmd
 168
 169 1;