lib/Clearquest.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: Clearquest.pm,v $
   4
   5 Object oriented interface to Clearquest.
   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.23 $
  18
  19 =item Created
  20
  21 Fri Sep 22 09:21:18 CDT 2006
  22
  23 =item Modified
  24
  25 $Date: 2013/03/28 22:48:07 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Provides access to Clearquest database in an object oriented manner.
  32
  33  # Create Clearquest object
  34  my $cq = Clearquest->new;
  35
  36  # Connect to database (using all the defaults in cq.conf)
  37  $cq->connect;
  38
  39  # Connect as non standard user;
  40
  41  $cq->connect (CQ_USERNAME => 'me', CQ_PASSWORD => 'mypassword');
  42
  43  # Get record (Default: all fields)
  44  my %record = $cq->get ($recordName, $key);
  45
  46  # Get record with specific field list
  47  my %record =$cq->get ($recordName, $key, qw(field1 field2))
  48
  49  # Modify a record
  50  my %update = (
  51    Description => 'This is a new description',
  52    Active      => 1,
  53  );
  54  $cq->modify ($recordName, $key, 'Modify', \%update);
  55
  56  # Change state using modify with an alternate action. Note the use of @ordering
  57  my %fieldsToUpdate = (
  58    Project  => 'Carrier',
  59    Category => 'New Functionality',
  60    Groups   => [ 'Group1', 'Group2' ],
  61  );
  62
  63  my @ordering qw(Project Category);
  64
  65  $cq->modify ($recordName, $key, 'Open', \%fieldsToUpdate, @ordering);
  66
  67  if ($cq->error) {
  68    error "Unable to update $key to Opened state\n"
  69        . $cq->errmsg;
  70  } # if
  71
  72 =head1 DESCRIPTION
  73
  74 This module provides a simple interface to Clearquest in a Perl like fashion.
  75 There are three modes of talking to Clearquest using this module - api, rest
  76 and client.
  77
  78 With module = 'api' you must have Clearquest installed locally and you must use
  79 cqperl to execute your script. This mode of operation has the benefit of speed -
  80 note that initial connection to the Clearquest database is not very speedy, but
  81 all subsequent calls will operate at full speed. The 'api' module is free to
  82 use. For the other modules contact ClearSCM, Inc.
  83
  84 With module = 'rest' you can access Clearquest by using a RESTFull interface.
  85 You can use any Perl which has the required CPAN modules (REST, XML::Simple -
  86 see Clearquest::REST for a list of required CPAN modules). The REST interface is
  87 a slower than the native api and requires the setup of Clearquest Web (cqweb) on
  88 your network. To use the REST interface set CQ_MODULE to 'rest'.
  89
  90 With module = 'client' you access Clearquest through the companion
  91 Clearquest::Server module and the cqd.pl server script. The server process is
  92 started on a machine that has Clearquest installed locally. It uses the api
  93 interface for speed and can operate in a multithreaded manner, spawning
  94 processes which open and handle requests from Clearquest::Client requests. To
  95 use the Client interface set CQ_MODULE to 'client'.
  96
  97 Other than setting CQ_MODULE to one of the three modes described above, the rest
  98 of your script's usage of the Clearquest module should be exactly the same.
  99
 100 =head1 CONFIGURATION
 101
 102 This module uses GetConfig to read in a configuration file (../etc/cq.conf)
 103 which sets default values described below. Or you can export the option name to
 104 the env(1) to override the defaults in cq.conf. Finally you can programmatically
 105 set the options when you call new by passing in a %parms hash. To specify the
 106 %parms hash key remove the CQ_ portion and lc the rest.
 107
 108 =for html <blockquote>
 109
 110 =over
 111
 112 =item CQ_SERVER
 113
 114 Clearquest server to talk to. Also used for rest server (Default: From cq.conf)
 115
 116 =item CQ_PORT
 117
 118 Port to connect to (Default: From cq.conf)
 119
 120 =item CQ_WEBHOST
 121
 122 The web host to contact with leading http:// (Default: From cq.conf)
 123
 124 =item CQ_DATABASE
 125
 126 Name of database to connect to (Default: From cq.conf)
 127
 128 =item CQ_USERNAME
 129
 130 User name to connect as (Default: From cq.conf)
 131
 132 =item CQ_PASSWORD
 133
 134 Password for CQREST_USERNAME (Default: From cq.conf)
 135
 136 =item CQ_DBSET
 137
 138 Database Set name (Default: From cq.conf)
 139
 140 =item CQ_MODULE
 141
 142 One of 'api', 'rest' or 'client' (Default: From cq.conf)
 143
 144 =back
 145
 146 =head1 METHODS
 147
 148 The following methods are available:
 149
 150 =cut
 151
 152 package Clearquest;
 153
 154 use strict;
 155 use warnings;
 156
 157 use File::Basename;
 158 use Carp;
 159 use Time::Local;
 160
 161 use GetConfig;
 162
 163 # Seed options from config file
 164 my $config = $ENV{CQ_CONF} || dirname (__FILE__) . '/../etc/cq.conf';
 165
 166 croak "Unable to find config file $config" unless -r $config;
 167
 168 our %OPTS = GetConfig $config;
 169
 170 my $DEFAULT_DBSET = $OPTS{CQ_DBSET};
 171
 172 our $VERSION  = '$Revision: 2.23 $';
 173    ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
 174
 175 # Override options if in the environment
 176 $OPTS{CQ_DATABASE} = $ENV{CQ_DATABASE} if $ENV{CQ_DATABASE};
 177 $OPTS{CQ_DBSET}    = $ENV{CQ_DBSET}    if $ENV{CQ_DBSET};
 178 $OPTS{CQ_MODULE}   = $ENV{CQ_MODULE}   if $ENV{CQ_MODULE};
 179 $OPTS{CQ_PASSWORD} = $ENV{CQ_PASSWORD} if $ENV{CQ_PASSWORD};
 180 $OPTS{CQ_PORT}     = $ENV{CQ_PORT}     if $ENV{CQ_PORT};
 181 $OPTS{CQ_SERVER}   = $ENV{CQ_SERVER}   if $ENV{CQ_SERVER};
 182 $OPTS{CQ_USERNAME} = $ENV{CQ_USERNAME} if $ENV{CQ_USERNAME};
 183
 184 # FieldTypes ENUM
 185 our $UNKNOWN          = -1;
 186 our $STRING           = 1;
 187 our $MULTILINE_STRING = 2;
 188 our $INT              = 3;
 189 our $DATE_TIME        = 4;
 190 our $REFERENCE        = 5;
 191 our $REFERENCE_LIST   = 6;
 192 our $ATTACHMENT_LIST  = 7;
 193 our $ID               = 8;
 194 our $STATE            = 9;
 195 our $JOURNAL          = 10;
 196 our $DBID             = 11;
 197 our $STATETYPE        = 12;
 198 our $RECORD_TYPE      = 13;
 199
 200 my %FIELDS;
 201
 202 my @objects;
 203
 204 my $SECS_IN_MIN  = 60;
 205 my $SECS_IN_HOUR = $SECS_IN_MIN * 60;
 206 my $SECS_IN_DAY  = $SECS_IN_HOUR * 24;
 207
 208 my $operatorRE = qr/
 209   (\w+)              # field name
 210   \s*                # whitespace
 211   (                  # operators
 212     ==               # double equals
 213     |=               # single equals
 214     |!=              # not equal
 215     |<>              # the other not equal
 216     |<=              # less than or equal
 217     |>=              # greater than or equal
 218     |<               # less than
 219     |>               # greater than
 220     |like            # like
 221     |not\s+like      # not like
 222     |between         # between
 223     |not\s*between   # not between
 224     |is\s+null       # is null
 225     |is\s+not\s+null # is not null
 226     |in              # in
 227     |not\s+in        # not in
 228   )
 229   \s*                # whitespace
 230   (.*)               # value
 231   /ix;
 232
 233 END {
 234   # Insure all instaniated objects have been destroyed
 235   $_->DESTROY for (@objects);
 236 } # END
 237
 238 # Internal methods
 239 sub _commitRecord($) {
 240   my ($self, $entity) = @_;
 241
 242   $self->{errmsg} = $entity->Validate;
 243
 244   if ($self->{errmsg} eq '') {
 245     $self->{errmsg} = $entity->Commit;
 246     $self->{error}  = $self->{errmsg} eq '' ? 0 : 1;
 247
 248     return $self->{errmsg};
 249   } else {
 250     $self->{error} = 1;
 251
 252     $entity->Revert;
 253
 254     return $self->{errmsg};
 255   } # if
 256 } # _commitRecord
 257
 258 sub _is_leap_year($) {
 259   my ($year) = @_;
 260
 261   return 0 if $year % 4;
 262   return 1 if $year % 100;
 263   return 0 if $year % 400;
 264
 265   return 1;
 266 } # _is_leap_year
 267
 268 sub _dateToEpoch($) {
 269   my ($date) = @_;
 270
 271   my $year    = substr $date,  0, 4;
 272   my $month   = substr $date,  5, 2;
 273   my $day     = substr $date,  8, 2;
 274   my $hour    = substr $date, 11, 2;
 275   my $minute  = substr $date, 14, 2;
 276   my $seconds = substr $date, 17, 2;
 277
 278   my $days;
 279
 280   for (my $i = 1970; $i < $year; $i++) {
 281     $days += _is_leap_year ($i) ? 366 : 365;
 282   } # for
 283
 284   my @monthDays = (
 285     0,
 286     31,
 287     59,
 288     90,
 289     120,
 290     151,
 291     181,
 292     212,
 293     243,
 294     273,
 295     304,
 296     334,
 297   );
 298
 299   $days += $monthDays[$month - 1];
 300
 301   $days++
 302     if _is_leap_year ($year) and $month > 2;
 303
 304  $days += $day - 1;
 305
 306   return ($days   * $SECS_IN_DAY)
 307        + ($hour   * $SECS_IN_HOUR)
 308        + ($minute * $SECS_IN_MIN)
 309        + $seconds;
 310 } # _dateToEpoch
 311
 312 sub _epochToDate($) {
 313   my ($epoch) = @_;
 314
 315   my $year = 1970;
 316   my ($month, $day, $hour, $minute, $seconds);
 317   my $leapYearSecs = 366 * $SECS_IN_DAY;
 318   my $yearSecs     = $leapYearSecs - $SECS_IN_DAY;
 319
 320   while () {
 321     my $amount = _is_leap_year ($year) ? $leapYearSecs : $yearSecs;
 322
 323     last
 324       if $amount > $epoch;
 325
 326     $epoch -= $amount;
 327     $year++;
 328   } # while
 329
 330   my $leapYearAdjustment = _is_leap_year ($year) ? 1 : 0;
 331
 332   if ($epoch >= (334 + $leapYearAdjustment) * $SECS_IN_DAY) {
 333     $month = '12';
 334     $epoch -= (334 + $leapYearAdjustment) * $SECS_IN_DAY;
 335   } elsif ($epoch >= (304 + $leapYearAdjustment) * $SECS_IN_DAY) {
 336     $month = '11';
 337     $epoch -= (304 + $leapYearAdjustment) * $SECS_IN_DAY;
 338   } elsif ($epoch >= (273 + $leapYearAdjustment) * $SECS_IN_DAY) {
 339     $month = '10';
 340     $epoch -= (273 + $leapYearAdjustment) * $SECS_IN_DAY;
 341   } elsif ($epoch >= (243 + $leapYearAdjustment) * $SECS_IN_DAY) {
 342     $month = '09';
 343     $epoch -= (243 + $leapYearAdjustment) * $SECS_IN_DAY;
 344   } elsif ($epoch >= (212 + $leapYearAdjustment) * $SECS_IN_DAY) {
 345     $month = '08';
 346     $epoch -= (212 + $leapYearAdjustment) * $SECS_IN_DAY;
 347   } elsif ($epoch >= (181 + $leapYearAdjustment) * $SECS_IN_DAY) {
 348     $month = '07';
 349     $epoch -= (181 + $leapYearAdjustment) * $SECS_IN_DAY;
 350   } elsif ($epoch >= (151 + $leapYearAdjustment) * $SECS_IN_DAY) {
 351     $month = '06';
 352     $epoch -= (151 + $leapYearAdjustment) * $SECS_IN_DAY;
 353   } elsif ($epoch >= (120 + $leapYearAdjustment) * $SECS_IN_DAY) {
 354     $month = '05';
 355     $epoch -= (120 + $leapYearAdjustment) * $SECS_IN_DAY;
 356   } elsif ($epoch >= (90 + $leapYearAdjustment) * $SECS_IN_DAY) {
 357     $month = '04';
 358     $epoch -= (90 + $leapYearAdjustment) * $SECS_IN_DAY;
 359   } elsif ($epoch >= (59 + $leapYearAdjustment) * $SECS_IN_DAY) {
 360     $month = '03';
 361     $epoch -= (59 + $leapYearAdjustment) * $SECS_IN_DAY;
 362   } elsif ($epoch >= 31 * $SECS_IN_DAY) {
 363     $month = '02';
 364     $epoch -= 31 * $SECS_IN_DAY;
 365   } else {
 366     $month = '01';
 367   } # if
 368
 369   $day     = int (($epoch / $SECS_IN_DAY) + 1);
 370   $epoch   = $epoch % $SECS_IN_DAY;
 371   $hour    = int ($epoch / $SECS_IN_HOUR);
 372   $epoch   = $epoch % $SECS_IN_HOUR;
 373   $minute  = int ($epoch / $SECS_IN_MIN);
 374   $seconds = $epoch % $SECS_IN_MIN;
 375
 376   $day     = "0$day"     if $day     < 10;
 377   $hour    = "0$hour"    if $hour    < 10;
 378   $minute  = "0$minute"  if $minute  < 10;
 379   $seconds = "0$seconds" if $seconds < 10;
 380
 381   return "$year-$month-$day $hour:$minute:$seconds";
 382 } # _epochToDate
 383
 384 sub _parseCondition($) {
 385   my ($self, $condition) = @_;
 386
 387   # Parse simple conditions only
 388   my ($field, $operator, $value);
 389
 390   if ($condition =~ $operatorRE) {
 391     $field    = $1;
 392     $operator = $2;
 393     $value    = $3;
 394
 395     if ($operator eq '==' or $operator eq '=') {
 396       if ($value !~ /^null$/i) {
 397         $operator = $CQPerlExt::CQ_COMP_OP_EQ;
 398       } else {
 399         $operator = $CQPerlExt::CQ_COMP_OP_IS_NULL;
 400       } # if
 401     } elsif ($operator eq '!=' or $operator eq '<>') {
 402       if ($value !~ /^null$/i) {
 403         $operator = $CQPerlExt::CQ_COMP_OP_NEQ;
 404       } else {
 405         $operator = $CQPerlExt::CQ_COMP_OP_IS_NOT_NULL;
 406       } # if
 407     } elsif ($operator eq '<') {
 408       $operator = $CQPerlExt::CQ_COMP_OP_LT;
 409     } elsif ($operator eq '>') {
 410       $operator = $CQPerlExt::CQ_COMP_OP_GT;
 411     } elsif ($operator eq '<=') {
 412       $operator = $CQPerlExt::CQ_COMP_OP_LTE;
 413     } elsif ($operator eq '>=') {
 414       $operator = $CQPerlExt::CQ_COMP_OP_GTE;
 415     } elsif ($operator =~ /^like$/i) {
 416       $operator = $CQPerlExt::CQ_COMP_OP_LIKE;
 417     } elsif ($operator =~ /^not\s+like$/i) {
 418       $operator = $CQPerlExt::CQ_COMP_OP_NOT_LIKE;
 419     } elsif ($operator =~ /^between$/i) {
 420       $operator = $CQPerlExt::CQ_COMP_OP_BETWEEN;
 421     } elsif ($operator =~ /^not\s+between$/i) {
 422       $operator = $CQPerlExt::CQ_COMP_OP_NOT_BETWEEN;
 423     } elsif ($operator =~ /^is\s+null$/i) {
 424       $operator = $CQPerlExt::CQ_COMP_OP_IS_NULL;
 425     } elsif ($operator =~ /^is\s+not\s+null$/i) {
 426       $operator = $CQPerlExt::CQ_COMP_OP_IS_NOT_NULL;
 427     } elsif ($operator =~ /^in$/i) {
 428       $operator = $CQPerlExt::CQ_COMP_OP_IN;
 429     } elsif ($operator =~ /^not\s+in$/) {
 430       $operator = $CQPerlExt::CQ_COMP_OP_NOT_IN;
 431     } else {
 432       $self->_setError ("I can't understand the operator $operator");
 433
 434       $operator = undef;
 435
 436       return 1;
 437     } # if
 438   } else {
 439     # TODO: How to handle more complicated $condition....
 440     $self->_setError ("I can't understand the conditional expression "
 441                     . $condition);
 442
 443     $operator = undef;
 444
 445     return 1;
 446   } # if
 447
 448   # Trim quotes if any:
 449   if ($value =~ /^\s*\'/) {
 450     $value =~ s/^\s*\'//;
 451     $value =~ s/\'\s*$//;
 452   } elsif ($value =~ /^\s*\"/) {
 453     $value =~ s/^\s*\"//;
 454     $value =~ s/\"\s*$//;
 455   } # if
 456
 457   # Trim leading and trailing whitespace
 458   $value =~ s/^\s+//;
 459   $value =~ s/\s+$//;
 460
 461   return ($field, $operator, $value);
 462 } # _parseCondition
 463
 464 sub _parseConditional($$;$);
 465 sub _parseConditional($$;$) {
 466   my ($self, $query, $condition, $filterOperator) = @_;
 467
 468   return if $condition eq '';
 469
 470   my ($field, $operator, $value);
 471
 472   if ($condition =~ /(.+?)\s+(and|or)\s+(.+)/i) {
 473     my $leftSide    = $1;
 474     my $conjunction = lc $2;
 475     my $rightSide   = $3;
 476
 477     if ($conjunction eq 'and') {
 478       unless ($filterOperator) {
 479         $filterOperator = $query->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_AND);
 480       } else {
 481         $filterOperator = $filterOperator->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_AND);
 482       } # unless
 483     } elsif ($conjunction eq 'or') {
 484       unless ($filterOperator) {
 485         $filterOperator = $query->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_OR);
 486       } else {
 487         $filterOperator = $filterOperator->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_OR);
 488       } # unless
 489     } # if
 490
 491     $self->_setCondition ($self->_parseCondition ($leftSide), $filterOperator);
 492
 493     $self->_parseConditional ($query, $rightSide, $filterOperator);
 494   } else {
 495     unless ($condition =~ $operatorRE) {
 496       $self->_setError ("Unable to parse condition \"$condition\"");
 497
 498       return;
 499     } # unless
 500
 501     $filterOperator = $query->BuildFilterOperator ($CQPerlExt::CQ_BOOL_OP_AND)
 502       unless $filterOperator;
 503
 504     $self->_setCondition ($self->_parseCondition ($condition), $filterOperator);
 505   } # if
 506
 507   # Actually clear error...
 508   $self->_setError;
 509
 510   return;
 511 } # _parseConditional
 512
 513 sub _setCondition($$$) {
 514   my ($self, $field, $operator, $value, $filterOperator) = @_;
 515
 516   return unless $operator;
 517
 518   if ($operator == $CQPerlExt::CQ_COMP_OP_IS_NULL or
 519       $operator == $CQPerlExt::CQ_COMP_OP_IS_NOT_NULL) {
 520     eval {$filterOperator->BuildFilter ($field, $operator, [()])};
 521
 522     if ($@) {
 523       $self->_setError ($@);
 524
 525       carp $@;
 526     } # if
 527   } else {
 528     # If the operator is one of the operators that have mulitple values then we
 529     # need to make an array of $value
 530     if ($operator == $CQPerlExt::CQ_COMP_OP_BETWEEN     or
 531         $operator == $CQPerlExt::CQ_COMP_OP_NOT_BETWEEN or
 532         $operator == $CQPerlExt::CQ_COMP_OP_IN          or
 533         $operator == $CQPerlExt::CQ_COMP_OP_NOT_IN) {
 534       my @values = split /,\s*/, $value;
 535
 536       eval {$filterOperator->BuildFilter ($field, $operator, \@values)};
 537
 538       if ($@) {
 539         $self->_setError ($@);
 540
 541         carp $@;
 542       } # if
 543     } else {
 544       eval {$filterOperator->BuildFilter ($field, $operator, [$value])};
 545
 546       if ($@) {
 547         $self->_setError ($@);
 548
 549         carp $@;
 550       } # if
 551     } # if
 552   } # if
 553
 554   return;
 555 } # _setCondition
 556
 557 sub _setFields($@) {
 558   my ($self, $table, @fields) = @_;
 559
 560   my $entityDef;
 561
 562   eval {$entityDef = $self->{session}->GetEntityDef ($table)};
 563
 564   if ($@) {
 565     $self->_setError ($@, -1);
 566
 567     return;
 568   } # if
 569
 570   unless (@fields) {
 571     for (@{$entityDef->GetFieldDefNames}) {
 572       unless ($self->{returnSystemFields}) {
 573         next if $entityDef->IsSystemOwnedFieldDefName ($_);
 574       } # unless
 575
 576       push @fields, $_;
 577     } # for
 578   } # unless
 579
 580   # Always return dbid
 581   push @fields, 'dbid' unless grep {$_ eq 'dbid'} @fields;
 582
 583   return @fields;
 584 } # _setFields
 585
 586 sub _setError(;$$) {
 587   my ($self, $errmsg, $error) = @_;
 588
 589   $error ||= 0;
 590
 591   if ($errmsg and $errmsg ne '') {
 592     $error = 1;
 593
 594     $self->{errmsg} = $errmsg;
 595   } else {
 596     $self->{errmsg} = '';
 597   } # if
 598
 599   $self->error ($error);
 600
 601   return;
 602 } # _setError
 603
 604 sub _setFieldValue($$$$) {
 605   my ($self, $entity, $table, $fieldName, $fieldValue) = @_;
 606
 607   my $errmsg = '';
 608
 609   my $entityDef = $self->{session}->GetEntityDef ($table);
 610
 611   return $errmsg if $entityDef->IsSystemOwnedFieldDefName ($fieldName);
 612
 613   unless (ref $fieldValue eq 'ARRAY') {
 614     # This is one of those rare instances where it is important to surround a
 615     # bare variable with double quotes otherwise the CQ API will wrongly
 616     # evaluate $fieldValue if $fieldValue is a simple number (e.g. 0, 1, etc.)
 617     $errmsg = $entity->SetFieldValue ($fieldName, "$fieldValue") if $fieldValue;
 618   } else {
 619     for (@$fieldValue) {
 620       $errmsg = $entity->AddFieldValue ($fieldName, $_);
 621
 622       return $errmsg unless $errmsg eq '';
 623     } # for
 624   } # unless
 625
 626   return $errmsg;
 627 } # _setFieldValues
 628
 629 sub _UTC2Localtime($) {
 630   my ($utcdatetime) = @_;
 631
 632   return unless $utcdatetime;
 633
 634   # If the field does not look like a UTC time then just return it.
 635   return $utcdatetime unless $utcdatetime =~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/;
 636
 637   $utcdatetime =~ s/T/ /;
 638   $utcdatetime =~ s/Z//;
 639
 640   my @localtime = localtime;
 641
 642   return _epochToDate (
 643     _dateToEpoch ($utcdatetime) + (timegm (@localtime) - timelocal (@localtime))
 644   );
 645 } # _UTC2Localtime
 646
 647 sub add($$;@) {
 648   my ($self, $table, $values, @ordering) = @_;
 649
 650 =pod
 651
 652 =head2 add ($$;@)
 653
 654 Insert a new record into the database
 655
 656 Parameters:
 657
 658 =for html <blockquote>
 659
 660 =over
 661
 662 =item $table
 663
 664 The name of the table to insert into
 665
 666 =item $values
 667
 668 Hash reference of name/value pairs for the insertion
 669
 670 =item @ordering
 671
 672 Array containing field names that need to be processed in order. Not all fields
 673 mentioned in the $values hash need be mentioned here. If you have fields that
 674 must be set in a particular order you can mention them here. So, if you're
 675 adding the Defect record, but you need Project set before Platform,  you need
 676 only pass in an @ordering of qw(Project Platform). They will be done first, then
 677 all of the rest of the fields in the $values hash. If you have no ordering
 678 dependencies then you can simply omit @ordering.
 679
 680 Note that the best way to determine if you have an ordering dependency try using
 681 a Clearquest client and note the order that you set fields in. If at anytime
 682 setting one field negates another field via action hook code then you have just
 683 figured out that this field needs to be set before the file that just got
 684 negated.
 685
 686 =back
 687
 688 =for html </blockquote>
 689
 690 Returns:
 691
 692 =for html <blockquote>
 693
 694 =over
 695
 696 =item $dbid
 697
 698 The DBID of the newly added record or undef if error.
 699
 700 =back
 701
 702 =for html </blockquote>
 703
 704 =cut
 705
 706   $self->{errmsg} = '';
 707
 708   unless ($self->connected) {
 709     $self->_setError ('You must connect to Clearquest before you can call add');
 710
 711     return;
 712   } # unless
 713
 714   my %values = %$values;
 715   my $entity;
 716
 717   eval {$entity = $self->{session}->BuildEntity ($table)};
 718
 719   if ($@) {
 720     $self->_setError ("Unable to create new $table record:\n$@");
 721
 722     return;
 723   } # if
 724
 725   # First process all fields in @ordering, if specified
 726   for (@ordering) {
 727     if ($values{$_}) {
 728       $self->{errmsg} = $self->_setFieldValue ($entity, $table, $_, $values{$_});
 729     } else {
 730       $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
 731     } # if
 732
 733     last unless $self->{errmsg} eq '';
 734   } # for
 735
 736   return unless $self->{errmsg} eq '';
 737
 738   # Now process the rest of the values
 739   for my $fieldName (keys %values) {
 740     next if grep {$fieldName eq $_} @ordering;
 741
 742     $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
 743
 744     last unless $self->{errmsg} eq '';
 745   } # for
 746
 747   $self->_setError ($self->{errmsg});
 748
 749   return unless $self->{errmsg} eq '';
 750
 751   $self->{errmsg} = $self->_commitRecord ($entity);
 752   $self->{error}  = $self->{errmsg} eq '' ? 0 : 1;
 753
 754   my $dbid = $entity->GetFieldValue ('dbid')->GetValue;
 755
 756   return $dbid;
 757 } # add
 758
 759 sub connect(;$$$$) {
 760   my ($self, $username, $password, $database, $dbset) = @_;
 761
 762 =pod
 763
 764 =head2 connect (;$$$$)
 765
 766 Connect to the Clearquest database. You can supply parameters such as username,
 767 password, etc and they will override any passed to Clearquest::new (or those
 768 coming from ../etc/cq.conf)
 769
 770 Parameters:
 771
 772 =for html <blockquote>
 773
 774 =over
 775
 776 =item $username
 777
 778 Username to use to connect to the database
 779
 780 =item $password
 781
 782 Password to use to connect to the database
 783
 784 =item $database
 785
 786 Clearquest database to connect to
 787
 788 =item $dbset
 789
 790 Database set to connect to (Default: Connect to the default dbset)
 791
 792 =back
 793
 794 =for html </blockquote>
 795
 796 Returns:
 797
 798 =for html <blockquote>
 799
 800 =over
 801
 802 =item 1
 803
 804 =back
 805
 806 =for html </blockquote>
 807
 808 =cut
 809
 810   return unless $self->{module} eq 'api';
 811
 812   eval {require CQPerlExt};
 813
 814   croak "Unable to use Rational's CQPerlExt library - "
 815       . "You must use cqperl to use the Clearquest API back end\n$@" if $@;
 816
 817   $self->{username} = $username if $username;
 818   $self->{password} = $password if $password;
 819   $self->{database} = $database if $database;
 820   $self->{dbset}    = $dbset    if $dbset;
 821
 822   $self->{session} = CQSession::Build ();
 823
 824   $self->{loggedin} = 0;
 825
 826   eval {
 827     $self->{session}->UserLogon ($self->{username},
 828                                  $self->{password},
 829                                  $self->{database},
 830                                  $self->{dbset});
 831   };
 832
 833   if ($@) {
 834     chomp ($@);
 835
 836     $self->_setError ($@, 1);
 837   } else {
 838     $self->{loggedin} = 1;
 839
 840     $self->_setError ($_, 0);
 841   } # if
 842
 843   return $self->{loggedin};
 844 } # connect
 845
 846 sub connected() {
 847   my ($self) = @_;
 848
 849 =pod
 850
 851 =head2 connected ()
 852
 853 Returns 1 if we are currently connected to Clearquest
 854
 855 Parameters:
 856
 857 =for html <blockquote>
 858
 859 =over
 860
 861 =item none
 862
 863 =back
 864
 865 =for html </blockquote>
 866
 867 Returns:
 868
 869 =for html <blockquote>
 870
 871 =over
 872
 873 =item 1 if logged in - 0 if not
 874
 875 =back
 876
 877 =for html </blockquote>
 878
 879 =cut
 880
 881   return $self->{loggedin};
 882 } # connected
 883
 884 sub connection($) {
 885   my ($self, $fullyQualify) = @_;
 886
 887 =pod
 888
 889 =head2 connection ()
 890
 891 Returns a connection string that describes the current connection
 892
 893 Parameters:
 894
 895 =for html <blockquote>
 896
 897 =over
 898
 899 =item $fullyQualify
 900
 901 If true the connection string will be fully qualified
 902
 903 =back
 904
 905 =for html </blockquote>
 906
 907 Returns:
 908
 909 =for html <blockquote>
 910
 911 =over
 912
 913 =item $connectionStr
 914
 915 A string describing the current connection. Generally
 916 <username>@<database>[/<dbset>]. Note that <dbset> is only displayed if it is
 917 not the default DBSet as defined in cq.conf.
 918
 919 =back
 920
 921 =for html </blockquote>
 922
 923 =cut
 924
 925   my $connectionStr = $self->username ()
 926                     . '@'
 927                     . $self->database ();
 928
 929   if ($fullyQualify) {
 930     $connectionStr .= '/' . $self->dbset;
 931   } else {
 932     $connectionStr .= '/' . $self->dbset () unless $self->dbset eq $DEFAULT_DBSET;
 933   } # if
 934
 935   return $connectionStr;
 936 } # connection
 937
 938 sub checkErr(;$$$) {
 939   my ($self, $msg, $die, $log) = @_;
 940
 941 =pod
 942
 943 =head2 checkErr (;$$)
 944
 945 Checks for error in the last Clearquest method call and prints error to STDERR.
 946 Optionally prints a user message if $msg is specified. Dies if $die is true
 947
 948 Parameters:
 949
 950 =for html <blockquote>
 951
 952 =over
 953
 954 =item $msg
 955
 956 User error message
 957
 958 =item $die
 959
 960 Causes caller to croak if set to true
 961
 962 =back
 963
 964 =for html </blockquote>
 965
 966 Returns:
 967
 968 =for html <blockquote>
 969
 970 =over
 971
 972 =item $error
 973
 974 Returns 0 for no error, non-zero if error.
 975
 976 =back
 977
 978 =for html </blockquote>
 979
 980 =cut
 981
 982   $die ||= 0;
 983
 984   if ($self->{error}) {
 985     if ($msg) {
 986       $msg .= "\n" . $self->errmsg . "\n";
 987     } else {
 988       $msg = $self->errmsg . "\n";
 989     } # if
 990
 991     if ($die) {
 992       $log->err ($msg) if $log;
 993       croak $msg;
 994     } else {
 995       if ($log) {
 996         $log->err($msg);
 997       } else {
 998         print STDERR "$msg\n";
 999       } # if
1000
1001       return $self->{error};
1002     } # if
1003   } # if
1004
1005   return 0;
1006 } # checkErr
1007
1008 sub database() {
1009   my ($self) = @_;
1010
1011 =pod
1012
1013 =head2 database
1014
1015 Returns the current database (or the database that would be used)
1016
1017 Parameters:
1018
1019 =for html <blockquote>
1020
1021 =over
1022
1023 =item none
1024
1025 =back
1026
1027 =for html </blockquote>
1028
1029 Returns:
1030
1031 =for html <blockquote>
1032
1033 =over
1034
1035 =item database
1036
1037 =back
1038
1039 =for html </blockquote>
1040
1041 =cut
1042
1043   return $self->{database};
1044 } # database
1045
1046 sub dbset() {
1047   my ($self) = @_;
1048
1049 =pod
1050
1051 =head2 dbset
1052
1053 Returns the current dbset (or the dbset that would be used)
1054
1055 Parameters:
1056
1057 =for html <blockquote>
1058
1059 =over
1060
1061 =item none
1062
1063 =back
1064
1065 =for html </blockquote>
1066
1067 Returns:
1068
1069 =for html <blockquote>
1070
1071 =over
1072
1073 =item dbset
1074
1075 =back
1076
1077 =for html </blockquote>
1078
1079 =cut
1080
1081   return $self->{dbset};
1082 } # dbset
1083
1084 sub dbsets() {
1085   my ($self) = @_;
1086
1087 =pod
1088
1089 =head2 dbsets ()
1090
1091 Return the installed DBSets for this schema
1092
1093 Parameters:
1094
1095 =for html <blockquote>
1096
1097 =over
1098
1099 =item none
1100
1101 =back
1102
1103 =for html </blockquote>
1104
1105 Returns:
1106
1107 =for html <blockquote>
1108
1109 =over
1110
1111 =item @dbsets
1112
1113 An array of dbsets
1114
1115 =back
1116
1117 =for html </blockquote>
1118
1119 =cut
1120
1121   unless ($self->connected) {
1122     $self->_setError ('You must connect to Clearquest before you can call DBSets', '-1');
1123
1124     return;
1125   } # unless
1126
1127   return @{$self->{session}->GetInstalledDbSets};
1128 } # dbsets
1129
1130 sub delete($;$) {
1131   my ($self, $table, $key) = @_;
1132
1133 =pod
1134
1135 =head2 delete ($;$)
1136
1137 Deletes records from the database
1138
1139 Parameters:
1140
1141 =for html <blockquote>
1142
1143 =over
1144
1145 =item $table
1146
1147 Table to delete records from
1148
1149 =item $key
1150
1151 Key of the record to delete
1152
1153 =back
1154
1155 =for html </blockquote>
1156
1157 Returns:
1158
1159 =for html <blockquote>
1160
1161 =over
1162
1163 =item $errmsg
1164
1165 Error message or blank if no error
1166
1167 =back
1168
1169 =for html </blockquote>
1170
1171 =cut
1172
1173   my $entity;
1174
1175   eval {$entity = $self->{session}->GetEntity ($table, $key)};
1176
1177   if ($@) {
1178     $self->_setError ($@, 1);
1179
1180     return $@;
1181   } # if
1182
1183   eval {$self->{session}->DeleteEntity ($entity, 'Delete')};
1184
1185   if ($@) {
1186     $self->_setError ($@, 1);
1187
1188     return $@;
1189   } # if
1190
1191   return  '';
1192 } # delete
1193
1194 sub DESTROY() {
1195   my ($self) = @_;
1196
1197   CQSession::Unbuild ($self->{session}) if $self->{session};
1198
1199   return;
1200 } # DESTROY
1201
1202 sub disconnect() {
1203   my ($self) = @_;
1204
1205 =pod
1206
1207 =head2 disconnect ()
1208
1209 Disconnect from Clearquest
1210
1211 Parameters:
1212
1213 =for html <blockquote>
1214
1215 =over
1216
1217 =item none
1218
1219 =back
1220
1221 =for html </blockquote>
1222
1223 Returns:
1224
1225 =for html <blockquote>
1226
1227 =over
1228
1229 =item nothing
1230
1231 =back
1232
1233 =for html </blockquote>
1234
1235 =cut
1236
1237   CQSession::Unbuild ($self->{session});
1238
1239   undef $self->{session};
1240
1241   $self->{loggedin} = 0;
1242
1243   return;
1244 } # disconnect
1245
1246 sub errmsg(;$) {
1247   my ($self, $errmsg) = @_;
1248
1249 =pod
1250
1251 =head2 errmsg ()
1252
1253 Returns the last error message. Optionally sets the error message if specified.
1254
1255 Parameters:
1256
1257 =for html <blockquote>
1258
1259 =over
1260
1261 =item $errmsg
1262
1263 =back
1264
1265 =for html </blockquote>
1266
1267 Returns:
1268
1269 =for html <blockquote>
1270
1271 =over
1272
1273 =item $errmsg
1274
1275 Last $errmsg
1276
1277 =back
1278
1279 =for html </blockquote>
1280
1281 =cut
1282
1283   $self->{errmsg} = $errmsg if $errmsg;
1284
1285   return $self->{errmsg};
1286 } # errmsg
1287
1288 sub error(;$) {
1289   my ($self, $error) = @_;
1290
1291 =pod
1292
1293 =head2 error ($error)
1294
1295 Returns the last error number. Optional set the error number if specified
1296
1297 Parameters:
1298
1299 =for html <blockquote>
1300
1301 =over
1302
1303 =item $error
1304
1305 Error number to set
1306
1307 =back
1308
1309 =for html </blockquote>
1310
1311 Returns:
1312
1313 =for html <blockquote>
1314
1315 =over
1316
1317 =item $error
1318
1319 Last error
1320
1321 =back
1322
1323 =for html </blockquote>
1324
1325 =cut
1326
1327   # Watch here as $error can very well be 0 which "if $error" would evaluate
1328   # to false leaving $self->{error} undefined
1329   $self->{error} = $error if defined $error;
1330
1331   return $self->{error};
1332 } # error
1333
1334 sub fieldType($$) {
1335   my ($self, $table, $fieldName) = @_;
1336
1337 =pod
1338
1339 =head2 fieldType ($table, $fieldname)
1340
1341 Returns the field type for the $table, $fieldname combination.
1342
1343 Parameters:
1344
1345 =for html <blockquote>
1346
1347 =over
1348
1349 =item $table
1350
1351 Table to return field type from.
1352
1353 =item $fieldname
1354
1355 Fieldname to return the field type from.
1356
1357 =back
1358
1359 =for html </blockquote>
1360
1361 Returns:
1362
1363 =for html <blockquote>
1364
1365 =over
1366
1367 =item $fieldType
1368
1369 Fieldtype enum
1370
1371 =back
1372
1373 =for html </blockquote>
1374
1375 =cut
1376
1377   return $UNKNOWN unless $self->{loggedin};
1378
1379   # If we've already computed the fieldTypes for the fields in this table then
1380   # return the value
1381   if ($FIELDS{$table}) {
1382     # If we already have this fieldType just return it
1383     if (defined $FIELDS{$table}{$fieldName}) {
1384       return $FIELDS{$table}{$fieldName}
1385     } else {
1386       return $UNKNOWN
1387     } # if
1388   } # if
1389
1390   my $entityDef = $self->{session}->GetEntityDef ($table);
1391
1392   for (@{$entityDef->GetFieldDefNames}) {
1393     $FIELDS{$table}{$_} = $entityDef->GetFieldDefType ($_);
1394   } # for
1395
1396   if (defined $FIELDS{$table}{$fieldName}) {
1397     return $FIELDS{$table}{$fieldName}
1398   } else {
1399     return $UNKNOWN
1400   } # if
1401 } # fieldType
1402
1403 sub fieldTypeName($$) {
1404   my ($self, $table, $fieldName) = @_;
1405
1406 =pod
1407
1408 =head2 fieldTypeName ($table, $fieldname)
1409
1410 Returns the field type name for the $table, $fieldname combination.
1411
1412 Parameters:
1413
1414 =for html <blockquote>
1415
1416 =over
1417
1418 =item $table
1419
1420 Table to return field type from.
1421
1422 =item $fieldname
1423
1424 Fieldname to return the field type from.
1425
1426 =back
1427
1428 =for html </blockquote>
1429
1430 Returns:
1431
1432 =for html <blockquote>
1433
1434 =over
1435
1436 =item $fieldTypeName
1437
1438 Fieldtype name
1439
1440 =back
1441
1442 =for html </blockquote>
1443
1444 =cut
1445
1446   my $fieldType = $self->fieldType ($table, $fieldName);
1447
1448   return $UNKNOWN unless $fieldType;
1449
1450   if ($fieldType == $STRING) {
1451     return "STRING";
1452   } elsif ($fieldType == $MULTILINE_STRING) {
1453     return "MULTILINE_STRING";
1454   } elsif ($fieldType == $INT) {
1455     return "INT";
1456   } elsif ($fieldType == $DATE_TIME) {
1457     return "DATE_TIME";
1458   } elsif ($fieldType == $REFERENCE) {
1459     return "REFERENCE"
1460   } elsif ($fieldType == $REFERENCE_LIST) {
1461     return "REFERENCE_LIST";
1462   } elsif ($fieldType == $ATTACHMENT_LIST) {
1463     return "ATTACHMENT_LIST";
1464   } elsif ($fieldType == $ID) {
1465     return "ID";
1466   } elsif ($fieldType == $STATE) {
1467     return "STATE";
1468   } elsif ($fieldType == $JOURNAL) {
1469     return "JOURNAL";
1470   } elsif ($fieldType == $DBID) {
1471     return "DBID";
1472   } elsif ($fieldType == $STATETYPE) {
1473     return "STATETYPE";
1474   } elsif ($fieldType == $RECORD_TYPE) {
1475     return "RECORD_TYPE";
1476   } elsif ($fieldType == $UNKNOWN) {
1477     return "UNKNOWN";
1478   } # if
1479 } # fieldTypeName
1480
1481 sub find($;$@) {
1482   my ($self, $table, $condition, @fields) = @_;
1483
1484 =pod
1485
1486 =head2 find ($;$@)
1487
1488 Find records in $table. You can specify a $condition and which fields you wish
1489 to retrieve. Specifying a smaller set of fields means less data transfered and
1490 quicker retrieval so only retrieve the fields you really need.
1491
1492 Parameters:
1493
1494 =for html <blockquote>
1495
1496 =over
1497
1498 =item $table
1499
1500 Name of the table to search
1501
1502 =item $condition
1503
1504 Condition to use. If you want all records then pass in undef. Only simple
1505 conditions are supported. You can specify compound conditions (e.g. field1 ==
1506 'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
1507 supported (yet).
1508
1509 The following conditionals are supported
1510
1511 =over
1512
1513 =item Equal (==|=)
1514
1515 =item Not Equal (!=|<>)
1516
1517 =item Less than (<)
1518
1519 =item Greater than (>)
1520
1521 =item Less than or equal (<=)
1522
1523 =item Greater than or equal (>=)
1524
1525 =item Like
1526
1527 =item Is null
1528
1529 =item Is not null
1530
1531 =item In
1532
1533 =back
1534
1535 Note that "is not null" is currently not working in the REST module (it works
1536 in the api and thus also in the client/server model). This because the
1537 OLSC spec V1.0 does not support it.
1538
1539 As for "Like"", you'll need to specify "<fieldname> like '%var%'" for the
1540 condition.
1541
1542 "In" is only available in the REST interface as that's what OLSC supports. It's
1543 syntax would be "<fieldname> In 'value1', 'value2', 'value3'..."
1544
1545 Also conditions can be combined with (and|or) so in the api you could do "in"
1546 as "<fieldname> = 'value1 or <fieldname> = 'value2" or <fieldname> = 'value3'".
1547
1548 Complicated expressions with parenthesis like "(Project = 'Athena' or Project =
1549 'Hawaii') and Category = 'Aspen'" are not supported.
1550
1551 =item @fields
1552
1553 An array of fieldnames to retrieve
1554
1555 =back
1556
1557 =for html </blockquote>
1558
1559 Returns:
1560
1561 =for html <blockquote>
1562
1563 =over
1564
1565 =item $result or ($result, $nbrRecs)
1566
1567 Internal structure to be used with getNext. If in an array context then $nbrRecs
1568 is also returned.
1569
1570 =back
1571
1572 =for html </blockquote>
1573
1574 =cut
1575
1576   $condition ||= '';
1577
1578   unless ($self->connected) {
1579     $self->_setError ('You must connect to Clearquest before you can call find', '-1');
1580
1581     return;
1582   } # unless
1583
1584   my $entityDef;
1585
1586   eval {$entityDef = $self->{session}->GetEntityDef ($table)};
1587
1588   if ($@) {
1589     $self->_setError ($@, -1);
1590
1591     return ($@, -1);
1592   } # if
1593
1594   @fields = $self->_setFields ($table, @fields);
1595
1596   return unless @fields;
1597
1598   my $query = $self->{session}->BuildQuery ($table);
1599
1600   for (@fields) {
1601     eval {$query->BuildField ($_)};
1602
1603     if ($@) {
1604       $self->_setError ($@);
1605
1606       carp $@;
1607     } # if
1608   } # for
1609
1610   $self->_parseConditional ($query, $condition);
1611
1612   return if $self->error;
1613
1614   my $result  = $self->{session}->BuildResultSet ($query);
1615   my $nbrRecs = $result->ExecuteAndCountRecords;
1616
1617   $self->_setError;
1618
1619   my %resultSet = (
1620     result => $result
1621   );
1622
1623   if (wantarray) {
1624     return (\%resultSet, $nbrRecs);
1625   } else {
1626     return \%resultSet
1627   } # if
1628 } # find
1629
1630 sub findIDs($) {
1631   my ($str) = @_;
1632
1633 =pod
1634
1635 =head2 findIDs ($)
1636
1637 Given a $str or a reference to an array of strings, this function returns a list
1638 of Clearquest IDs found in the $str. If called in a scalar context this function
1639 returns a comma separated string of IDs found. Note that duplicate IDs are
1640 eliminated. Also, the lists of IDs may refer to different Clearquest databases.
1641
1642 Parameters:
1643
1644 =for html <blockquote>
1645
1646 =over
1647
1648 =item $str
1649
1650 String or reference to an array of strings to search
1651
1652 =back
1653
1654 =for html </blockquote>
1655
1656 Returns:
1657
1658 =for html <blockquote>
1659
1660 =over
1661
1662 =item @IDs or $strIDs
1663
1664 Either an array of CQ IDs or a comma separated list of CQ IDs.
1665
1666 =back
1667
1668 =for html </blockquote>
1669
1670 =cut
1671
1672   $str = join ' ', @$str if ref $str eq 'ARRAY';
1673
1674   my @IDs = $str =~ /([A-Za-z]\w{1,4}\d{8})/gs;
1675
1676   my %IDs;
1677
1678   map { $IDs{$_} = 1; } @IDs;
1679
1680   if (wantarray) {
1681     return keys %IDs;
1682   } else {
1683     return join ',', keys %IDs;
1684   } # if
1685 } # findIDs
1686
1687 sub get($$;@) {
1688   my ($self, $table, $id, @fields) = @_;
1689
1690 =pod
1691
1692 =head2 get ($$)
1693
1694 Return a record that you have the id or key of.
1695
1696 Parameters:
1697
1698 =for html <blockquote>
1699
1700 =over
1701
1702 =item $table
1703
1704 The $table to get the record from
1705
1706 =item $id
1707
1708 The $id or key to use to retrieve the record
1709
1710 =back
1711
1712 =for html </blockquote>
1713
1714 Returns:
1715
1716 =for html <blockquote>
1717
1718 =over
1719
1720 =item %record
1721
1722 Hash of name/value pairs for all the fields in $table
1723
1724 =back
1725
1726 =for html </blockquote>
1727
1728 =cut
1729
1730   unless ($self->connected) {
1731     $self->_setError ('You must connect to Clearquest before you can call get', '-1');
1732
1733     return;
1734   } # unless
1735
1736   @fields = $self->_setFields ($table, @fields);
1737
1738   return unless @fields;
1739
1740   my $entity;
1741
1742   eval {$entity = $self->{session}->GetEntity ($table, $id)};
1743
1744   if ($@) {
1745     $self->_setError ($@);
1746
1747     return;
1748   } # if
1749
1750   my %record;
1751
1752   for (@fields) {
1753     my $fieldType = $entity->GetFieldValue ($_)->GetType;
1754
1755     if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
1756       $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
1757     } else {
1758       $record{$_}   = $entity->GetFieldValue ($_)->GetValue;
1759       $record{$_} ||= '' if $self->{emptyStringForUndef};
1760
1761       # Fix any UTC dates
1762       if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
1763         $record{$_} = _UTC2Localtime ($record{$_});
1764       } # if
1765     } # if
1766   } # for
1767
1768   $self->_setError;
1769
1770   return %record;
1771 } # get
1772
1773 sub getDBID($$;@) {
1774   my ($self, $table, $dbid, @fields) = @_;
1775
1776 =pod
1777
1778 =head2 getDBID ($$;@)
1779
1780 Return a record that you have the dbid
1781
1782 Parameters:
1783
1784 =for html <blockquote>
1785
1786 =over
1787
1788 =item $table
1789
1790 The $table to get the record from
1791
1792 =item $dbid
1793
1794 The $dbid to use to retrieve the record
1795
1796 =item @fields
1797
1798 Array of field names to retrieve (Default: All fields)
1799
1800 Note: Avoid getting all fields for large records. It will be slow and bloat your
1801 script's memory usage.
1802
1803 =back
1804
1805 =for html </blockquote>
1806
1807 Returns:
1808
1809 =for html <blockquote>
1810
1811 =over
1812
1813 =item %record
1814
1815 Hash of name/value pairs for all the fields in $table
1816
1817 =back
1818
1819 =for html </blockquote>
1820
1821 =cut
1822
1823   unless ($self->connected) {
1824     $self->_setError ('You must connect to Clearquest before you can call getDBID', '-1');
1825
1826     return;
1827   } # unless
1828
1829   @fields = $self->_setFields ($table, @fields);
1830
1831   my $entity;
1832
1833   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
1834
1835   if ($@) {
1836     $self->_setError ($@);
1837
1838     return;
1839   } # if
1840
1841   my %record;
1842
1843   for (@fields) {
1844     my $fieldType = $entity->GetFieldValue ($_)->GetType;
1845
1846     if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
1847       $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
1848     } else {
1849       $record{$_}   = $entity->GetFieldValue ($_)->GetValue;
1850       $record{$_} ||= '' if $self->{emptyStringForUndef};
1851
1852       # Fix any UTC dates
1853       if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
1854         $record{$_} = _UTC2Localtime ($record{$_});
1855       } # if
1856     } # if
1857   } # for
1858
1859   $self->_setError;
1860
1861   return %record;
1862 } # getDBID
1863
1864 sub getDynamicList($) {
1865   my ($self, $list) = @_;
1866
1867 =pod
1868
1869 =head2 getDynamicList ($)
1870
1871 Return the entries of a dynamic list
1872
1873 Parameters:
1874
1875 =for html <blockquote>
1876
1877 =over
1878
1879 =item $list
1880
1881 The name of the dynamic list
1882
1883 =back
1884
1885 =for html </blockquote>
1886
1887 Returns:
1888
1889 =for html <blockquote>
1890
1891 =over
1892
1893 =item @entries
1894
1895 An array of entries from the dynamic list
1896
1897 =back
1898
1899 =for html </blockquote>
1900
1901 =cut
1902
1903   return () unless $self->connected;
1904
1905   return @{$self->{session}->GetListMembers ($list)};
1906 } # getDynamicList
1907
1908 sub getNext($) {
1909   my ($self, $result) = @_;
1910
1911 =pod
1912
1913 =head2 getNext ($)
1914
1915 Return the next record that qualifies from a preceeding call to the find method.
1916
1917 Parameters:
1918
1919 =for html <blockquote>
1920
1921 =over
1922
1923 =item $result
1924
1925 The $result returned from find.
1926
1927 =back
1928
1929 =for html </blockquote>
1930
1931 Returns:
1932
1933 =for html <blockquote>
1934
1935 =over
1936
1937 =item %record
1938
1939 Hash of name/value pairs for the @fields specified to find.
1940
1941 =back
1942
1943 =for html </blockquote>
1944
1945 =cut
1946
1947   unless ($self->connected) {
1948     $self->_setError ('You must connect to Clearquest before you can call getNext', '-1');
1949
1950     return;
1951   } # unless
1952
1953 # Here we need to do special processing to gather up reference list fields, if
1954 # any. If we have a reference list field in the field list then Clearquest
1955 # returns multiple records - one for each entry in the reference list. Thus if
1956 # you were getting say the key field of a record and a reference list field like
1957 # say Projects, you might see:
1958 #
1959 # Key Value     Projects
1960 # ---------     --------
1961 # key1          Athena
1962 # key1          Apollo
1963 # key1          Gemini
1964 #
1965 # Things get combinatoric when multiple reference list fields are involved. Our
1966 # strategy here is to keep gathering all fields that change into arrays assuming
1967 # they are reference fields as long as the dbid field has not changed.
1968 my %record;
1969
1970 while () {
1971   unless ($result->{lastDBID}) {
1972     # Move to the first record
1973     last unless $result->{result}->MoveNext == $CQPerlExt::CQ_SUCCESS;
1974   } elsif ($result->{lastDBID} == $result->{thisDBID}) {
1975     # If the dbid is the same then we have at least one reference list field
1976     # in the request so we need to move to the next record
1977     last unless $result->{result}->MoveNext == $CQPerlExt::CQ_SUCCESS;
1978   } else {
1979     # If lastDBID != thisDBID then set lastDBID to thisDBID so we can process
1980     # this group
1981     $result->{lastDBID} = $result->{thisDBID};
1982
1983     delete $result->{lastRecord};
1984   } # unless
1985
1986   my $nbrColumns = $result->{result}->GetNumberOfColumns;
1987
1988   my $column = 1;
1989
1990   # Format %record
1991   while ($column <= $nbrColumns) {
1992     my $name  = $result->{result}->GetColumnLabel($column);
1993     my $value = $result->{result}->GetColumnValue($column++);
1994
1995     # Fix any UTC dates - _UTC2Localtime will only modify data if the data
1996     # matches a UTC datetime.
1997     $value = _UTC2Localtime ($value) if $value;
1998
1999     $value ||= '' if $self->{emptyStringForUndef};
2000
2001     $record{$name} = $value;
2002   } # while
2003
2004   %{$result->{lastRecord}} = %record unless $result->{lastRecord};
2005
2006   # Store this record's DBID
2007   $result->{thisDBID} = $record{dbid};
2008
2009   if ($result->{lastDBID}) {
2010     if ($result->{thisDBID} == $result->{lastDBID}) {
2011       # Since the dbid's are the same, we have at least one reference list field
2012       # and we need to compare all fields
2013       for my $field (keys %record) {
2014         # If the field is blank then skip it
2015         next if $record{$field} eq '';
2016
2017         # Here we check the field in %lastRecord to see if it was a reference
2018         # list with more than one entry.
2019         if (ref \$result->{lastRecord}{$field} eq 'ARRAY') {
2020           # Check to see if this entry is already in the list of current entries
2021           next if grep {/^$record{$field}$/} @{$result->{lastRecord}{$field}};
2022         } # if
2023
2024         # This checks to see if the current field is a scalar and we have a new
2025         # value, then the scalar needs to be changed to an array
2026         if (ref \$result->{lastRecord}{$field} eq 'SCALAR') {
2027           # If the field is the same value then no change, no array. We do next
2028           # to start processing the next field
2029           next if $result->{lastRecord}{$field} eq $record{$field};
2030
2031           # Changed $lastRecord{$_} to a reference to an ARRAY
2032           $result->{lastRecord}{$field} = [$result->{lastRecord}{$field}, $record{$field}];
2033         } else {
2034           # Push the value only if it does not already exists in the array
2035           push @{$result->{lastRecord}{$field}}, $record{$field}
2036             unless grep {/^$record{$field}$/} @{$result->{lastRecord}{$field}};
2037         } # if
2038       } # for
2039
2040       # Transfer %lastRecord -> %record
2041       %record = %{$result->{lastRecord}};
2042     } else {
2043       %record = %{$result->{lastRecord}};
2044
2045       last;
2046     } # if
2047   } # if
2048
2049   # The $lastDBID is now $thisDBID
2050   $result->{lastDBID} = $result->{thisDBID};
2051
2052   # Update %lastRecord
2053   %{$result->{lastRecord}} = %record;
2054 } # while
2055
2056   $self->_setError;
2057
2058   # Never return dbid...
2059   delete $record{dbid};
2060
2061   return %record;
2062 } # getNext
2063
2064 sub id2db($) {
2065   my ($ID) = @_;
2066
2067 =pod
2068
2069 =head2 id2db ($)
2070
2071 This function returns the database name given an ID.
2072
2073 Parameters:
2074
2075 =for html <blockquote>
2076
2077 =over
2078
2079 =item $ID
2080
2081 The ID to extract the database name from
2082
2083 =back
2084
2085 =for html </blockquote>
2086
2087 Returns:
2088
2089 =for html <blockquote>
2090
2091 =over
2092
2093 =item $database
2094
2095 Returns the name of the database the ID is part of or undef if not found.
2096
2097 =back
2098
2099 =for html </blockquote>
2100
2101 =cut
2102
2103   if ($ID =~ /([A-Za-z]\w{1,4})\d{8}/) {
2104     return $1;
2105   } else {
2106     return;
2107   } # if
2108 } # id2db
2109
2110 sub key($$) {
2111   my ($self, $table, $dbid) = @_;
2112
2113 =pod
2114
2115 =head2 key ($$)
2116
2117 Return the key of the record given a $dbid
2118
2119 Parameters:
2120
2121 =for html <blockquote>
2122
2123 =over
2124
2125 =item $table
2126
2127 Name of the table to lookup
2128
2129 =item $dbid
2130
2131 Database ID of the record to retrieve
2132
2133 =back
2134
2135 =for html </blockquote>
2136
2137 Returns:
2138
2139 =for html <blockquote>
2140
2141 =over
2142
2143 =item key
2144
2145 =back
2146
2147 =for html </blockquote>
2148
2149 =cut
2150
2151   unless ($self->connected) {
2152     $self->_setError ('You must connect to Clearquest before you can call key', '-1');
2153
2154     return;
2155   } # unless
2156
2157   my $entity;
2158
2159   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
2160
2161   return $entity->GetDisplayName;
2162 } # key
2163
2164 sub modify($$$$;@) {
2165   my ($self, $table, $key, $action, $values, @ordering) = @_;
2166
2167 =pod
2168
2169 =head2 modify ($$$$;@)
2170
2171 Update record(s)
2172
2173 Parameters:
2174
2175 =for html <blockquote>
2176
2177 =over
2178
2179 =item $table
2180
2181 The $table to get the record from
2182
2183 =item $key
2184
2185 The $key identifying the record to modify
2186
2187 =item $action
2188
2189 Action to perform the modification under. Default is 'Modify'.
2190
2191 =item $values
2192
2193 Hash reference containing name/value that have the new values for the fields
2194
2195 =item @ordering
2196
2197 Array containing field names that need to be processed in order. Not all fields
2198 mentioned in the $values hash need be mentioned here. If you have fields that
2199 must be set in a particular order you can mention them here. So, if you're
2200 modifying the Defect record, but you need Project set before Platform,  you need
2201 only pass in an @ordering of qw(Project Platform). They will be done first, then
2202 all of the rest of the fields in the $values hash. If you have no ordering
2203 dependencies then you can simply omit @ordering.
2204
2205 Note that the best way to determine if you have an ordering dependency try using
2206 a Clearquest client and note the order that you set fields in. If at anytime
2207 setting one field negates another field via action hook code then you have just
2208 figured out that this field needs to be set before the file that just got
2209 negated.
2210
2211 =back
2212
2213 =for html </blockquote>
2214
2215 Returns:
2216
2217 =for html <blockquote>
2218
2219 =over
2220
2221 =item $errmsg
2222
2223 The $errmsg, if any, when performing the update (empty string for success)
2224
2225 =back
2226
2227 =for html </blockquote>
2228
2229 =cut
2230
2231   unless ($self->connected) {
2232     $self->_setError ('You must connect to Clearquest before you can call modify', '-1');
2233
2234     return $self->{errmsg};
2235   } # unless
2236
2237   my %record = $self->get ($table, $key, qw(dbid));
2238
2239   return $self->modifyDBID ($table, $record{dbid}, $action, $values, @ordering);
2240 } # modify
2241
2242 sub modifyDBID($$$$;@) {
2243   my ($self, $table, $dbid, $action, $values, @ordering) = @_;
2244
2245 =pod
2246
2247 =head2 modifyDBID ($$$%)
2248
2249 Update a unique record (by DBID)
2250
2251 Parameters:
2252
2253 =for html <blockquote>
2254
2255 =over
2256
2257 =item $table
2258
2259 The $table to get the record from
2260
2261 =item $dbid
2262
2263 The $dbid of the record to update. Note that the find method always includes the
2264 dbid of a record in the hash that it returns.
2265
2266 =item $action
2267
2268 Action to perform the modification under. Default is 'Modify'.
2269
2270 =item %update
2271
2272 Hash containing name/value that have the new values for the fields
2273
2274 =back
2275
2276 =for html </blockquote>
2277
2278 Returns:
2279
2280 =for html <blockquote>
2281
2282 =over
2283
2284 =item $errmsg
2285
2286 The $errmsg, if any, when performing the update (empty string for success)
2287
2288 =back
2289
2290 =for html </blockquote>
2291
2292 =cut
2293
2294   $action ||= 'Modify';
2295
2296   my %values = ();
2297
2298   %values = %$values if $values;
2299
2300   my $entity;
2301
2302   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
2303
2304   if ($@) {
2305     $self->_setError ($@);
2306
2307     return;
2308   } # if
2309
2310   eval {$entity->EditEntity ($action)};
2311
2312   if ($@) {
2313     $self->_setError ($@);
2314
2315     return $@;
2316   } # if
2317
2318   # First process all fields in @ordering, if specified
2319   for (@ordering) {
2320     if ($values{$_}) {
2321       $self->{errmsg} = $self->_setFieldValue ($table, $_, $values{$_});
2322     } else {
2323       $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
2324     } # if
2325
2326     last unless $self->{errmsg} eq '';
2327   } # for
2328
2329   return $self->{errmsg} unless $self->{errmsg} eq '';
2330
2331   # Now process the rest of the values
2332   for my $fieldName (keys %values) {
2333     next if grep {$fieldName eq $_} @ordering;
2334
2335     $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
2336
2337     last unless $self->{errmsg} eq '';
2338   } # for
2339
2340   $self->_setError ($self->{errmsg});
2341
2342   return $self->{errmsg} unless $self->{errmsg} eq '';
2343
2344   $self->{errmsg} = $self->_commitRecord ($entity);
2345   $self->{error}  = $self->{errmsg} eq '' ? 0 : 1;
2346
2347   return $self->{errmsg};
2348 } # modifyDBID
2349
2350 sub module() {
2351   my ($self) = @_;
2352
2353 =pod
2354
2355 =head2 module
2356
2357 Returns the current back end module we are using
2358
2359 Parameters:
2360
2361 =for html <blockquote>
2362
2363 =over
2364
2365 =item none
2366
2367 =back
2368
2369 =for html </blockquote>
2370
2371 Returns:
2372
2373 =for html <blockquote>
2374
2375 =over
2376
2377 =item module
2378
2379 =back
2380
2381 =for html </blockquote>
2382
2383 =cut
2384
2385   return $self->{module};
2386 } # module
2387
2388 sub new(;%) {
2389   my ($class, %parms) = @_;
2390
2391 =pod
2392
2393 =head2 new ()
2394
2395 Construct a new Clearquest object.
2396
2397 Parameters:
2398
2399 Below are the key values for the %parms hash.
2400
2401 =for html <blockquote>
2402
2403 =over
2404
2405 =item CQ_SERVER
2406
2407 Webhost for REST module
2408
2409 =item CQ_USERNAME
2410
2411 Username to use to connect to the database
2412
2413 =item CQ_PASSWORD
2414
2415 Password to use to connect to the database
2416
2417 =item CQ_DATABASE
2418
2419 Clearquest database to connect to
2420
2421 =item CQ_DBSET
2422
2423 Database set to connect to
2424
2425 =item CQ_MODULE
2426
2427 One of 'rest', 'api' or 'client' (Default: From cq.conf). This determines which
2428 backend module will be used.
2429
2430 =back
2431
2432 =for html </blockquote>
2433
2434 Returns:
2435
2436 =for html <blockquote>
2437
2438 =over
2439
2440 =item Clearquest object
2441
2442 =back
2443
2444 =for html </blockquote>
2445
2446 =cut
2447
2448   $parms{CQ_DATABASE} ||= $OPTS{CQ_DATABASE};
2449   $parms{CQ_USERNAME} ||= $OPTS{CQ_USERNAME};
2450   $parms{CQ_PASSWORD} ||= $OPTS{CQ_PASSWORD};
2451   $parms{CQ_DBSET}    ||= $OPTS{CQ_DBSET};
2452
2453   my $self = bless {
2454     server              => $parms{CQ_SERVER},
2455     port                => $parms{CQ_PORT},
2456     database            => $parms{CQ_DATABASE},
2457     dbset               => $parms{CQ_DBSET},
2458     username            => $parms{CQ_USERNAME},
2459     password            => $parms{CQ_PASSWORD},
2460     emptyStringForUndef => 0,
2461     returnSystemFields  => 0,
2462   }, $class;
2463
2464   my $module = delete $parms{CQ_MODULE};
2465
2466   $module ||= $OPTS{CQ_MODULE};
2467
2468   $module = lc $module;
2469
2470   if ($module eq 'rest') {
2471     require Clearquest::REST;
2472
2473     $self->{webhost} = $parms{CQ_WEBHOST} || $OPTS{CQ_WEBHOST};
2474
2475     $self = Clearquest::REST->new ($self);
2476   } elsif ($module eq 'client') {
2477     require Clearquest::Client;
2478
2479     $self->{server} = $parms{CQ_SERVER} || $OPTS{CQ_SERVER};
2480     $self->{port}   = $parms{CQ_PORT}   || $OPTS{CQ_PORT};
2481
2482     $self = Clearquest::Client->new ($self);
2483   } elsif ($module ne 'api') {
2484     croak "Unknown interface requested - $module";
2485   } # if
2486
2487   $self->{module} = $module;
2488
2489   # Save reference to instaniated instance of this object to insure that global
2490   # variables are properly disposed of
2491   push @objects, $self;
2492
2493   return $self;
2494 } # new
2495
2496 sub server() {
2497   my ($self) = @_;
2498
2499 =pod
2500
2501 =head2 server
2502
2503 Returns the current server if applicable
2504
2505 Parameters:
2506
2507 =for html <blockquote>
2508
2509 =over
2510
2511 =item none
2512
2513 =back
2514
2515 =for html </blockquote>
2516
2517 Returns:
2518
2519 =for html <blockquote>
2520
2521 =over
2522
2523 =item $server
2524
2525 For api this will return ''. For REST and client/server this will return the
2526 server name that we are talking to.
2527
2528 =back
2529
2530 =for html </blockquote>
2531
2532 =cut
2533
2534   return $self->{server};
2535 } # server
2536
2537 sub setOpts(%) {
2538   my ($self, %opts) = @_;
2539
2540 =pod
2541
2542 =head2 setOpts
2543
2544 Set options for operating
2545
2546 Parameters:
2547
2548 =for html <blockquote>
2549
2550 =over
2551
2552 =item %opts
2553
2554 =back
2555
2556 Options to set. The only options currently supported are emptyStringForUndef
2557 and returnSystemFields. If set emptyStringForUndef will return empty strings for
2558 empty fields instead of undef. Default: Empty fields are represented with undef.
2559
2560 System-owned fields are used internally by IBM Rational ClearQuest to maintain
2561 information about the database. You should never modify system fields directly
2562 as it could corrupt the database. If returnSystemFields is set then system
2563 fields will be returned. Default: System fields will not be returned unless
2564 explicitly stated in the @fields parameter. This means that if you do not
2565 specify any fields in @fields, all fields will be returned except system fields,
2566 unless you set returnSystemFields via this method or you explicitly mention the
2567 system field in your @fields parameter.
2568
2569 =for html </blockquote>
2570
2571 Returns:
2572
2573 =for html <blockquote>
2574
2575 =over
2576
2577 =item Nothing
2578
2579 =back
2580
2581 =for html </blockquote>
2582
2583 =cut
2584
2585   $self->{emptyStringForUndef} = $opts{emptyStringForUndef}
2586     if $opts{emptyStringForUndef};
2587   $self->{returnSystemFields}  = $opts{returnSystemFields}
2588     if $opts{returnSystemFields};
2589
2590   return
2591 } # setOpts
2592
2593 sub getOpt($) {
2594   my ($self, $option) = @_;
2595
2596 =pod
2597
2598 =head2 getOpt
2599
2600 Get option
2601
2602 Parameters:
2603
2604 =for html <blockquote>
2605
2606 =over
2607
2608 =item $option
2609
2610 =back
2611
2612 Option to retrieve. If non-existant then undef is returned.
2613
2614 =for html </blockquote>
2615
2616 Returns:
2617
2618 =for html <blockquote>
2619
2620 =over
2621
2622 =item $option or undef if option doesn't exist
2623
2624 =back
2625
2626 =for html </blockquote>
2627
2628 =cut
2629
2630   my @validOpts = qw (emptyStringForUndef returnSystemFields);
2631
2632   if (grep {$option eq $_} @validOpts) {
2633     return $self->{$option};
2634   } else {
2635     return;
2636   } # if
2637 } # getOpt
2638
2639 sub username() {
2640   my ($self) = @_;
2641
2642 =pod
2643
2644 =head2 username
2645
2646 Returns the current username (or the username that would be used)
2647
2648 Parameters:
2649
2650 =for html <blockquote>
2651
2652 =over
2653
2654 =item none
2655
2656 =back
2657
2658 =for html </blockquote>
2659
2660 Returns:
2661
2662 =for html <blockquote>
2663
2664 =over
2665
2666 =item username
2667
2668 =back
2669
2670 =for html </blockquote>
2671
2672 =cut
2673
2674   return $self->{username};
2675 } # username
2676
2677 sub webhost() {
2678   my ($self) = @_;
2679
2680   return $self->{webhost};
2681 } # webhost
2682
2683 1;
2684
2685 =pod
2686
2687 =head1 DEPENDENCIES
2688
2689 =head2 Perl Modules
2690
2691 L<File::Basename|File::Basename>
2692
2693 =head2 ClearSCM Perl Modules
2694
2695 =for html <p><a href="/php/scm_man.php?file=lib/GetConfig.pm">GetConfig</a></p>
2696
2697 =head1 BUGS AND LIMITATIONS
2698
2699 There are no known bugs in this module
2700
2701 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
2702
2703 =head1 LICENSE AND COPYRIGHT
2704
2705 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
2706
2707 =cut