defaria.com/Computers/code/bin/clearquest/cqc.pm

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