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