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 foreach (@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 } # _pochToDate
 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     # Always return dbid
 572     push @fields, 'dbid' unless grep {$_ eq 'dbid'} @fields;
 573
 574     foreach (@{$entityDef->GetFieldDefNames}) {
 575       unless ($self->{returnSystemFields}) {
 576         next if $entityDef->IsSystemOwnedFieldDefName ($_);
 577       } # unless
 578
 579       push @fields, $_;
 580     } # foreach
 581   } # unless
 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     foreach (@$fieldValue) {
 620       $errmsg = $entity->AddFieldValue ($fieldName, $_);
 621
 622       return $errmsg unless $errmsg eq '';
 623     } # foreach
 624   } # unless
 625
 626   return $errmsg;
 627 } # _setFieldValues
 628
 629 sub _UTCTime ($) {
 630   my ($datetime) = @_;
 631
 632   my @localtime = localtime;
 633   my ($sec, $min, $hour, $mday, $mon, $year) = gmtime (
 634     _dateToEpoch ($datetime) - (timegm (@localtime) - timelocal (@localtime))
 635   );
 636
 637   $year += 1900;
 638   $mon++;
 639
 640   $sec  = '0' . $sec  if $sec  < 10;
 641   $min  = '0' . $min  if $min  < 10;
 642   $hour = '0' . $hour if $hour < 10;
 643   $mon  = '0' . $mon  if $mon  < 10;
 644   $mday = '0' . $mday if $mday < 10;
 645
 646   return "$year-$mon-${mday}T$hour:$min:${sec}Z";
 647 } # _UTCTime
 648
 649 sub _UTC2Localtime ($) {
 650   my ($utcdatetime) = @_;
 651
 652   return unless $utcdatetime;
 653
 654   # If the field does not look like a UTC time then just return it.
 655   return $utcdatetime unless $utcdatetime =~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/;
 656
 657   $utcdatetime =~ s/T/ /;
 658   $utcdatetime =~ s/Z//;
 659
 660   my @localtime = localtime;
 661
 662   return _epochToDate (
 663     _dateToEpoch ($utcdatetime) + (timegm (@localtime) - timelocal (@localtime))
 664   );
 665 } # _UTC2Localtime
 666
 667 sub add ($$;@) {
 668   my ($self, $table, $values, @ordering) = @_;
 669
 670 =pod
 671
 672 =head2 add ($$;@)
 673
 674 Insert a new record into the database
 675
 676 Parameters:
 677
 678 =for html <blockquote>
 679
 680 =over
 681
 682 =item $table
 683
 684 The name of the table to insert into
 685
 686 =item $values
 687
 688 Hash reference of name/value pairs for the insertion
 689
 690 =item @ordering
 691
 692 Array containing field names that need to be processed in order. Not all fields
 693 mentioned in the $values hash need be mentioned here. If you have fields that
 694 must be set in a particular order you can mention them here. So, if you're
 695 adding the Defect record, but you need Project set before Platform,  you need
 696 only pass in an @ordering of qw(Project Platform). They will be done first, then
 697 all of the rest of the fields in the $values hash. If you have no ordering
 698 dependencies then you can simply omit @ordering.
 699
 700 Note that the best way to determine if you have an ordering dependency try using
 701 a Clearquest client and note the order that you set fields in. If at anytime
 702 setting one field negates another field via action hook code then you have just
 703 figured out that this field needs to be set before the file that just got
 704 negated.
 705
 706 =back
 707
 708 =for html </blockquote>
 709
 710 Returns:
 711
 712 =for html <blockquote>
 713
 714 =over
 715
 716 =item $dbid
 717
 718 The DBID of the newly added record or undef if error.
 719
 720 =back
 721
 722 =for html </blockquote>
 723
 724 =cut
 725
 726   $self->{errmsg} = '';
 727
 728   unless ($self->connected) {
 729     $self->_setError ('You must connect to Clearquest before you can call add');
 730
 731     return;
 732   } # unless
 733
 734   my %values = %$values;
 735   my $entity;
 736
 737   eval {$entity = $self->{session}->BuildEntity ($table)};
 738
 739   if ($@) {
 740     $self->_setError ("Unable to create new $table record:\n$@");
 741
 742     return;
 743   } # if
 744
 745   # First process all fields in @ordering, if specified
 746   foreach (@ordering) {
 747     if ($values{$_}) {
 748       $self->{errmsg} = $self->_setFieldValue ($entity, $table, $_, $values{$_});
 749     } else {
 750       $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
 751     } # if
 752
 753     last unless $self->{errmsg} eq '';
 754   } # foreach
 755
 756   return unless $self->{errmsg} eq '';
 757
 758   # Now process the rest of the values
 759   foreach my $fieldName (keys %values) {
 760     next if grep {$fieldName eq $_} @ordering;
 761
 762     $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
 763
 764     last unless $self->{errmsg} eq '';
 765   } # foreach
 766
 767   $self->_setError ($self->{errmsg});
 768
 769   return unless $self->{errmsg} eq '';
 770
 771   $self->{errmsg} = $self->_commitRecord ($entity);
 772   $self->{error}  = $self->{errmsg} eq '' ? 0 : 1;
 773
 774   my $dbid = $entity->GetFieldValue ('dbid')->GetValue;
 775
 776   return $dbid;
 777 } # add
 778
 779 sub connect (;$$$$) {
 780   my ($self, $username, $password, $database, $dbset) = @_;
 781
 782 =pod
 783
 784 =head2 connect (;$$$$)
 785
 786 Connect to the Clearquest database. You can supply parameters such as username,
 787 password, etc and they will override any passed to Clearquest::new (or those
 788 coming from ../etc/cq.conf)
 789
 790 Parameters:
 791
 792 =for html <blockquote>
 793
 794 =over
 795
 796 =item $username
 797
 798 Username to use to connect to the database
 799
 800 =item $password
 801
 802 Password to use to connect to the database
 803
 804 =item $database
 805
 806 Clearquest database to connect to
 807
 808 =item $dbset
 809
 810 Database set to connect to (Default: Connect to the default dbset)
 811
 812 =back
 813
 814 =for html </blockquote>
 815
 816 Returns:
 817
 818 =for html <blockquote>
 819
 820 =over
 821
 822 =item 1
 823
 824 =back
 825
 826 =for html </blockquote>
 827
 828 =cut
 829
 830   return unless $self->{module} eq 'api';
 831
 832   eval {require CQPerlExt};
 833
 834   croak "Unable to use Rational's CQPerlExt library - "
 835       . "You must use cqperl to use the Clearquest API back end\n$@" if $@;
 836
 837   $self->{username} = $username if $username;
 838   $self->{password} = $password if $password;
 839   $self->{database} = $database if $database;
 840   $self->{dbset}    = $dbset    if $dbset;
 841
 842   $self->{session} = CQSession::Build ();
 843
 844   $self->{loggedin} = 0;
 845
 846   eval {
 847     $self->{session}->UserLogon ($self->{username},
 848                                  $self->{password},
 849                                  $self->{database},
 850                                  $self->{dbset});
 851   };
 852
 853   if ($@) {
 854     chomp ($@);
 855
 856     $self->_setError ($@, 1);
 857   } else {
 858     $self->{loggedin} = 1;
 859
 860     $self->_setError ($_, 0);
 861   } # if
 862
 863   return $self->{loggedin};
 864 } # connect
 865
 866 sub connected () {
 867   my ($self) = @_;
 868
 869 =pod
 870
 871 =head2 connected ()
 872
 873 Returns 1 if we are currently connected to Clearquest
 874
 875 Parameters:
 876
 877 =for html <blockquote>
 878
 879 =over
 880
 881 =item none
 882
 883 =back
 884
 885 =for html </blockquote>
 886
 887 Returns:
 888
 889 =for html <blockquote>
 890
 891 =over
 892
 893 =item 1 if logged in - 0 if not
 894
 895 =back
 896
 897 =for html </blockquote>
 898
 899 =cut
 900
 901   return $self->{loggedin};
 902 } # connected
 903
 904 sub connection ($) {
 905   my ($self, $fullyQualify) = @_;
 906
 907 =pod
 908
 909 =head2 connection ()
 910
 911 Returns a connection string that describes the current connection
 912
 913 Parameters:
 914
 915 =for html <blockquote>
 916
 917 =over
 918
 919 =item $fullyQualify
 920
 921 If true the connection string will be fully qualified
 922
 923 =back
 924
 925 =for html </blockquote>
 926
 927 Returns:
 928
 929 =for html <blockquote>
 930
 931 =over
 932
 933 =item $connectionStr
 934
 935 A string describing the current connection. Generally
 936 <username>@<database>[/<dbset>]. Note that <dbset> is only displayed if it is
 937 not the default DBSet as defined in cq.conf.
 938
 939 =back
 940
 941 =for html </blockquote>
 942
 943 =cut
 944
 945   my $connectionStr = $self->username ()
 946                     . '@'
 947                     . $self->database ();
 948
 949   if ($fullyQualify) {
 950     $connectionStr .= '/' . $self->dbset;
 951   } else {
 952     $connectionStr .= '/' . $self->dbset () unless $self->dbset eq $DEFAULT_DBSET;
 953   } # if
 954
 955   return $connectionStr;
 956 } # connection
 957
 958 sub checkErr (;$$) {
 959   my ($self, $msg, $die) = @_;
 960
 961 =pod
 962
 963 =head2 checkErr (;$$)
 964
 965 Checks for error in the last Clearquest method call and prints error to STDERR.
 966 Optionally prints a user message if $msg is specified. Dies if $die is true
 967
 968 Parameters:
 969
 970 =for html <blockquote>
 971
 972 =over
 973
 974 =item $msg
 975
 976 User error message
 977
 978 =item $die
 979
 980 Causes caller to croak if set to true
 981
 982 =back
 983
 984 =for html </blockquote>
 985
 986 Returns:
 987
 988 =for html <blockquote>
 989
 990 =over
 991
 992 =item $error
 993
 994 Returns 0 for no error, non-zero if error.
 995
 996 =back
 997
 998 =for html </blockquote>
 999
1000 =cut
1001
1002   $die ||= 0;
1003
1004   if ($self->{error}) {
1005     if ($msg) {
1006       $msg .= "\n" . $self->errmsg . "\n";
1007     } else {
1008       $msg = $self->errmsg . "\n";
1009     } # if
1010
1011     if ($die) {
1012       croak $msg if $die;
1013     } else {
1014       print STDERR "$msg\n";
1015
1016       return $self->{error};
1017     } # if
1018   } # if
1019
1020   return 0;
1021 } # checkErr
1022
1023 sub database () {
1024   my ($self) = @_;
1025
1026 =pod
1027
1028 =head2 database
1029
1030 Returns the current database (or the database that would be used)
1031
1032 Parameters:
1033
1034 =for html <blockquote>
1035
1036 =over
1037
1038 =item none
1039
1040 =back
1041
1042 =for html </blockquote>
1043
1044 Returns:
1045
1046 =for html <blockquote>
1047
1048 =over
1049
1050 =item database
1051
1052 =back
1053
1054 =for html </blockquote>
1055
1056 =cut
1057
1058   return $self->{database};
1059 } # database
1060
1061 sub dbset () {
1062   my ($self) = @_;
1063
1064 =pod
1065
1066 =head2 dbset
1067
1068 Returns the current dbset (or the dbset that would be used)
1069
1070 Parameters:
1071
1072 =for html <blockquote>
1073
1074 =over
1075
1076 =item none
1077
1078 =back
1079
1080 =for html </blockquote>
1081
1082 Returns:
1083
1084 =for html <blockquote>
1085
1086 =over
1087
1088 =item dbset
1089
1090 =back
1091
1092 =for html </blockquote>
1093
1094 =cut
1095
1096   return $self->{dbset};
1097 } # dbset
1098
1099 sub dbsets () {
1100   my ($self) = @_;
1101
1102 =pod
1103
1104 =head2 dbsets ()
1105
1106 Return the installed DBSets for this schema
1107
1108 Parameters:
1109
1110 =for html <blockquote>
1111
1112 =over
1113
1114 =item none
1115
1116 =back
1117
1118 =for html </blockquote>
1119
1120 Returns:
1121
1122 =for html <blockquote>
1123
1124 =over
1125
1126 =item @dbsets
1127
1128 An array of dbsets
1129
1130 =back
1131
1132 =for html </blockquote>
1133
1134 =cut
1135
1136   unless ($self->connected) {
1137     $self->_setError ('You must connect to Clearquest before you can call DBSets', '-1');
1138
1139     return;
1140   } # unless
1141
1142   return @{$self->{session}->GetInstalledDbSets};
1143 } # dbsets
1144
1145 sub delete ($;$) {
1146   my ($self, $table, $key) = @_;
1147
1148 =pod
1149
1150 =head2 delete ($;$)
1151
1152 Deletes records from the database
1153
1154 Parameters:
1155
1156 =for html <blockquote>
1157
1158 =over
1159
1160 =item $table
1161
1162 Table to delete records from
1163
1164 =item $key
1165
1166 Key of the record to delete
1167
1168 =back
1169
1170 =for html </blockquote>
1171
1172 Returns:
1173
1174 =for html <blockquote>
1175
1176 =over
1177
1178 =item $errmsg
1179
1180 Error message or blank if no error
1181
1182 =back
1183
1184 =for html </blockquote>
1185
1186 =cut
1187
1188   my $entity;
1189
1190   eval {$entity = $self->{session}->GetEntity ($table, $key)};
1191
1192   if ($@) {
1193     $self->_setError ($@, 1);
1194
1195     return $@;
1196   } # if
1197
1198   eval {$self->{session}->DeleteEntity ($entity, 'Delete')};
1199
1200   if ($@) {
1201     $self->_setError ($@, 1);
1202
1203     return $@;
1204   } # if
1205
1206   return  '';
1207 } # delete
1208
1209 sub DESTROY () {
1210   my ($self) = @_;
1211
1212   CQSession::Unbuild ($self->{session}) if $self->{session};
1213
1214   return;
1215 } # DESTROY
1216
1217 sub disconnect () {
1218   my ($self) = @_;
1219
1220 =pod
1221
1222 =head2 disconnect ()
1223
1224 Disconnect from Clearquest
1225
1226 Parameters:
1227
1228 =for html <blockquote>
1229
1230 =over
1231
1232 =item none
1233
1234 =back
1235
1236 =for html </blockquote>
1237
1238 Returns:
1239
1240 =for html <blockquote>
1241
1242 =over
1243
1244 =item nothing
1245
1246 =back
1247
1248 =for html </blockquote>
1249
1250 =cut
1251
1252   CQSession::Unbuild ($self->{session});
1253
1254   undef $self->{session};
1255
1256   $self->{loggedin} = 0;
1257
1258   return;
1259 } # disconnect
1260
1261 sub errmsg (;$) {
1262   my ($self, $errmsg) = @_;
1263
1264 =pod
1265
1266 =head2 errmsg ()
1267
1268 Returns the last error message. Optionally sets the error message if specified.
1269
1270 Parameters:
1271
1272 =for html <blockquote>
1273
1274 =over
1275
1276 =item $errmsg
1277
1278 =back
1279
1280 =for html </blockquote>
1281
1282 Returns:
1283
1284 =for html <blockquote>
1285
1286 =over
1287
1288 =item $errmsg
1289
1290 Last $errmsg
1291
1292 =back
1293
1294 =for html </blockquote>
1295
1296 =cut
1297
1298   $self->{errmsg} = $errmsg if $errmsg;
1299
1300   return $self->{errmsg};
1301 } # errmsg
1302
1303 sub error (;$) {
1304   my ($self, $error) = @_;
1305
1306 =pod
1307
1308 =head2 error ($error)
1309
1310 Returns the last error number. Optional set the error number if specified
1311
1312 Parameters:
1313
1314 =for html <blockquote>
1315
1316 =over
1317
1318 =item $error
1319
1320 Error number to set
1321
1322 =back
1323
1324 =for html </blockquote>
1325
1326 Returns:
1327
1328 =for html <blockquote>
1329
1330 =over
1331
1332 =item $error
1333
1334 Last error
1335
1336 =back
1337
1338 =for html </blockquote>
1339
1340 =cut
1341
1342   $self->{error} = $error if defined $error;
1343
1344   return $self->{error};
1345 } # error
1346
1347 sub fieldType ($$) {
1348   my ($self, $table, $fieldName) = @_;
1349
1350 =pod
1351
1352 =head2 fieldType ($table, $fieldname)
1353
1354 Returns the field type for the $table, $fieldname combination.
1355
1356 Parameters:
1357
1358 =for html <blockquote>
1359
1360 =over
1361
1362 =item $table
1363
1364 Table to return field type from.
1365
1366 =item $fieldname
1367
1368 Fieldname to return the field type from.
1369
1370 =back
1371
1372 =for html </blockquote>
1373
1374 Returns:
1375
1376 =for html <blockquote>
1377
1378 =over
1379
1380 =item $fieldType
1381
1382 Fieldtype enum
1383
1384 =back
1385
1386 =for html </blockquote>
1387
1388 =cut
1389
1390   return $UNKNOWN unless $self->{loggedin};
1391
1392   # If we've already computed the fieldTypes for the fields in this table then
1393   # return the value
1394   if ($FIELDS{$table}) {
1395     # If we already have this fieldType just return it
1396     if (defined $FIELDS{$table}{$fieldName}) {
1397       return $FIELDS{$table}{$fieldName}
1398     } else {
1399       return $UNKNOWN
1400     } # if
1401   } # if
1402
1403   my $entityDef = $self->{session}->GetEntityDef ($table);
1404
1405   foreach (@{$entityDef->GetFieldDefNames}) {
1406     $FIELDS{$table}{$_} = $entityDef->GetFieldDefType ($_);
1407   } # foreach
1408
1409   if (defined $FIELDS{$table}{$fieldName}) {
1410     return $FIELDS{$table}{$fieldName}
1411   } else {
1412     return $UNKNOWN
1413   } # if
1414 } # fieldType
1415
1416 sub fieldTypeName ($$) {
1417   my ($self, $table, $fieldName) = @_;
1418
1419 =pod
1420
1421 =head2 fieldTypeName ($table, $fieldname)
1422
1423 Returns the field type name for the $table, $fieldname combination.
1424
1425 Parameters:
1426
1427 =for html <blockquote>
1428
1429 =over
1430
1431 =item $table
1432
1433 Table to return field type from.
1434
1435 =item $fieldname
1436
1437 Fieldname to return the field type from.
1438
1439 =back
1440
1441 =for html </blockquote>
1442
1443 Returns:
1444
1445 =for html <blockquote>
1446
1447 =over
1448
1449 =item $fieldTypeName
1450
1451 Fieldtype name
1452
1453 =back
1454
1455 =for html </blockquote>
1456
1457 =cut
1458
1459   my $fieldType = $self->fieldType ($table, $fieldName);
1460
1461   return $UNKNOWN unless $fieldType;
1462
1463   if ($fieldType == $STRING) {
1464     return "STRING";
1465   } elsif ($fieldType == $MULTILINE_STRING) {
1466     return "MULTILINE_STRING";
1467   } elsif ($fieldType == $INT) {
1468     return "INT";
1469   } elsif ($fieldType == $DATE_TIME) {
1470     return "DATE_TIME";
1471   } elsif ($fieldType == $REFERENCE) {
1472     return "REFERENCE"
1473   } elsif ($fieldType == $REFERENCE_LIST) {
1474     return "REFERENCE_LIST";
1475   } elsif ($fieldType == $ATTACHMENT_LIST) {
1476     return "ATTACHMENT_LIST";
1477   } elsif ($fieldType == $ID) {
1478     return "ID";
1479   } elsif ($fieldType == $STATE) {
1480     return "STATE";
1481   } elsif ($fieldType == $JOURNAL) {
1482     return "JOURNAL";
1483   } elsif ($fieldType == $DBID) {
1484     return "DBID";
1485   } elsif ($fieldType == $STATETYPE) {
1486     return "STATETYPE";
1487   } elsif ($fieldType == $RECORD_TYPE) {
1488     return "RECORD_TYPE";
1489   } elsif ($fieldType == $UNKNOWN) {
1490     return "UNKNOWN";
1491   } # if
1492 } # fieldTypeName
1493
1494 sub find ($;$@) {
1495   my ($self, $table, $condition, @fields) = @_;
1496
1497 =pod
1498
1499 =head2 find ($;$@)
1500
1501 Find records in $table. You can specify a $condition and which fields you wish
1502 to retrieve. Specifying a smaller set of fields means less data transfered and
1503 quicker retrieval so only retrieve the fields you really need.
1504
1505 Parameters:
1506
1507 =for html <blockquote>
1508
1509 =over
1510
1511 =item $table
1512
1513 Name of the table to search
1514
1515 =item $condition
1516
1517 Condition to use. If you want all records then pass in undef. Only simple
1518 conditions are supported. You can specify compound conditions (e.g. field1 ==
1519 'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
1520 supported (yet).
1521
1522 The following conditionals are supported
1523
1524 =over
1525
1526 =item Equal (==|=)
1527
1528 =item Not Equal (!=|<>)
1529
1530 =item Less than (<)
1531
1532 =item Greater than (>)
1533
1534 =item Less than or equal (<=)
1535
1536 =item Greater than or equal (>=)
1537
1538 =item Like
1539
1540 =item Is null
1541
1542 =item Is not null
1543
1544 =item In
1545
1546 =back
1547
1548 Note that "is not null" is currently not working in the REST module (it works
1549 in the api and thus also in the client/server model). This because the
1550 OLSC spec V1.0 does not support it.
1551
1552 As for "Like"", you'll need to specify "<fieldname> like '%var%'" for the
1553 condition.
1554
1555 "In" is only available in the REST interface as that's what OLSC supports. It's
1556 syntax would be "<fieldname> In 'value1', 'value2', 'value3'..."
1557
1558 Also conditions can be combined with (and|or) so in the api you could do "in"
1559 as "<fieldname> = 'value1 or <fieldname> = 'value2" or <fieldname> = 'value3'".
1560
1561 Complicated expressions with parenthesis like "(Project = 'Athena' or Project =
1562 'Hawaii') and Category = 'Aspen'" are not supported.
1563
1564 =item @fields
1565
1566 An array of fieldnames to retrieve
1567
1568 =back
1569
1570 =for html </blockquote>
1571
1572 Returns:
1573
1574 =for html <blockquote>
1575
1576 =over
1577
1578 =item $result or ($result, $nbrRecs)
1579
1580 Internal structure to be used with getNext. If in an array context then $nbrRecs
1581 is also returned.
1582
1583 =back
1584
1585 =for html </blockquote>
1586
1587 =cut
1588
1589   $condition ||= '';
1590
1591   unless ($self->connected) {
1592     $self->_setError ('You must connect to Clearquest before you can call find', '-1');
1593
1594     return;
1595   } # unless
1596
1597   my $entityDef;
1598
1599   eval {$entityDef = $self->{session}->GetEntityDef ($table)};
1600
1601   if ($@) {
1602     $self->_setError ($@, -1);
1603
1604     return ($@, -1);
1605   } # if
1606
1607   @fields = $self->_setFields ($table, @fields);
1608
1609   return unless @fields;
1610
1611   my $query = $self->{session}->BuildQuery ($table);
1612
1613   foreach (@fields) {
1614     eval {$query->BuildField ($_)};
1615
1616     if ($@) {
1617       $self->_setError ($@);
1618
1619       carp $@;
1620     } # if
1621   } # foreach
1622
1623   $self->_parseConditional ($query, $condition);
1624
1625   return if $self->error;
1626
1627   my $result  = $self->{session}->BuildResultSet ($query);
1628   my $nbrRecs = $result->ExecuteAndCountRecords;
1629
1630   $self->_setError;
1631
1632   my %resultSet = (
1633     result => $result
1634   );
1635
1636   if (wantarray) {
1637     return (\%resultSet, $nbrRecs);
1638   } else {
1639     return \%resultSet
1640   } # if
1641 } # find
1642
1643 sub findIDs ($) {
1644   my ($str) = @_;
1645
1646 =pod
1647
1648 =head2 findIDs ($)
1649
1650 Given a $str or a reference to an array of strings, this function returns a list
1651 of Clearquest IDs found in the $str. If called in a scalar context this function
1652 returns a comma separated string of IDs found. Note that duplicate IDs are
1653 eliminated. Also, the lists of IDs may refer to different Clearquest databases.
1654
1655 Parameters:
1656
1657 =for html <blockquote>
1658
1659 =over
1660
1661 =item $str
1662
1663 String or reference to an array of strings to search
1664
1665 =back
1666
1667 =for html </blockquote>
1668
1669 Returns:
1670
1671 =for html <blockquote>
1672
1673 =over
1674
1675 =item @IDs or $strIDs
1676
1677 Either an array of CQ IDs or a comma separated list of CQ IDs.
1678
1679 =back
1680
1681 =for html </blockquote>
1682
1683 =cut
1684
1685   $str = join ' ', @$str if ref $str eq 'ARRAY';
1686
1687   my @IDs = $str =~ /([A-Za-z]\w{1,4}\d{8})/gs;
1688
1689   my %IDs;
1690
1691   map { $IDs{$_} = 1; } @IDs;
1692
1693   if (wantarray) {
1694     return keys %IDs;
1695   } else {
1696     return join ',', keys %IDs;
1697   } # if
1698 } # findIDs
1699
1700 sub get ($$;@) {
1701   my ($self, $table, $id, @fields) = @_;
1702
1703 =pod
1704
1705 =head2 get ($$)
1706
1707 Return a record that you have the id or key of.
1708
1709 Parameters:
1710
1711 =for html <blockquote>
1712
1713 =over
1714
1715 =item $table
1716
1717 The $table to get the record from
1718
1719 =item $id
1720
1721 The $id or key to use to retrieve the record
1722
1723 =back
1724
1725 =for html </blockquote>
1726
1727 Returns:
1728
1729 =for html <blockquote>
1730
1731 =over
1732
1733 =item %record
1734
1735 Hash of name/value pairs for all the fields in $table
1736
1737 =back
1738
1739 =for html </blockquote>
1740
1741 =cut
1742
1743   unless ($self->connected) {
1744     $self->_setError ('You must connect to Clearquest before you can call get', '-1');
1745
1746     return;
1747   } # unless
1748
1749   @fields = $self->_setFields ($table, @fields);
1750
1751   return unless @fields;
1752
1753   my $entity;
1754
1755   eval {$entity = $self->{session}->GetEntity ($table, $id)};
1756
1757   if ($@) {
1758     $self->_setError ($@);
1759
1760     return;
1761   } # if
1762
1763   my %record;
1764
1765   foreach (@fields) {
1766     my $fieldType = $entity->GetFieldValue ($_)->GetType;
1767
1768     if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
1769       $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
1770     } else {
1771       $record{$_}   = $entity->GetFieldValue ($_)->GetValue;
1772       $record{$_} ||= '' if $self->{emptyStringForUndef};
1773
1774       # Fix any UTC dates
1775       if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
1776         $record{$_} = _UTC2Localtime ($record{$_});
1777       } # if
1778     } # if
1779   } # foreach
1780
1781   $self->_setError;
1782
1783   return %record;
1784 } # get
1785
1786 sub getDBID ($$;@) {
1787   my ($self, $table, $dbid, @fields) = @_;
1788
1789 =pod
1790
1791 =head2 getDBID ($$;@)
1792
1793 Return a record that you have the dbid
1794
1795 Parameters:
1796
1797 =for html <blockquote>
1798
1799 =over
1800
1801 =item $table
1802
1803 The $table to get the record from
1804
1805 =item $dbid
1806
1807 The $dbid to use to retrieve the record
1808
1809 =item @fields
1810
1811 Array of field names to retrieve (Default: All fields)
1812
1813 Note: Avoid getting all fields for large records. It will be slow and bloat your
1814 script's memory usage.
1815
1816 =back
1817
1818 =for html </blockquote>
1819
1820 Returns:
1821
1822 =for html <blockquote>
1823
1824 =over
1825
1826 =item %record
1827
1828 Hash of name/value pairs for all the fields in $table
1829
1830 =back
1831
1832 =for html </blockquote>
1833
1834 =cut
1835
1836   unless ($self->connected) {
1837     $self->_setError ('You must connect to Clearquest before you can call getDBID', '-1');
1838
1839     return;
1840   } # unless
1841
1842   @fields = $self->_setFields ($table, @fields);
1843
1844   return if @fields;
1845
1846   my $entity;
1847
1848   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
1849
1850   if ($@) {
1851     $self->_setError ($@);
1852
1853     return;
1854   } # if
1855
1856   my %record;
1857
1858   foreach (@fields) {
1859     my $fieldType = $entity->GetFieldValue ($_)->GetType;
1860
1861     if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
1862       $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
1863     } else {
1864       $record{$_}   = $entity->GetFieldValue ($_)->GetValue;
1865       $record{$_} ||= '' if $self->{emptyStringForUndef};
1866
1867       # Fix any UTC dates
1868       if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
1869         $record{$_} = _UTC2Localtime ($record{$_});
1870       } # if
1871     } # if
1872   } # foreach
1873
1874   $self->_setError;
1875
1876   return %record;
1877 } # getDBID
1878
1879 sub getDynamicList ($) {
1880   my ($self, $list) = @_;
1881
1882 =pod
1883
1884 =head2 getDynamicList ($)
1885
1886 Return the entries of a dynamic list
1887
1888 Parameters:
1889
1890 =for html <blockquote>
1891
1892 =over
1893
1894 =item $list
1895
1896 The name of the dynamic list
1897
1898 =back
1899
1900 =for html </blockquote>
1901
1902 Returns:
1903
1904 =for html <blockquote>
1905
1906 =over
1907
1908 =item @entries
1909
1910 An array of entries from the dynamic list
1911
1912 =back
1913
1914 =for html </blockquote>
1915
1916 =cut
1917
1918   return () unless $self->connected;
1919
1920   return @{$self->{session}->GetListMembers ($list)};
1921 } # getDynamicList
1922
1923 sub getNext ($) {
1924   my ($self, $result) = @_;
1925
1926 =pod
1927
1928 =head2 getNext ($)
1929
1930 Return the next record that qualifies from a preceeding call to the find method.
1931
1932 Parameters:
1933
1934 =for html <blockquote>
1935
1936 =over
1937
1938 =item $result
1939
1940 The $result returned from find.
1941
1942 =back
1943
1944 =for html </blockquote>
1945
1946 Returns:
1947
1948 =for html <blockquote>
1949
1950 =over
1951
1952 =item %record
1953
1954 Hash of name/value pairs for the @fields specified to find.
1955
1956 =back
1957
1958 =for html </blockquote>
1959
1960 =cut
1961
1962   unless ($self->connected) {
1963     $self->_setError ('You must connect to Clearquest before you can call getNext', '-1');
1964
1965     return;
1966   } # unless
1967
1968 # Here we need to do special processing to gather up reference list fields, if
1969 # any. If we have a reference list field in the field list then Clearquest
1970 # returns multiple records - one for each entry in the reference list. Thus if
1971 # you were getting say the key field of a record and a reference list field like
1972 # say Projects, you might see:
1973 #
1974 # Key Value     Projects
1975 # ---------     --------
1976 # key1          Athena
1977 # key1          Apollo
1978 # key1          Gemini
1979 #
1980 # Things get combinatoric when multiple reference list fields are involved. Our
1981 # strategy here is to keep gathering all fields that change into arrays assuming
1982 # they are reference fields as long as the dbid field has not changed.
1983 my %record;
1984
1985 while () {
1986   unless ($result->{lastDBID}) {
1987     # Move to the first record
1988     last unless $result->{result}->MoveNext == $CQPerlExt::CQ_SUCCESS;
1989   } elsif ($result->{lastDBID} == $result->{thisDBID}) {
1990     # If the dbid is the same then we have at least one reference list field
1991     # in the request so we need to move to the next record
1992     last unless $result->{result}->MoveNext == $CQPerlExt::CQ_SUCCESS;
1993   } else {
1994     # If lastDBID != thisDBID then set lastDBID to thisDBID so we can process
1995     # this group
1996     $result->{lastDBID} = $result->{thisDBID};
1997
1998     delete $result->{lastRecord};
1999   } # unless
2000
2001   my $nbrColumns = $result->{result}->GetNumberOfColumns;
2002
2003   my $column = 1;
2004
2005   # Format %record
2006   while ($column <= $nbrColumns) {
2007     my $value = $result->{result}->GetColumnValue ($column);
2008
2009     $value ||= '' if $self->{emptyStringForUndef};
2010
2011     # Fix any UTC dates - _UTC2Localtime will only modify data if the data
2012     # matches a UTC datetime.
2013     $value = _UTC2Localtime ($value);
2014
2015     $record{$result->{result}->GetColumnLabel ($column++)} = $value;
2016   } # while
2017
2018   %{$result->{lastRecord}} = %record unless $result->{lastRecord};
2019
2020   # Store this record's DBID
2021   $result->{thisDBID} = $record{dbid};
2022
2023   if ($result->{lastDBID}) {
2024     if ($result->{thisDBID} == $result->{lastDBID}) {
2025       # Since the dbid's are the same, we have at least one reference list field
2026       # and we need to compare all fields
2027       foreach my $field (keys %record) {
2028         # If the field is blank then skip it
2029         next if $record{$field} eq '';
2030
2031         # Here we check the field in %lastRecord to see if it was a reference
2032         # list with more than one entry.
2033         if (ref \$result->{lastRecord}{$field} eq 'ARRAY') {
2034           # Check to see if this entry is already in the list of current entries
2035           next if grep {/^$record{$field}$/} @{$result->{lastRecord}{$field}};
2036         } # if
2037
2038         # This checks to see if the current field is a scalar and we have a new
2039         # value, then the scalar needs to be changed to an array
2040         if (ref \$result->{lastRecord}{$field} eq 'SCALAR') {
2041           # If the field is the same value then no change, no array. We do next
2042           # to start processing the next field
2043           next if $result->{lastRecord}{$field} eq $record{$field};
2044
2045           # Changed $lastRecord{$_} to a reference to an ARRAY
2046           $result->{lastRecord}{$field} = [$result->{lastRecord}{$field}, $record{$field}];
2047         } else {
2048           # Push the value only if it does not already exists in the array
2049           push @{$result->{lastRecord}{$field}}, $record{$field}
2050             unless grep {/^$record{$field}$/} @{$result->{lastRecord}{$field}};
2051         } # if
2052       } # foreach
2053
2054       # Transfer %lastRecord -> %record
2055       %record = %{$result->{lastRecord}};
2056     } else {
2057       %record = %{$result->{lastRecord}};
2058
2059       last;
2060     } # if
2061   } # if
2062
2063   # The $lastDBID is now $thisDBID
2064   $result->{lastDBID} = $result->{thisDBID};
2065
2066   # Update %lastRecord
2067   %{$result->{lastRecord}} = %record;
2068 } # while
2069
2070   $self->_setError;
2071
2072   return %record;
2073 } # getNext
2074
2075 sub id2db ($) {
2076   my ($ID) = @_;
2077
2078 =pod
2079
2080 =head2 id2db ($)
2081
2082 This function returns the database name given an ID.
2083
2084 Parameters:
2085
2086 =for html <blockquote>
2087
2088 =over
2089
2090 =item $ID
2091
2092 The ID to extract the database name from
2093
2094 =back
2095
2096 =for html </blockquote>
2097
2098 Returns:
2099
2100 =for html <blockquote>
2101
2102 =over
2103
2104 =item $database
2105
2106 Returns the name of the database the ID is part of or undef if not found.
2107
2108 =back
2109
2110 =for html </blockquote>
2111
2112 =cut
2113
2114   if ($ID =~ /([A-Za-z]\w{1,4})\d{8}/) {
2115     return $1;
2116   } else {
2117     return;
2118   } # if
2119 } # id2db
2120
2121 sub key ($$) {
2122   my ($self, $table, $dbid) = @_;
2123
2124 =pod
2125
2126 =head2 key ($$)
2127
2128 Return the key of the record given a $dbid
2129
2130 Parameters:
2131
2132 =for html <blockquote>
2133
2134 =over
2135
2136 =item $table
2137
2138 Name of the table to lookup
2139
2140 =item $dbid
2141
2142 Database ID of the record to retrieve
2143
2144 =back
2145
2146 =for html </blockquote>
2147
2148 Returns:
2149
2150 =for html <blockquote>
2151
2152 =over
2153
2154 =item key
2155
2156 =back
2157
2158 =for html </blockquote>
2159
2160 =cut
2161
2162   unless ($self->connected) {
2163     $self->_setError ('You must connect to Clearquest before you can call key', '-1');
2164
2165     return;
2166   } # unless
2167
2168   my $entity;
2169
2170   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
2171
2172   return $entity->GetDisplayName;
2173 } # key
2174
2175 sub modify ($$$$;@) {
2176   my ($self, $table, $key, $action, $values, @ordering) = @_;
2177
2178 =pod
2179
2180 =head2 modify ($$$$;@)
2181
2182 Update record(s)
2183
2184 Parameters:
2185
2186 =for html <blockquote>
2187
2188 =over
2189
2190 =item $table
2191
2192 The $table to get the record from
2193
2194 =item $key
2195
2196 The $key identifying the record to modify
2197
2198 =item $action
2199
2200 Action to perform the modification under. Default is 'Modify'.
2201
2202 =item $values
2203
2204 Hash reference containing name/value that have the new values for the fields
2205
2206 =item @ordering
2207
2208 Array containing field names that need to be processed in order. Not all fields
2209 mentioned in the $values hash need be mentioned here. If you have fields that
2210 must be set in a particular order you can mention them here. So, if you're
2211 modifying the Defect record, but you need Project set before Platform,  you need
2212 only pass in an @ordering of qw(Project Platform). They will be done first, then
2213 all of the rest of the fields in the $values hash. If you have no ordering
2214 dependencies then you can simply omit @ordering.
2215
2216 Note that the best way to determine if you have an ordering dependency try using
2217 a Clearquest client and note the order that you set fields in. If at anytime
2218 setting one field negates another field via action hook code then you have just
2219 figured out that this field needs to be set before the file that just got
2220 negated.
2221
2222 =back
2223
2224 =for html </blockquote>
2225
2226 Returns:
2227
2228 =for html <blockquote>
2229
2230 =over
2231
2232 =item $errmsg
2233
2234 The $errmsg, if any, when performing the update (empty string for success)
2235
2236 =back
2237
2238 =for html </blockquote>
2239
2240 =cut
2241
2242   unless ($self->connected) {
2243     $self->_setError ('You must connect to Clearquest before you can call modify', '-1');
2244
2245     return $self->{errmsg};
2246   } # unless
2247
2248   my %record = $self->get ($table, $key, qw(dbid));
2249
2250   return $self->modifyDBID ($table, $record{dbid}, $action, $values, @ordering);
2251 } # modify
2252
2253 sub modifyDBID ($$$$;@) {
2254   my ($self, $table, $dbid, $action, $values, @ordering) = @_;
2255
2256 =pod
2257
2258 =head2 modifyDBID ($$$%)
2259
2260 Update a unique record (by DBID)
2261
2262 Parameters:
2263
2264 =for html <blockquote>
2265
2266 =over
2267
2268 =item $table
2269
2270 The $table to get the record from
2271
2272 =item $dbid
2273
2274 The $dbid of the record to update. Note that the find method always includes the
2275 dbid of a record in the hash that it returns.
2276
2277 =item $action
2278
2279 Action to perform the modification under. Default is 'Modify'.
2280
2281 =item %update
2282
2283 Hash containing name/value that have the new values for the fields
2284
2285 =back
2286
2287 =for html </blockquote>
2288
2289 Returns:
2290
2291 =for html <blockquote>
2292
2293 =over
2294
2295 =item $errmsg
2296
2297 The $errmsg, if any, when performing the update (empty string for success)
2298
2299 =back
2300
2301 =for html </blockquote>
2302
2303 =cut
2304   $action ||= 'Modify';
2305
2306   my %values = %$values;
2307
2308   my $entity;
2309
2310   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
2311
2312   if ($@) {
2313     $self->_setError ($@);
2314
2315     return;
2316   } # if
2317
2318   eval {$entity->EditEntity ($action)};
2319
2320   if ($@) {
2321     $self->_setError ($@);
2322
2323     return $@;
2324   } # if
2325
2326   # First process all fields in @ordering, if specified
2327   foreach (@ordering) {
2328     if ($values{$_}) {
2329       $self->{errmsg} = $self->_setFieldValue ($table, $_, $values{$_});
2330     } else {
2331       $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
2332     } # if
2333
2334     last unless $self->{errmsg} eq '';
2335   } # foreach
2336
2337   return $self->{errmsg} unless $self->{errmsg} eq '';
2338
2339   # Now process the rest of the values
2340   foreach my $fieldName (keys %values) {
2341     next if grep {$fieldName eq $_} @ordering;
2342
2343     $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
2344
2345     last unless $self->{errmsg} eq '';
2346   } # foreach
2347
2348   $self->_setError ($self->{errmsg});
2349
2350   return $self->{errmsg} unless $self->{errmsg} eq '';
2351
2352   $self->{errmsg} = $self->_commitRecord ($entity);
2353   $self->{error}  = $self->{errmsg} eq '' ? 0 : 1;
2354
2355   return $self->{errmsg};
2356 } # modifyDBID
2357
2358 sub module () {
2359   my ($self) = @_;
2360
2361 =pod
2362
2363 =head2 module
2364
2365 Returns the current back end module we are using
2366
2367 Parameters:
2368
2369 =for html <blockquote>
2370
2371 =over
2372
2373 =item none
2374
2375 =back
2376
2377 =for html </blockquote>
2378
2379 Returns:
2380
2381 =for html <blockquote>
2382
2383 =over
2384
2385 =item module
2386
2387 =back
2388
2389 =for html </blockquote>
2390
2391 =cut
2392
2393   return $self->{module};
2394 } # module
2395
2396 sub new (;%) {
2397   my ($class, %parms) = @_;
2398
2399 =pod
2400
2401 =head2 new ()
2402
2403 Construct a new Clearquest object.
2404
2405 Parameters:
2406
2407 Below are the key values for the %parms hash.
2408
2409 =for html <blockquote>
2410
2411 =over
2412
2413 =item CQ_SERVER
2414
2415 Webhost for REST module
2416
2417 =item CQ_USERNAME
2418
2419 Username to use to connect to the database
2420
2421 =item CQ_PASSWORD
2422
2423 Password to use to connect to the database
2424
2425 =item CQ_DATABASE
2426
2427 Clearquest database to connect to
2428
2429 =item CQ_DBSET
2430
2431 Database set to connect to
2432
2433 =item CQ_MODULE
2434
2435 One of 'rest', 'api' or 'client' (Default: From cq.conf). This determines which
2436 backend module will be used.
2437
2438 =back
2439
2440 =for html </blockquote>
2441
2442 Returns:
2443
2444 =for html <blockquote>
2445
2446 =over
2447
2448 =item Clearquest object
2449
2450 =back
2451
2452 =for html </blockquote>
2453
2454 =cut
2455
2456   $parms{CQ_DATABASE} ||= $OPTS{CQ_DATABASE};
2457   $parms{CQ_USERNAME} ||= $OPTS{CQ_USERNAME};
2458   $parms{CQ_PASSWORD} ||= $OPTS{CQ_PASSWORD};
2459   $parms{CQ_DBSET}    ||= $OPTS{CQ_DBSET};
2460
2461   my $self = bless {
2462     server              => $parms{CQ_SERVER},
2463     port                => $parms{CQ_PORT},
2464     database            => $parms{CQ_DATABASE},
2465     dbset               => $parms{CQ_DBSET},
2466     username            => $parms{CQ_USERNAME},
2467     password            => $parms{CQ_PASSWORD},
2468     emptyStringForUndef => 0,
2469     returnSystemFields  => 0,
2470   }, $class;
2471
2472   my $module = delete $parms{CQ_MODULE};
2473
2474   $module ||= $OPTS{CQ_MODULE};
2475
2476   $module = lc $module;
2477
2478   if ($module eq 'rest') {
2479     require Clearquest::REST;
2480
2481     $self->{webhost} = $parms{CQ_WEBHOST} || $OPTS{CQ_WEBHOST};
2482
2483     $self = Clearquest::REST->new ($self);
2484   } elsif ($module eq 'client') {
2485     require Clearquest::Client;
2486
2487     $self->{server} = $parms{CQ_SERVER} || $OPTS{CQ_SERVER};
2488     $self->{port}   = $parms{CQ_PORT}   || $OPTS{CQ_PORT};
2489
2490     $self = Clearquest::Client->new ($self);
2491   } elsif ($module ne 'api') {
2492     croak "Unknown interface requested - $module";
2493   } # if
2494
2495   $self->{module} = $module;
2496
2497   # Save reference to instaniated instance of this object to insure that global
2498   # variables are properly disposed of
2499   push @objects, $self;
2500
2501   return $self;
2502 } # new
2503
2504 sub server () {
2505   my ($self) = @_;
2506
2507 =pod
2508
2509 =head2 server
2510
2511 Returns the current server if applicable
2512
2513 Parameters:
2514
2515 =for html <blockquote>
2516
2517 =over
2518
2519 =item none
2520
2521 =back
2522
2523 =for html </blockquote>
2524
2525 Returns:
2526
2527 =for html <blockquote>
2528
2529 =over
2530
2531 =item $server
2532
2533 For api this will return ''. For REST and client/server this will return the
2534 server name that we are talking to.
2535
2536 =back
2537
2538 =for html </blockquote>
2539
2540 =cut
2541
2542   return $self->{server};
2543 } # server
2544
2545 sub setOpts (%) {
2546   my ($self, %opts) = @_;
2547
2548 =pod
2549
2550 =head2 setOpts
2551
2552 Set options for operating
2553
2554 Parameters:
2555
2556 =for html <blockquote>
2557
2558 =over
2559
2560 =item %opts
2561
2562 =back
2563
2564 Options to set. The only options currently supported are emptyStringForUndef
2565 and returnSystemFields. If set emptyStringForUndef will return empty strings for
2566 empty fields instead of undef. Default: Empty fields are represented with undef.
2567
2568 System-owned fields are used internally by IBM Rational ClearQuest to maintain
2569 information about the database. You should never modify system fields directly
2570 as it could corrupt the database. If returnSystemFields is set then system
2571 fields will be returned. Default: System fields will not be returned unless
2572 explicitly stated in the @fields parameter. This means that if you do not
2573 specify any fields in @fields, all fields will be returned except system fields,
2574 unless you set returnSystemFields via this method or you explicitly mention the
2575 system field in your @fields parameter.
2576
2577 =for html </blockquote>
2578
2579 Returns:
2580
2581 =for html <blockquote>
2582
2583 =over
2584
2585 =item Nothing
2586
2587 =back
2588
2589 =for html </blockquote>
2590
2591 =cut
2592
2593   $self->{emptyStringForUndef} = $opts{emptyStringForUndef}
2594     if $opts{emptyStringForUndef};
2595   $self->{returnSystemFields}  = $opts{returnSystemFields}
2596     if $opts{returnSystemFields};
2597 } # setOpts
2598
2599 sub getOpt ($) {
2600   my ($self, $option) = @_;
2601
2602 =pod
2603
2604 =head2 getOpt
2605
2606 Get option
2607
2608 Parameters:
2609
2610 =for html <blockquote>
2611
2612 =over
2613
2614 =item $option
2615
2616 =back
2617
2618 Option to retrieve. If non-existant then undef is returned.
2619
2620 =for html </blockquote>
2621
2622 Returns:
2623
2624 =for html <blockquote>
2625
2626 =over
2627
2628 =item $option or undef if option doesn't exist
2629
2630 =back
2631
2632 =for html </blockquote>
2633
2634 =cut
2635
2636   my @validOpts = qw (emptyStringForUndef returnSystemFields);
2637
2638   if (grep {$option eq $_} @validOpts) {
2639     return $self->{$option};
2640   } else {
2641     return;
2642   } # if
2643 } # getOpt
2644
2645 sub username () {
2646   my ($self) = @_;
2647
2648 =pod
2649
2650 =head2 username
2651
2652 Returns the current username (or the username that would be used)
2653
2654 Parameters:
2655
2656 =for html <blockquote>
2657
2658 =over
2659
2660 =item none
2661
2662 =back
2663
2664 =for html </blockquote>
2665
2666 Returns:
2667
2668 =for html <blockquote>
2669
2670 =over
2671
2672 =item username
2673
2674 =back
2675
2676 =for html </blockquote>
2677
2678 =cut
2679
2680   return $self->{username};
2681 } # username
2682
2683 sub webhost () {
2684   my ($self) = @_;
2685
2686   return $self->{webhost};
2687 } # webhost
2688
2689 1;
2690
2691 =pod
2692
2693 =head1 DEPENDENCIES
2694
2695 =head2 Perl Modules
2696
2697 L<File::Basename|File::Basename>
2698
2699 =head2 ClearSCM Perl Modules
2700
2701 =for html <p><a href="/php/scm_man.php?file=lib/GetConfig.pm">GetConfig</a></p>
2702
2703 =head1 BUGS AND LIMITATIONS
2704
2705 There are no known bugs in this module
2706
2707 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
2708
2709 =head1 LICENSE AND COPYRIGHT
2710
2711 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
2712
2713 =cut