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   # Watch here as $error can very well be 0 which "if $error" would evaluate
1348   # to false leaving $self->{error} undefined
1349   $self->{error} = $error if defined $error;
1350
1351   return $self->{error};
1352 } # error
1353
1354 sub fieldType ($$) {
1355   my ($self, $table, $fieldName) = @_;
1356
1357 =pod
1358
1359 =head2 fieldType ($table, $fieldname)
1360
1361 Returns the field type for the $table, $fieldname combination.
1362
1363 Parameters:
1364
1365 =for html <blockquote>
1366
1367 =over
1368
1369 =item $table
1370
1371 Table to return field type from.
1372
1373 =item $fieldname
1374
1375 Fieldname to return the field type from.
1376
1377 =back
1378
1379 =for html </blockquote>
1380
1381 Returns:
1382
1383 =for html <blockquote>
1384
1385 =over
1386
1387 =item $fieldType
1388
1389 Fieldtype enum
1390
1391 =back
1392
1393 =for html </blockquote>
1394
1395 =cut
1396
1397   return $UNKNOWN unless $self->{loggedin};
1398
1399   # If we've already computed the fieldTypes for the fields in this table then
1400   # return the value
1401   if ($FIELDS{$table}) {
1402     # If we already have this fieldType just return it
1403     if (defined $FIELDS{$table}{$fieldName}) {
1404       return $FIELDS{$table}{$fieldName}
1405     } else {
1406       return $UNKNOWN
1407     } # if
1408   } # if
1409
1410   my $entityDef = $self->{session}->GetEntityDef ($table);
1411
1412   for (@{$entityDef->GetFieldDefNames}) {
1413     $FIELDS{$table}{$_} = $entityDef->GetFieldDefType ($_);
1414   } # for
1415
1416   if (defined $FIELDS{$table}{$fieldName}) {
1417     return $FIELDS{$table}{$fieldName}
1418   } else {
1419     return $UNKNOWN
1420   } # if
1421 } # fieldType
1422
1423 sub fieldTypeName ($$) {
1424   my ($self, $table, $fieldName) = @_;
1425
1426 =pod
1427
1428 =head2 fieldTypeName ($table, $fieldname)
1429
1430 Returns the field type name for the $table, $fieldname combination.
1431
1432 Parameters:
1433
1434 =for html <blockquote>
1435
1436 =over
1437
1438 =item $table
1439
1440 Table to return field type from.
1441
1442 =item $fieldname
1443
1444 Fieldname to return the field type from.
1445
1446 =back
1447
1448 =for html </blockquote>
1449
1450 Returns:
1451
1452 =for html <blockquote>
1453
1454 =over
1455
1456 =item $fieldTypeName
1457
1458 Fieldtype name
1459
1460 =back
1461
1462 =for html </blockquote>
1463
1464 =cut
1465
1466   my $fieldType = $self->fieldType ($table, $fieldName);
1467
1468   return $UNKNOWN unless $fieldType;
1469
1470   if ($fieldType == $STRING) {
1471     return "STRING";
1472   } elsif ($fieldType == $MULTILINE_STRING) {
1473     return "MULTILINE_STRING";
1474   } elsif ($fieldType == $INT) {
1475     return "INT";
1476   } elsif ($fieldType == $DATE_TIME) {
1477     return "DATE_TIME";
1478   } elsif ($fieldType == $REFERENCE) {
1479     return "REFERENCE"
1480   } elsif ($fieldType == $REFERENCE_LIST) {
1481     return "REFERENCE_LIST";
1482   } elsif ($fieldType == $ATTACHMENT_LIST) {
1483     return "ATTACHMENT_LIST";
1484   } elsif ($fieldType == $ID) {
1485     return "ID";
1486   } elsif ($fieldType == $STATE) {
1487     return "STATE";
1488   } elsif ($fieldType == $JOURNAL) {
1489     return "JOURNAL";
1490   } elsif ($fieldType == $DBID) {
1491     return "DBID";
1492   } elsif ($fieldType == $STATETYPE) {
1493     return "STATETYPE";
1494   } elsif ($fieldType == $RECORD_TYPE) {
1495     return "RECORD_TYPE";
1496   } elsif ($fieldType == $UNKNOWN) {
1497     return "UNKNOWN";
1498   } # if
1499 } # fieldTypeName
1500
1501 sub find ($;$@) {
1502   my ($self, $table, $condition, @fields) = @_;
1503
1504 =pod
1505
1506 =head2 find ($;$@)
1507
1508 Find records in $table. You can specify a $condition and which fields you wish
1509 to retrieve. Specifying a smaller set of fields means less data transfered and
1510 quicker retrieval so only retrieve the fields you really need.
1511
1512 Parameters:
1513
1514 =for html <blockquote>
1515
1516 =over
1517
1518 =item $table
1519
1520 Name of the table to search
1521
1522 =item $condition
1523
1524 Condition to use. If you want all records then pass in undef. Only simple
1525 conditions are supported. You can specify compound conditions (e.g. field1 ==
1526 'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
1527 supported (yet).
1528
1529 The following conditionals are supported
1530
1531 =over
1532
1533 =item Equal (==|=)
1534
1535 =item Not Equal (!=|<>)
1536
1537 =item Less than (<)
1538
1539 =item Greater than (>)
1540
1541 =item Less than or equal (<=)
1542
1543 =item Greater than or equal (>=)
1544
1545 =item Like
1546
1547 =item Is null
1548
1549 =item Is not null
1550
1551 =item In
1552
1553 =back
1554
1555 Note that "is not null" is currently not working in the REST module (it works
1556 in the api and thus also in the client/server model). This because the
1557 OLSC spec V1.0 does not support it.
1558
1559 As for "Like"", you'll need to specify "<fieldname> like '%var%'" for the
1560 condition.
1561
1562 "In" is only available in the REST interface as that's what OLSC supports. It's
1563 syntax would be "<fieldname> In 'value1', 'value2', 'value3'..."
1564
1565 Also conditions can be combined with (and|or) so in the api you could do "in"
1566 as "<fieldname> = 'value1 or <fieldname> = 'value2" or <fieldname> = 'value3'".
1567
1568 Complicated expressions with parenthesis like "(Project = 'Athena' or Project =
1569 'Hawaii') and Category = 'Aspen'" are not supported.
1570
1571 =item @fields
1572
1573 An array of fieldnames to retrieve
1574
1575 =back
1576
1577 =for html </blockquote>
1578
1579 Returns:
1580
1581 =for html <blockquote>
1582
1583 =over
1584
1585 =item $result or ($result, $nbrRecs)
1586
1587 Internal structure to be used with getNext. If in an array context then $nbrRecs
1588 is also returned.
1589
1590 =back
1591
1592 =for html </blockquote>
1593
1594 =cut
1595
1596   $condition ||= '';
1597
1598   unless ($self->connected) {
1599     $self->_setError ('You must connect to Clearquest before you can call find', '-1');
1600
1601     return;
1602   } # unless
1603
1604   my $entityDef;
1605
1606   eval {$entityDef = $self->{session}->GetEntityDef ($table)};
1607
1608   if ($@) {
1609     $self->_setError ($@, -1);
1610
1611     return ($@, -1);
1612   } # if
1613
1614   @fields = $self->_setFields ($table, @fields);
1615
1616   return unless @fields;
1617
1618   my $query = $self->{session}->BuildQuery ($table);
1619
1620   for (@fields) {
1621     eval {$query->BuildField ($_)};
1622
1623     if ($@) {
1624       $self->_setError ($@);
1625
1626       carp $@;
1627     } # if
1628   } # for
1629
1630   $self->_parseConditional ($query, $condition);
1631
1632   return if $self->error;
1633
1634   my $result  = $self->{session}->BuildResultSet ($query);
1635   my $nbrRecs = $result->ExecuteAndCountRecords;
1636
1637   $self->_setError;
1638
1639   my %resultSet = (
1640     result => $result
1641   );
1642
1643   if (wantarray) {
1644     return (\%resultSet, $nbrRecs);
1645   } else {
1646     return \%resultSet
1647   } # if
1648 } # find
1649
1650 sub findIDs ($) {
1651   my ($str) = @_;
1652
1653 =pod
1654
1655 =head2 findIDs ($)
1656
1657 Given a $str or a reference to an array of strings, this function returns a list
1658 of Clearquest IDs found in the $str. If called in a scalar context this function
1659 returns a comma separated string of IDs found. Note that duplicate IDs are
1660 eliminated. Also, the lists of IDs may refer to different Clearquest databases.
1661
1662 Parameters:
1663
1664 =for html <blockquote>
1665
1666 =over
1667
1668 =item $str
1669
1670 String or reference to an array of strings to search
1671
1672 =back
1673
1674 =for html </blockquote>
1675
1676 Returns:
1677
1678 =for html <blockquote>
1679
1680 =over
1681
1682 =item @IDs or $strIDs
1683
1684 Either an array of CQ IDs or a comma separated list of CQ IDs.
1685
1686 =back
1687
1688 =for html </blockquote>
1689
1690 =cut
1691
1692   $str = join ' ', @$str if ref $str eq 'ARRAY';
1693
1694   my @IDs = $str =~ /([A-Za-z]\w{1,4}\d{8})/gs;
1695
1696   my %IDs;
1697
1698   map { $IDs{$_} = 1; } @IDs;
1699
1700   if (wantarray) {
1701     return keys %IDs;
1702   } else {
1703     return join ',', keys %IDs;
1704   } # if
1705 } # findIDs
1706
1707 sub get ($$;@) {
1708   my ($self, $table, $id, @fields) = @_;
1709
1710 =pod
1711
1712 =head2 get ($$)
1713
1714 Return a record that you have the id or key of.
1715
1716 Parameters:
1717
1718 =for html <blockquote>
1719
1720 =over
1721
1722 =item $table
1723
1724 The $table to get the record from
1725
1726 =item $id
1727
1728 The $id or key to use to retrieve the record
1729
1730 =back
1731
1732 =for html </blockquote>
1733
1734 Returns:
1735
1736 =for html <blockquote>
1737
1738 =over
1739
1740 =item %record
1741
1742 Hash of name/value pairs for all the fields in $table
1743
1744 =back
1745
1746 =for html </blockquote>
1747
1748 =cut
1749
1750   unless ($self->connected) {
1751     $self->_setError ('You must connect to Clearquest before you can call get', '-1');
1752
1753     return;
1754   } # unless
1755
1756   @fields = $self->_setFields ($table, @fields);
1757
1758   return unless @fields;
1759
1760   my $entity;
1761
1762   eval {$entity = $self->{session}->GetEntity ($table, $id)};
1763
1764   if ($@) {
1765     $self->_setError ($@);
1766
1767     return;
1768   } # if
1769
1770   my %record;
1771
1772   for (@fields) {
1773     my $fieldType = $entity->GetFieldValue ($_)->GetType;
1774
1775     if ($fieldType == $CQPerlExt::CQ_REFERENCE_LIST) {
1776       $record{$_} = $entity->GetFieldValue ($_)->GetValueAsList;
1777     } else {
1778       $record{$_}   = $entity->GetFieldValue ($_)->GetValue;
1779       $record{$_} ||= '' if $self->{emptyStringForUndef};
1780
1781       # Fix any UTC dates
1782       if ($fieldType == $CQPerlExt::CQ_DATE_TIME) {
1783         $record{$_} = _UTC2Localtime ($record{$_});
1784       } # if
1785     } # if
1786   } # for
1787
1788   $self->_setError;
1789
1790   return %record;
1791 } # get
1792
1793 sub getDBID ($$;@) {
1794   my ($self, $table, $dbid, @fields) = @_;
1795
1796 =pod
1797
1798 =head2 getDBID ($$;@)
1799
1800 Return a record that you have the dbid
1801
1802 Parameters:
1803
1804 =for html <blockquote>
1805
1806 =over
1807
1808 =item $table
1809
1810 The $table to get the record from
1811
1812 =item $dbid
1813
1814 The $dbid to use to retrieve the record
1815
1816 =item @fields
1817
1818 Array of field names to retrieve (Default: All fields)
1819
1820 Note: Avoid getting all fields for large records. It will be slow and bloat your
1821 script's memory usage.
1822
1823 =back
1824
1825 =for html </blockquote>
1826
1827 Returns:
1828
1829 =for html <blockquote>
1830
1831 =over
1832
1833 =item %record
1834
1835 Hash of name/value pairs for all the fields in $table
1836
1837 =back
1838
1839 =for html </blockquote>
1840
1841 =cut
1842
1843   unless ($self->connected) {
1844     $self->_setError ('You must connect to Clearquest before you can call getDBID', '-1');
1845
1846     return;
1847   } # unless
1848
1849   @fields = $self->_setFields ($table, @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 = ();
2316
2317   %values = %$values if $values;
2318
2319   my $entity;
2320
2321   eval {$entity = $self->{session}->GetEntityByDbId ($table, $dbid)};
2322
2323   if ($@) {
2324     $self->_setError ($@);
2325
2326     return;
2327   } # if
2328
2329   eval {$entity->EditEntity ($action)};
2330
2331   if ($@) {
2332     $self->_setError ($@);
2333
2334     return $@;
2335   } # if
2336
2337   # First process all fields in @ordering, if specified
2338   for (@ordering) {
2339     if ($values{$_}) {
2340       $self->{errmsg} = $self->_setFieldValue ($table, $_, $values{$_});
2341     } else {
2342       $self->_setError ("$_ from the ordering array is not present in the value hash", -1);
2343     } # if
2344
2345     last unless $self->{errmsg} eq '';
2346   } # for
2347
2348   return $self->{errmsg} unless $self->{errmsg} eq '';
2349
2350   # Now process the rest of the values
2351   for my $fieldName (keys %values) {
2352     next if grep {$fieldName eq $_} @ordering;
2353
2354     $self->{errmsg} = $self->_setFieldValue ($entity, $table, $fieldName, $values{$fieldName});
2355
2356     last unless $self->{errmsg} eq '';
2357   } # for
2358
2359   $self->_setError ($self->{errmsg});
2360
2361   return $self->{errmsg} unless $self->{errmsg} eq '';
2362
2363   $self->{errmsg} = $self->_commitRecord ($entity);
2364   $self->{error}  = $self->{errmsg} eq '' ? 0 : 1;
2365
2366   return $self->{errmsg};
2367 } # modifyDBID
2368
2369 sub module () {
2370   my ($self) = @_;
2371
2372 =pod
2373
2374 =head2 module
2375
2376 Returns the current back end module we are using
2377
2378 Parameters:
2379
2380 =for html <blockquote>
2381
2382 =over
2383
2384 =item none
2385
2386 =back
2387
2388 =for html </blockquote>
2389
2390 Returns:
2391
2392 =for html <blockquote>
2393
2394 =over
2395
2396 =item module
2397
2398 =back
2399
2400 =for html </blockquote>
2401
2402 =cut
2403
2404   return $self->{module};
2405 } # module
2406
2407 sub new (;%) {
2408   my ($class, %parms) = @_;
2409
2410 =pod
2411
2412 =head2 new ()
2413
2414 Construct a new Clearquest object.
2415
2416 Parameters:
2417
2418 Below are the key values for the %parms hash.
2419
2420 =for html <blockquote>
2421
2422 =over
2423
2424 =item CQ_SERVER
2425
2426 Webhost for REST module
2427
2428 =item CQ_USERNAME
2429
2430 Username to use to connect to the database
2431
2432 =item CQ_PASSWORD
2433
2434 Password to use to connect to the database
2435
2436 =item CQ_DATABASE
2437
2438 Clearquest database to connect to
2439
2440 =item CQ_DBSET
2441
2442 Database set to connect to
2443
2444 =item CQ_MODULE
2445
2446 One of 'rest', 'api' or 'client' (Default: From cq.conf). This determines which
2447 backend module will be used.
2448
2449 =back
2450
2451 =for html </blockquote>
2452
2453 Returns:
2454
2455 =for html <blockquote>
2456
2457 =over
2458
2459 =item Clearquest object
2460
2461 =back
2462
2463 =for html </blockquote>
2464
2465 =cut
2466
2467   $parms{CQ_DATABASE} ||= $OPTS{CQ_DATABASE};
2468   $parms{CQ_USERNAME} ||= $OPTS{CQ_USERNAME};
2469   $parms{CQ_PASSWORD} ||= $OPTS{CQ_PASSWORD};
2470   $parms{CQ_DBSET}    ||= $OPTS{CQ_DBSET};
2471
2472   my $self = bless {
2473     server              => $parms{CQ_SERVER},
2474     port                => $parms{CQ_PORT},
2475     database            => $parms{CQ_DATABASE},
2476     dbset               => $parms{CQ_DBSET},
2477     username            => $parms{CQ_USERNAME},
2478     password            => $parms{CQ_PASSWORD},
2479     emptyStringForUndef => 0,
2480     returnSystemFields  => 0,
2481   }, $class;
2482
2483   my $module = delete $parms{CQ_MODULE};
2484
2485   $module ||= $OPTS{CQ_MODULE};
2486
2487   $module = lc $module;
2488
2489   if ($module eq 'rest') {
2490     require Clearquest::REST;
2491
2492     $self->{webhost} = $parms{CQ_WEBHOST} || $OPTS{CQ_WEBHOST};
2493
2494     $self = Clearquest::REST->new ($self);
2495   } elsif ($module eq 'client') {
2496     require Clearquest::Client;
2497
2498     $self->{server} = $parms{CQ_SERVER} || $OPTS{CQ_SERVER};
2499     $self->{port}   = $parms{CQ_PORT}   || $OPTS{CQ_PORT};
2500
2501     $self = Clearquest::Client->new ($self);
2502   } elsif ($module ne 'api') {
2503     croak "Unknown interface requested - $module";
2504   } # if
2505
2506   $self->{module} = $module;
2507
2508   # Save reference to instaniated instance of this object to insure that global
2509   # variables are properly disposed of
2510   push @objects, $self;
2511
2512   return $self;
2513 } # new
2514
2515 sub server () {
2516   my ($self) = @_;
2517
2518 =pod
2519
2520 =head2 server
2521
2522 Returns the current server if applicable
2523
2524 Parameters:
2525
2526 =for html <blockquote>
2527
2528 =over
2529
2530 =item none
2531
2532 =back
2533
2534 =for html </blockquote>
2535
2536 Returns:
2537
2538 =for html <blockquote>
2539
2540 =over
2541
2542 =item $server
2543
2544 For api this will return ''. For REST and client/server this will return the
2545 server name that we are talking to.
2546
2547 =back
2548
2549 =for html </blockquote>
2550
2551 =cut
2552
2553   return $self->{server};
2554 } # server
2555
2556 sub setOpts (%) {
2557   my ($self, %opts) = @_;
2558
2559 =pod
2560
2561 =head2 setOpts
2562
2563 Set options for operating
2564
2565 Parameters:
2566
2567 =for html <blockquote>
2568
2569 =over
2570
2571 =item %opts
2572
2573 =back
2574
2575 Options to set. The only options currently supported are emptyStringForUndef
2576 and returnSystemFields. If set emptyStringForUndef will return empty strings for
2577 empty fields instead of undef. Default: Empty fields are represented with undef.
2578
2579 System-owned fields are used internally by IBM Rational ClearQuest to maintain
2580 information about the database. You should never modify system fields directly
2581 as it could corrupt the database. If returnSystemFields is set then system
2582 fields will be returned. Default: System fields will not be returned unless
2583 explicitly stated in the @fields parameter. This means that if you do not
2584 specify any fields in @fields, all fields will be returned except system fields,
2585 unless you set returnSystemFields via this method or you explicitly mention the
2586 system field in your @fields parameter.
2587
2588 =for html </blockquote>
2589
2590 Returns:
2591
2592 =for html <blockquote>
2593
2594 =over
2595
2596 =item Nothing
2597
2598 =back
2599
2600 =for html </blockquote>
2601
2602 =cut
2603
2604   $self->{emptyStringForUndef} = $opts{emptyStringForUndef}
2605     if $opts{emptyStringForUndef};
2606   $self->{returnSystemFields}  = $opts{returnSystemFields}
2607     if $opts{returnSystemFields};
2608 } # setOpts
2609
2610 sub getOpt ($) {
2611   my ($self, $option) = @_;
2612
2613 =pod
2614
2615 =head2 getOpt
2616
2617 Get option
2618
2619 Parameters:
2620
2621 =for html <blockquote>
2622
2623 =over
2624
2625 =item $option
2626
2627 =back
2628
2629 Option to retrieve. If non-existant then undef is returned.
2630
2631 =for html </blockquote>
2632
2633 Returns:
2634
2635 =for html <blockquote>
2636
2637 =over
2638
2639 =item $option or undef if option doesn't exist
2640
2641 =back
2642
2643 =for html </blockquote>
2644
2645 =cut
2646
2647   my @validOpts = qw (emptyStringForUndef returnSystemFields);
2648
2649   if (grep {$option eq $_} @validOpts) {
2650     return $self->{$option};
2651   } else {
2652     return;
2653   } # if
2654 } # getOpt
2655
2656 sub username () {
2657   my ($self) = @_;
2658
2659 =pod
2660
2661 =head2 username
2662
2663 Returns the current username (or the username that would be used)
2664
2665 Parameters:
2666
2667 =for html <blockquote>
2668
2669 =over
2670
2671 =item none
2672
2673 =back
2674
2675 =for html </blockquote>
2676
2677 Returns:
2678
2679 =for html <blockquote>
2680
2681 =over
2682
2683 =item username
2684
2685 =back
2686
2687 =for html </blockquote>
2688
2689 =cut
2690
2691   return $self->{username};
2692 } # username
2693
2694 sub webhost () {
2695   my ($self) = @_;
2696
2697   return $self->{webhost};
2698 } # webhost
2699
2700 1;
2701
2702 =pod
2703
2704 =head1 DEPENDENCIES
2705
2706 =head2 Perl Modules
2707
2708 L<File::Basename|File::Basename>
2709
2710 =head2 ClearSCM Perl Modules
2711
2712 =for html <p><a href="/php/scm_man.php?file=lib/GetConfig.pm">GetConfig</a></p>
2713
2714 =head1 BUGS AND LIMITATIONS
2715
2716 There are no known bugs in this module
2717
2718 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
2719
2720 =head1 LICENSE AND COPYRIGHT
2721
2722 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
2723
2724 =cut