lib/Clearquest/Client.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: Client.pm,v $
   4
   5 Clearquest client - Provide access to a running Clearquest server
   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.8 $
  18
  19 =item Created
  20
  21 Monday, October 10, 2011  5:02:07 PM PDT
  22
  23 =item Modified
  24
  25 $Date: 2013/05/30 15:43:28 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Provides an interface to a running Clearquest Server over the network. This
  32 means that you can use any Perl you like, not just cqperl, and you don't need
  33 to have Clearquest installed locally. In fact you can run from say Linux and
  34 talk to the Clearquest Server running on Windows.
  35
  36 =head1 DESCRIPTION
  37
  38 The server allows both read and write access to a Clearquest database as defined
  39 in cqdservice.conf file. Note the username/password must be of a user who can
  40 write to 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::Client;
  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 ":sys_wait_h";
  72 use Data::Dumper;
  73
  74 use Clearquest;
  75
  76 use parent 'Clearquest';
  77
  78 $Data::Dumper::Indent = 0;
  79
  80 our $VERSION  = '$Revision: 2.8 $';
  81    ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
  82
  83 =pod
  84
  85 =head1 Options
  86
  87 Options are keep in the cq.conf file in the etc directory. They specify the
  88 default options listed below. Or you can export the option name to the env(1) to
  89 override the defaults in cq.conf. Finally you can programmatically set the
  90 options when you call new by passing in a %parms hash. The items below are the
  91 key values for the hash.
  92
  93 =for html <blockquote>
  94
  95 =over
  96
  97 =item CQ_SERVER
  98
  99 The CQ Server host to connect to
 100
 101 =item CQ_PORT
 102
 103 Port number to contact the server at (Default: From cq.conf)
 104
 105 =item CQ_USERNAME
 106
 107 User name to connect as (Default: From cq.conf)
 108
 109 =item CQ_PASSWORD
 110
 111 Password for CQ_USERNAME
 112
 113 =item CQ_DATABASE
 114
 115 Name of database to connect to (Default: From cq.conf)
 116
 117 =item CQ_DBSET
 118
 119 Database Set name (Default: From cq.conf)
 120
 121 =back
 122
 123 =cut
 124
 125 sub _parseCmd ($) {
 126   my ($self, $cmd) = @_;
 127 } # _parseCmd
 128
 129 sub _request ($;@) {
 130   my ($self, $call, @parms) = @_;
 131
 132   my $server = $self->{socket};
 133
 134   my $request = $call;
 135
 136   $request .= ' ';
 137   $request .= Dumper \@parms;
 138   $request .= "\n";
 139
 140   # Send request
 141   print $server $request;
 142
 143   # Get response
 144   my ($response, $status, @output);
 145
 146   while (defined ($response = <$server>)) {
 147     if ($response =~ /Clearquest::Server Status: (-*\d+)/) {
 148       $status = $1;
 149       last;
 150     } # if
 151
 152     chomp $response; chop $response if $response =~ /\r$/;
 153
 154     push @output, $response;
 155   } # while
 156
 157   unless (@output) {
 158     push @output, 'Unknown or unhandled error';
 159
 160     $status = -1;
 161   } # unless
 162
 163   $self->_setError (join ("\n", @output), $status) if $status;
 164
 165   return ($status, @output);
 166 } # _request
 167
 168 sub add ($$;@) {
 169   my ($self, $table, $values, @ordering) = @_;
 170
 171   my @parms;
 172
 173   push @parms, $table, Dumper ($values), @ordering;
 174
 175   $self->_request ('add', @parms);
 176
 177   return $self->errmsg;
 178 } # add
 179
 180 sub connect (;$$$$) {
 181   my ($self, $username, $password, $database, $dbset) = @_;
 182
 183   return $self->connectToServer;
 184 } # connect
 185
 186 sub connectToServer (;$$) {
 187   my ($self, $server, $port) = @_;
 188
 189   $self->{socket} = IO::Socket::INET->new (
 190     Proto    => 'tcp',
 191     PeerAddr => $self->{server},
 192     PeerPort => $self->{port},
 193   );
 194
 195   unless ($self->{socket}) {
 196     $self->_setError ($!, 1);
 197
 198     return;
 199   } # unless
 200
 201   $self->{socket}->autoflush;
 202
 203   # Now tell the server what database we wish to use
 204   my ($status, @output) = $self->_request (
 205     'open',
 206     $self->{database},
 207     $self->{username},
 208     $self->{password},
 209     $self->{dbset},
 210   );
 211
 212   $self->{loggedin} = $status == 0;
 213
 214   $self->_setError (@output, $status);
 215
 216   return $self->connected;
 217 } # connectToServer
 218
 219 sub dbsets () {
 220   my ($self) = @_;
 221
 222   my ($status, @output) = $self->_request ('dbsets');
 223
 224   return @output;
 225 } # dbsets
 226
 227 sub delete ($$) {
 228   my ($self, $table, $key) = @_;
 229
 230   my @parms;
 231
 232   push @parms, $table;
 233   push @parms, $key;
 234
 235   my ($status, @output) = $self->_request ('delete', @parms);
 236
 237   return $self->errmsg;
 238 } # delete
 239
 240 sub DESTROY () {
 241   my ($self) = @_;
 242
 243   $self->disconnectFromServer;
 244 } # DESTROY
 245
 246 sub disconnect () {
 247   my ($self) = @_;
 248
 249   $self->disconnectFromServer;
 250
 251   $self->{loggedin} = 0;
 252
 253   return;
 254 } # disconnect
 255
 256 sub disconnectFromServer () {
 257   my ($self) = @_;
 258
 259   if ($self->{socket}) {
 260     $self->_request ('end');
 261
 262     close $self->{socket};
 263
 264     undef $self->{socket};
 265   } # if
 266
 267   return;
 268 } # disconnectFromServer
 269
 270 sub find ($;$@) {
 271   my ($self, $table, $condition, @fields) = @_;
 272
 273   $condition ||= '';
 274
 275   # TODO: Need to return nbrrecs
 276   my ($status, @output) = $self->_request ('find', $table, $condition, @fields);
 277
 278   if ($self->error) {
 279     return (undef, $self->errmsg);
 280   } else {
 281     return ($status, $output[1]);
 282   } # if
 283 } # find
 284
 285 sub get ($$@) {
 286   my ($self, $table, $key, @fields) = @_;
 287
 288   my %record;
 289
 290   $self->_setError ('', 0);
 291
 292   my ($status, @output) = $self->_request ('get', $table, $key, @fields);
 293
 294   return if $status;
 295
 296   foreach (@output) {
 297     my ($field, $value) = split /\@\@/;
 298
 299     $value =~ s/&#10;/\n/g;
 300
 301     if ($record{$field}) {
 302       if (ref $record{$field} ne 'ARRAY') {
 303         my $valueOne = $record{$field};
 304
 305         $record{$field} = ();
 306
 307         push @{$record{$field}}, $valueOne, $value;
 308       } else {
 309         push @{$record{$field}}, $value;
 310       } # if
 311     } else {
 312       $record{$field} = $value;
 313     } # if
 314   } # foreach
 315
 316   return %record;
 317 } # get
 318
 319 sub getDBID ($$@) {
 320   my ($self, $table, $dbid, @fields) = @_;
 321
 322   my %record = ();
 323
 324   my ($status, @output) = $self->_request ('getDBID', $table, $dbid, @fields);
 325
 326   return ($status, %record) if $status;
 327
 328   foreach (@output) {
 329     my ($field, $value) = split /\@\@/;
 330
 331     $value =~ s/&#10;/\n/g;
 332
 333     if ($record{$field}) {
 334       if (ref $record{$field} ne 'ARRAY') {
 335         my $valueOne = $record{$field};
 336
 337         $record{$field} = ();
 338
 339         push @{$record{$field}}, $valueOne, $value;
 340       } else {
 341         push @{$record{$field}}, $value;
 342       } # if
 343     } else {
 344       $record{$field} = $value;
 345     } # if
 346   } # foreach
 347
 348   return %record;
 349 } # getDBID
 350
 351 sub getDynamicList ($) {
 352   my ($self, $list) = @_;
 353
 354   my ($status, @output) = $self->_request ('getDynamicList', $list);
 355
 356   return @output;
 357 } # getDynamicList
 358
 359 sub getNext ($) {
 360   my ($self, $result) = @_;
 361
 362   my ($status, @output) = $self->_request ('getNext', ());
 363
 364   return if $status;
 365
 366   my %record;
 367
 368   foreach (@output) {
 369     my ($field, $value) = split /\@\@/;
 370
 371     $value =~ s/&#10;/\n/g;
 372
 373     if ($record{$field}) {
 374       if (ref $record{$field} ne 'ARRAY') {
 375         push @{$record{$field}}, $record{$field}, $value;
 376       } else {
 377         push @{$record{$field}}, $value;
 378       } # if
 379     } else {
 380       $record{$field} = $value;
 381     } # if
 382   } # foreach
 383
 384   return %record;
 385 } # getNext
 386
 387 sub key ($$) {
 388   my $self = shift;
 389
 390   my ($status, @output) = $self->_request ('key', @_);
 391
 392   return $output[0];
 393 } # key
 394
 395 sub modify ($$$$;@) {
 396   my ($self, $table, $key, $action, $values, @ordering) = @_;
 397
 398   $action ||= 'Modify';
 399
 400   my @parms;
 401
 402   push @parms, $table, $key, $action, Dumper ($values), @ordering;
 403
 404   $self->_request ('modify', @parms);
 405
 406   return $self->errmsg;
 407 } # modify
 408
 409 sub modifyDBID ($$$$;@) {
 410   my ($self, $table, $dbid, $action, $values, @ordering) = @_;
 411
 412   my @parms;
 413
 414   push @parms, $table, $dbid, $action, Dumper ($values), @ordering;
 415
 416   $self->_request ('modifyDBID', @parms);
 417
 418   return $self->errmsg;
 419 } # modifyDBID
 420
 421 sub port () {
 422   my ($self) = @_;
 423
 424   return $self->{port};
 425 } # port
 426
 427 sub new () {
 428   my ($class, $self) = @_;
 429
 430   $$self{server} ||= $Clearquest::OPTS{CQ_SERVER};
 431   $$self{port}   ||= $Clearquest::OPTS{CQ_PORT};
 432
 433   bless $self, $class;
 434 } # new
 435
 436 sub shutdown () {
 437   my ($self) = @_;
 438
 439   if ($self->{socket}) {
 440     $self->_request ('shutdown');
 441   } # if
 442 } # shutdown
 443
 444 1;
 445
 446 =pod
 447
 448 =head1 CONFIGURATION AND ENVIRONMENT
 449
 450 DEBUG: If set then $debug is set to this level.
 451
 452 VERBOSE: If set then $verbose is set to this level.
 453
 454 TRACE: If set then $trace is set to this level.
 455
 456 =head1 DEPENDENCIES
 457
 458 =head2 Perl Modules
 459
 460 L<Carp>
 461
 462 L<File::Basename|File::Basename>
 463
 464 L<FindBin>
 465
 466 L<IO::Socket|IO::Socket>
 467
 468 L<Net::hostent|Net::hostent>
 469
 470 L<POSIX>
 471
 472 =head2 ClearSCM Perl Modules
 473
 474 =begin man
 475
 476  DateUtils
 477  Display
 478  GetConfig
 479
 480 =end man
 481
 482 =begin html
 483
 484 <blockquote>
 485 <a href="http://clearscm.com/php/cvs_man.php?file=lib/DateUtils.pm">DateUtils</a><br>
 486 <a href="http://clearscm.com/php/cvs_man.php?file=lib/Display.pm">Display</a><br>
 487 <a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
 488 </blockquote>
 489
 490 =end html
 491
 492 =head1 SEE ALSO
 493
 494 =head1 BUGS AND LIMITATIONS
 495
 496 There are no known bugs in this module.
 497
 498 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
 499
 500 =head1 LICENSE AND COPYRIGHT
 501
 502 Copyright (c) 2011, ClearSCM, Inc. All rights reserved.
 503
 504 =cut