lib/Clearquest/REST.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: REST.pm,v $
   4
   5 Clearquest REST client - Provide access to Clearquest via the REST interface
   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.16 $
  18
  19 =item Created
  20
  21 Wed May 30 11:43:41 PDT 2011
  22
  23 =item Modified
  24
  25 $Date: 2013/03/26 02:24:01 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Provides a RESTful interface to Clearquest
  32
  33 =head1 DESCRIPTION
  34
  35 This module implements a simple interface to Clearquest. The backend uses REST
  36 however this module hides all of the ugly details of the REST implementation.
  37 Since REST is used, however, this module can be used by any normal Perl. See
  38 Perl Modules below of a list of Perl modules required.
  39
  40 This module is object oriented so you need to instantiate an object. Be careful
  41 to make sure that you properly disconect from this object (See disconnect
  42 method).
  43
  44 The methods exported are simple: add, delete, get, modify... In most cases you
  45 simply need to supply the table name and a hash of name value pairs to perform
  46 actions. Record hashes representing name/value parts for the fields in the
  47 records are returned to you.
  48
  49 Here's an example of use:
  50
  51  use Clearquest;
  52
  53  my $cq;
  54
  55  END {
  56    $cq->disconnect if $cq;
  57  } # END
  58
  59  $cq = Clearquest->new (CQ_MODULE => 'rest');
  60
  61  $cq->connect;
  62
  63  my %record = $cq->get ('Project', 'Athena');
  64
  65  my %update = (
  66    Deprecated => 1,
  67    Projects   => 'Island', '21331', 'Hera' ],
  68  );
  69
  70  $cq->modify ('VersionInfo', '1.0', 'Modify', \%update);
  71
  72  if ($cq->error) {
  73    die "Unable to modify record\n" . $cq->errmsg;
  74  }
  75
  76 =head2 NOTES
  77
  78 Multiline text strings are limited to only 2000 characters by default. In order
  79 to expand this you need to change the cqrest.properties file in:
  80
  81 C:\Program Files (x86)\IBM\RationalSDLC\common\CM\profiles\cmprofile\installedApps\dfltCell\TeamEAR.ear\cqweb.war\WEB-INF\classes
  82
  83 on the web server. Multiline text strings can theoretically grow to 2 gig,
  84 however when set even as small as 10 meg REST messes up!
  85
  86 =head1 METHODS
  87
  88 The following methods are available:
  89
  90 =cut
  91
  92 package Clearquest::REST;
  93
  94 use strict;
  95 use warnings;
  96
  97 use File::Basename;
  98 use Carp;
  99
 100 use CGI qw (escapeHTML);
 101 use Encode;
 102 use LWP::UserAgent;
 103 use HTTP::Cookies;
 104 use MIME::Base64;
 105 use REST::Client;
 106 use XML::Simple;
 107
 108 use Clearquest;
 109 use GetConfig;
 110 use Utils;
 111
 112 use parent 'Clearquest';
 113
 114 our $VERSION  = '$Revision: 2.16 $';
 115    ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
 116
 117 =pod
 118
 119 =head1 Options
 120
 121 Options are keep in the cq.conf file in the etc directory. They specify the
 122 default options listed below. Or you can export the option name to the env(1) to
 123 override the defaults in cq.conf. Finally you can programmatically set the
 124 options when you call new by passing in a %parms hash. The items below are the
 125 key values for the hash.
 126
 127 =for html <blockquote>
 128
 129 =over
 130
 131 =item CQ_SERVER
 132
 133 The web host to contact with leading http://
 134
 135 =item CQ_USERNAME
 136
 137 User name to connect as (Default: From cq.conf)
 138
 139 =item CQ_PASSWORD
 140
 141 Password for CQ_USERNAME
 142
 143 =item CQ_DATABASE
 144
 145 Name of database to connect to (Default: From cq.conf)
 146
 147 =item CQ_DBSET
 148
 149 Database Set name (Default: From cq.conf)
 150
 151 =back
 152
 153 =cut
 154
 155 our (%RECORDS, %FIELDS);
 156
 157 # FieldTypes ENUM
 158 my $UNKNOWN          = -1;
 159 my $STRING           = 0;
 160 my $MULTILINE_STRING = 1;
 161 my $REFERENCE        = 2;
 162 my $REFERENCE_LIST   = 3;
 163 my $JOURNAL          = 4;
 164 my $ATTACHMENT_LIST  = 5;
 165 my $INT              = 6;
 166 my $DATE_TIME        = 7;
 167 my $DBID             = 8;
 168 my $RECORD_TYPE      = 9;
 169
 170 sub _callREST ($$$;%) {
 171   my ($self, $type, $url, $body, %parms) = @_;
 172
 173   # Set error and errmsg to no error
 174   $self->error (0);
 175   $self->{errmsg} = '';
 176
 177   # Upshift the call type as the calls are actually like 'GET' and not 'get'
 178   $type = uc $type;
 179
 180   # We only support these call types
 181   croak "Unknown call type \"$type\""
 182     unless $type eq 'GET'     or
 183            $type eq 'POST'    or
 184            $type eq 'PATCH'   or
 185            $type eq 'OPTIONS' or
 186            $type eq 'PUT'     or
 187            $type eq 'DELETE'  or
 188            $type eq 'HEAD';
 189
 190   # If the caller did not give us authorization then use the login member we
 191   # already have in the object
 192   unless ($parms{Authorization}) {
 193     $parms{$_} = $self->{login}{$_} foreach (keys %{$self->{login}});
 194   } # unless
 195
 196   # We need to use OSLC 2.0 for the conditional "is not null". So if we see a
 197   # "oslc.where" in the URL then add OSLC-Core-Version => '2.0' to %parms.
 198   if ($url =~ /oslc.where/) {
 199     $parms{'OSLC-Core-Version'} = '2.0';
 200   } # if
 201
 202   # Remove the host portion if any
 203   $url =~ s/^http.*$self->{server}//;
 204
 205   # Call the REST call (Different calls have different numbers of parameters)
 206   if ($type eq 'GET'     or
 207       $type eq 'DELETE'  or
 208       $type eq 'OPTIONS' or
 209       $type eq 'HEAD') {
 210     $self->{rest}->$type ($url, \%parms);
 211   } else {
 212     $self->{rest}->$type ($url, $body, \%parms);
 213   } # if
 214
 215   return $self->error;
 216 } # _callREST
 217
 218 sub _getRecordName ($) {
 219   my ($self, $query) = @_;
 220
 221   $self->_callREST ('get', $query);
 222
 223   if ($self->error) {
 224     $self->errmsg ("Unable to get record name for $query");
 225
 226     return;
 227   } # if
 228
 229   my %record = %{XMLin ($self->{rest}->responseContent)};
 230
 231   return $record{element}{name};
 232 } # _getRecordName
 233
 234 sub _getAttachmentList ($$) {
 235   my ($self, $result, $fields) = @_;
 236
 237   croak ((caller(0))[3] . ' is not implemented');
 238
 239   return;
 240 } # _getAttachmentList
 241
 242 sub _getInternalID ($$) {
 243   my ($self, $table, $key) = @_;
 244
 245   my $query = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}/record/?rcm.type=$table&";
 246
 247   $query .= "rcm.name=$key";
 248
 249   $self->_callREST ('get', $query);
 250
 251   unless ($self->error) {
 252     my %result = %{XMLin ($self->{rest}->responseContent)};
 253
 254     return $result{entry}{id};
 255   } else {
 256     $self->errmsg ("Record not found (Table: $table, Key: \"$key\")");
 257
 258     return $self->errmsg;
 259   } # unless
 260 } # _getInternalID
 261
 262 sub _getRecord ($$@) {
 263   my ($self, $table, $url, @fields) = @_;
 264
 265   $self->{fields} = [$self->_setFields ($table, @fields)];
 266
 267   $self->_callREST ('get', $url);
 268
 269   return if $self->error;
 270
 271   # Now parse the results
 272   my %result = %{XMLin ($self->{rest}->responseContent)};
 273
 274   if ($result{entry}{content}{$table}) {
 275     return $self->_parseFields ($table, %{$result{entry}{content}{$table}});
 276   } elsif (ref \%result eq 'HASH') {
 277     # The if test above will create an empty $result{entry}{content}. We need
 278     # to delete that
 279     delete $result{entry};
 280
 281     return $self->_parseFields ($table, %result);
 282   } else {
 283     return;
 284   } # if
 285 } # _getRecord
 286
 287 sub _getRecordID ($) {
 288   my ($self, $table) = @_;
 289
 290   $self->records;
 291
 292   return $RECORDS{$table};
 293 } # _getRecordID
 294
 295 sub _getRecordURL ($$;@) {
 296   my ($self, $table, $url, @fields) = @_;
 297
 298   $self->{fields} = [$self->_setFields ($table, @fields)];
 299
 300   $self->error ($self->_callREST ('get', $url));
 301
 302   return if $self->error;
 303
 304   return $self->_parseFields ($table, %{XMLin ($self->{rest}->responseContent)});
 305 } # _getRecordURL
 306
 307 sub _getReferenceList ($$) {
 308   my ($self, $url, $field) = @_;
 309
 310   $self->error ($self->_callREST ('get', $url));
 311
 312   return if $self->error;
 313
 314   my %result = %{XMLin ($self->{rest}->responseContent)};
 315
 316   my @values;
 317
 318   # Need to find the field array here...
 319   foreach my $key (keys %result) {
 320     if (ref $result{$key} eq 'ARRAY') {
 321       foreach (@{$result{$key}}) {
 322         push @values, $$_{'oslc_cm:label'};
 323       } # foreach
 324
 325       last;
 326     } elsif (ref $result{$key} eq 'HASH' and $result{$key}{'oslc_cm:label'}) {
 327       push @values, $result{$key}{'oslc_cm:label'};
 328     } # if
 329   } # foreach
 330
 331   return @values;
 332 } # _getReferenceList
 333
 334 sub _parseCondition ($$) {
 335   my ($self, $table, $condition) = @_;
 336
 337   # Parse simple conditions only
 338   my ($field, $operator, $value);
 339
 340   if ($condition =~ /(\w+)\s*(==|=|!=|<>|<=|>=|<|>|in|is\s+null|is\s+not\s+null)\s*(.*)/i) {
 341     $field    = $1;
 342     $operator = $2;
 343     $value    = $3;
 344
 345     if ($operator eq '==') {
 346       $operator = '=';
 347     } elsif ($operator eq '<>') {
 348       $operator = '!=';
 349     } elsif ($operator =~ /is\s+null/i) {
 350       return "$field in [\"\"]";
 351     } elsif ($operator =~ /is\s+not\s+null/i) {
 352       return "$field in [*]";
 353     } elsif ($operator =~ /in/i) {
 354       return "$field in [$value]"
 355     } # if
 356   } # if
 357
 358   if ($operator eq '=' and $value =~ /^null$/i) {
 359     return "$field in [\"\"]";
 360   } elsif ($operator eq '!=' and $value =~ /^null$/i) {
 361     return "$field in [*]";
 362   } # if
 363
 364   # Trim quotes if any:
 365   if ($value =~ /^\s*\'/) {
 366     $value =~ s/^\s*\'//;
 367     $value =~ s/\'\s*$//;
 368   } elsif ($value =~ /^\s*\"/) {
 369     $value =~ s/^\s*\"//;
 370     $value =~ s/\"\s*$//;
 371   } # if
 372
 373   # Trim leading and trailing whitespace
 374   $value =~ s/^\s+//;
 375   $value =~ s/\s+$//;
 376
 377   # Convert datetimes to Zulu
 378   if ($self->fieldType ($table, $field) == $DATE_TIME and
 379       $value !~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/) {
 380     $value = Clearquest::_UTCTime ($value);
 381   } # if
 382
 383   return "$field $operator \"$value\"";
 384 } # _parseCondition
 385
 386 sub _parseConditional ($$) {
 387   my ($self, $table, $condition) = @_;
 388
 389   return 'oslc_cm.query=' unless $condition;
 390
 391   my $parsedConditional;
 392
 393   # Special case when the condition is ultra simple
 394   if ($condition !~ /(\w+)\s*(==|=|!=|<>|<|>|<=|>=|in|is\s+null|is\s+not\s+null)\s*(.*)/i) {
 395     return "rcm.name=$condition";
 396   } # if
 397
 398   # TODO: This section needs improvement to handle more complex conditionals
 399   while () {
 400     if ($condition =~ /(.+?)\s+(and|or)\s+(.+)/i) {
 401       my $leftSide = $self->_parseCondition ($table, $1);
 402
 403       $parsedConditional .= "$leftSide $2 ";
 404       $condition          = $3;
 405     } else {
 406       $parsedConditional .= $self->_parseCondition ($table, $condition);
 407
 408       last;
 409     } # if
 410   } # while
 411
 412   # TODO: How would this work if we have a condition like 'f1 = "value" and
 413   # f2 is not null'?
 414   if ($parsedConditional =~ /in \[\*\]/) {
 415     return "oslc.where=$parsedConditional";
 416   } else {
 417     return "oslc_cm.query=$parsedConditional";
 418   } # if
 419 } # _parseConditional
 420
 421 sub _parseFields ($%) {
 422   my ($self, $table, %record) = @_;
 423
 424   foreach my $field (keys %record) {
 425     if ($field =~ /:/     or
 426         $field eq 'xmlns' or
 427         grep {/^$field$/} @{$self->{fields}} == 0) {
 428       delete $record{$field};
 429
 430       next;
 431     } # if
 432
 433     my $fieldType = $self->fieldType ($table, $field);
 434
 435     if (ref $record{$field} eq 'HASH') {
 436       if ($fieldType == $REFERENCE) {
 437         $record{$field} = $record{$field}{'oslc_cm:label'};
 438       } elsif ($fieldType == $REFERENCE_LIST) {
 439         my @values = $self->_getReferenceList ($record{$field}{'oslc_cm:collref'}, $field);
 440
 441         $record{$field} = \@values;
 442       } elsif ($fieldType == $ATTACHMENT_LIST) {
 443         my @attachments = $self->_getAttachmentList ($record{$field}{'oslc_cm:collref'}, $field);
 444
 445         $record{$field} = \@attachments;
 446       } elsif ($fieldType == $RECORD_TYPE) {
 447         $record{$field} = $record{$field}{'oslc_cm:label'};
 448       } elsif (!%{$record{$field}}) {
 449         $record{$field} = undef;
 450       } # if
 451     } # if
 452
 453     $record{$field} ||= '' if $self->{emptyStringForUndef};
 454
 455     if ($fieldType == $DATE_TIME) {
 456       $record{$field} = Clearquest::_UTC2Localtime $record{$field};
 457     } # if
 458   } # foreach
 459
 460   return %record;
 461 } # _parseFields
 462
 463 sub _parseRecordDesc ($) {
 464   my ($self, $table) = @_;
 465
 466   # Need to get fieldType info
 467   my $recordID = $self->_getRecordID ($table);
 468
 469   return unless $recordID;
 470
 471   my $url = "$self->{uri}/record-type/$recordID";
 472
 473   $self->_callREST ('get', $url);
 474
 475   return if $self->error;
 476
 477   my %result = %{XMLin ($self->{rest}->responseContent)};
 478
 479   # Reach in deep for field definitions
 480   my %fields = %{$result{element}{complexType}{choice}{element}};
 481
 482   foreach (keys %fields) {
 483     if ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:reference') {
 484       $FIELDS{$table}{$_}{FieldType}  = $REFERENCE;
 485       $FIELDS{$table}{$_}{References} = $self->_getRecordName ($fields{$_}{'cq:refURI'});
 486     } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:multilineString') {
 487       $FIELDS{$table}{$_}{FieldType} = $MULTILINE_STRING;
 488     } elsif ($fields{$_}{simpleType}) {
 489       if ($fields{$_}{simpleType}{restriction}{base}) {
 490         if ($fields{$_}{simpleType}{restriction}{base} eq 'string') {
 491           $FIELDS{$table}{$_}{FieldType} = $STRING;
 492         } elsif ($fields{$_}{simpleType}{union}{simpleType}[0]{restriction}{base} eq 'string') {
 493           $FIELDS{$table}{$_}{FieldType} = $STRING;
 494         } else {
 495           $FIELDS{$table}{$_}{FieldType} = $UNKNOWN;
 496         } # if
 497       } elsif ($fields{$_}{simpleType}{union}{simpleType}[0]{restriction}{base} eq 'string') {
 498         $FIELDS{$table}{$_}{FieldType} = $STRING;
 499       } elsif ($fields{$_}{simpleType}{union}{simpleType}[0]{restriction}{base} eq 'cqf:integer') {
 500         $FIELDS{$table}{$_}{FieldType} = $INT;
 501       } else {
 502         $FIELDS{$table}{$_} = $UNKNOWN;
 503       } # if
 504     } elsif ($fields{$_}{complexType} and $fields{$_}{'cq:refURI'}) {
 505       $FIELDS{$table}{$_}{FieldType} = $REFERENCE_LIST;
 506       $FIELDS{$table}{$_}{References} = $self->_getRecordName ($fields{$_}{'cq:refURI'});
 507     } elsif ($fields{$_}{complexType} and
 508              $fields{Symptoms}{complexType}{sequence}{element}{simpleType}{union}{simpleType}[1]{restriction}{base} eq 'string') {
 509       $FIELDS{$table}{$_}{FieldType} = $MULTILINE_STRING;
 510     } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:journal') {
 511       $FIELDS{$table}{$_}{FieldType} = $JOURNAL;
 512     } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:attachmentList') {
 513       $FIELDS{$table}{$_}{FieldType} = $ATTACHMENT_LIST;
 514     } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:integer') {
 515       $FIELDS{$table}{$_}{FieldType} = $INT;
 516     } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:dateTime') {
 517       $FIELDS{$table}{$_}{FieldType} = $DATE_TIME;
 518     } elsif ($fields{$_}{type} and $fields{$_}{type} eq 'cqf:recordType') {
 519       $FIELDS{$table}{$_}{FieldType} = $RECORD_TYPE;
 520     } else {
 521       $FIELDS{$table}{$_}{FieldType} = $UNKNOWN;
 522     } # if
 523
 524     if ($fields{$_}{'cq:systemOwned'} and $fields{$_}{'cq:systemOwned'} eq 'true') {
 525       $FIELDS{$table}{$_}{SystemField} = 1;
 526     } else {
 527       $FIELDS{$table}{$_}{SystemField} = 0;
 528     } # if
 529   } # foreach
 530
 531   return;
 532 } # _parseRecordDesc
 533
 534 sub _isSystemField ($$) {
 535   my ($self, $table, $fieldName) = @_;
 536
 537   if ($FIELDS{$table}) {
 538     # If we already have this fieldType just return it
 539     if (defined $FIELDS{$table}{$fieldName}) {
 540       return $FIELDS{$table}{$fieldName}{SystemField};
 541     } else {
 542       return 0;
 543     } # if
 544   } # if
 545
 546   $self->_parseRecordDesc ($table);
 547
 548   if (defined $FIELDS{$table}{$fieldName}) {
 549     return $FIELDS{$table}{$fieldName}{SystemField};
 550   } else {
 551     return 0;
 552   } # if
 553 } # _isSystemField
 554
 555 sub _setFields ($@) {
 556   my ($self, $table, @fields) = @_;
 557
 558   # Cause %FIELDS to be expanded for $table
 559   $self->_parseRecordDesc ($table);
 560
 561   unless (@fields) {
 562     foreach ($self->fields ($table)) {
 563       unless ($self->{returnSystemFields}) {
 564         next if $FIELDS{$table}{$_}{SystemField}
 565       } # unless
 566
 567       push @fields, $_;
 568     } # foreach
 569   } # unless
 570
 571   push @fields, 'dbid' unless grep { /dbid/ } @fields;
 572
 573   return @fields;
 574 } # _setFields
 575
 576 sub _setFieldValue ($$$) {
 577   my ($self, $table, $fieldName, $fieldValue) = @_;
 578
 579   return if $self->_isSystemField ($table, $fieldName);
 580
 581   my $xml .= "<$fieldName>";
 582
 583   my $fieldType = $self->fieldType ($table, $fieldName);
 584
 585   if ($fieldType == $STRING           or
 586       $fieldType == $MULTILINE_STRING or
 587       $fieldType == $INT              or
 588       $fieldType == $DATE_TIME) {
 589     # Fix MULTILINE_STRINGs
 590     if ($fieldType == $MULTILINE_STRING and ref $fieldValue eq 'ARRAY') {
 591       chomp @{$fieldName};
 592
 593       $fieldValue= join "\n", @$fieldValue;
 594     } # if
 595
 596     $xml .= escapeHTML $fieldValue;
 597   } elsif ($fieldType == $REFERENCE) {
 598     my $tableReferenced = $self->fieldReference ($table, $fieldName);
 599
 600     if ($tableReferenced) {
 601       $xml .= $self->_getInternalID ($tableReferenced, $fieldValue);
 602     } else {
 603       $self->error (600);
 604       $self->errmsg ("Could not determine reference for $fieldName");
 605
 606       return;
 607     } # if
 608   } elsif ($fieldType == $REFERENCE_LIST) {
 609     # We'll allow either an array reference or a single value, which we will
 610     # turn into an array
 611     my @values;
 612
 613     @values = ref $fieldValue eq 'ARRAY' ? @$fieldValue
 614                                          : ($fieldValue);
 615
 616     my $tableReferenced = $self->fieldReference ($table, $fieldName);
 617
 618     unless ($tableReferenced) {
 619       $self->error (600);
 620       $self->errmsg ("Could not determine reference for $fieldName");
 621
 622       return;
 623     } # if
 624
 625     foreach (@values) {
 626       my $internalID = $self->_getInternalID ($tableReferenced, $_);
 627
 628       if ($internalID) {
 629         $xml .= "<value rdf:resource=\"$internalID\" oslc_cm:label=\"$_\"/>\n";
 630       } else {
 631         $self->error (600);
 632         $self->errmsg ("Could not find a valid/active $tableReferenced with a key of \"$_\"");
 633
 634         return
 635       } # if
 636     } # foreach
 637   } else {
 638     croak "Unable to handle field $fieldName fieldType: " . $self->fieldTypeName ($table, $fieldName);
 639   } # if
 640
 641   $xml .= "</$fieldName>\n";
 642
 643   return $xml;
 644 } # _setFieldValue
 645
 646 sub _startXML ($) {
 647   my ($table) = @_;
 648
 649   my $xml = << "XML";
 650 <?xml version="1.0" encoding="UTF-8"?>
 651 <$table
 652   xmlns="http://www.ibm.com/xmlns/prod/rational/clearquest/1.0/"
 653   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
 654   xmlns:dc="http://purl.org/dc/terms/"
 655   xmlns:oslc_cm="http://open-services.net/xmlns/cm/1.0/">
 656 XML
 657
 658   return $xml
 659 } # _startXML
 660
 661 sub add ($$;@) {
 662   my ($self, $table, $record, @ordering) = @_;
 663
 664 =pod
 665
 666 =head2 add ($table, %record)
 667
 668 Adds a %record to $table.
 669
 670 Parameters:
 671
 672 =for html <blockquote>
 673
 674 =over
 675
 676 =item $table
 677
 678 Table to add a record to (e.g. 'Defect')
 679
 680 =item $values
 681
 682 Hash reference of name/value pairs for the insertion
 683
 684 =item @ordering
 685
 686 Array containing field names that need to be processed in order. Not all fields
 687 mentioned in the $values hash need be mentioned here. If you have fields that
 688 must be set in a particular order you can mention them here. So, if you're
 689 adding the Defect record, but you need Project set before Platform,  you need
 690 only pass in an @ordering of qw(Project Platform). They will be done first, then
 691 all of the rest of the fields in the $values hash. If you have no ordering
 692 dependencies then you can simply omit @ordering.
 693
 694 Note that the best way to determine if you have an ordering dependency try using
 695 a Clearquest client and note the order that you set fields in. If at anytime
 696 setting one field negates another field via action hook code then you have just
 697 figured out that this field needs to be set before the file that just got
 698 negated.
 699
 700 =back
 701
 702 =for html </blockquote>
 703
 704 Returns:
 705
 706 =for html <blockquote>
 707
 708 =over
 709
 710 =item $errmsg
 711
 712 Error message (if any)
 713
 714 =back
 715
 716 =for html </blockquote>
 717
 718 =cut
 719
 720   my %record = %$record;
 721   my $xml    = _startXML $table;
 722   my $uri    = $self->{uri} . '/record';
 723
 724   # First process all fields in the @ordering, if specified
 725   $xml .= $self->_setFieldValue ($table, $_, $record{$_}) foreach (@ordering);
 726
 727   foreach my $field (keys %record) {
 728     next if InArray $field, @ordering;
 729
 730     $xml .= $self->_setFieldValue ($table, $field, $record{$field});
 731   } # foreach
 732
 733   $xml .= "</$table>";
 734
 735   $self->_callREST ('post', $uri, $xml);
 736
 737   # Get the DBID of the newly created record
 738   if ($self->{rest}{_res}{_headers}{location} =~ /-(\d+)$/) {
 739     return $1;
 740   } else {
 741     return;
 742   } # if
 743 } # add
 744
 745 sub connect (;$$$$) {
 746   my ($self, $username, $password, $database, $dbset) = @_;
 747
 748 =pod
 749
 750 =head2 connect (;$$$$)
 751
 752 This method doesn't really connect but is included to be similar to the
 753 Clearquest::connect method. It does set any of the username, password,
 754 database and/or dbset members
 755
 756 Parameters:
 757
 758 =for html <blockquote>
 759
 760 =over
 761
 762 =item $username
 763
 764 Username to use to connect to the database
 765
 766 =item $password
 767
 768 Password to use to connect to the database
 769
 770 =item $database
 771
 772 Clearquest database to connect to
 773
 774 =item $dbset
 775
 776 Database set to connect to (Default: Connect to the default dbset)
 777
 778 =back
 779
 780 =for html </blockquote>
 781
 782 Returns:
 783
 784 =for html <blockquote>
 785
 786 =over
 787
 788 =item 1
 789
 790 =back
 791
 792 =for html </blockquote>
 793
 794 =cut
 795
 796   if (ref $username eq 'HASH') {
 797     my %opts = %$username;
 798
 799     $self->{username} = delete $opts{CQ_USERNAME};
 800     $self->{password} = delete $opts{CQ_PASSWORD};
 801     $self->{database} = delete $opts{CQ_DATABASE};
 802     $self->{dbset}    = delete $opts{CQ_DBSET};
 803   } else {
 804     $self->{username} = $username if $username;
 805     $self->{password} = $password if $password;
 806     $self->{database} = $database if $database;
 807     $self->{dbset}    = $dbset    if $dbset;
 808   } # if
 809
 810   # Set URI in case anything changed
 811   $self->{uri}      = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}";
 812   $self->{loggedin} = 1;
 813
 814   return 1;
 815 } # connect
 816
 817 sub connected () {
 818   my ($self) = @_;
 819
 820 =pod
 821
 822 =head2 connected ()
 823
 824 Returns 1 if we are currently connected to Clearquest
 825
 826 Parameters:
 827
 828 =for html <blockquote>
 829
 830 =over
 831
 832 =item none
 833
 834 =back
 835
 836 =for html </blockquote>
 837
 838 Returns:
 839
 840 =for html <blockquote>
 841
 842 =over
 843
 844 =item 1 if logged in - 0 if not
 845
 846 =back
 847
 848 =for html </blockquote>
 849
 850 =cut
 851
 852   return $self->{loggedin};
 853 } # connected
 854
 855 sub database () {
 856   my ($self) = @_;
 857
 858 =pod
 859
 860 =head2 database
 861
 862 Returns the current database (or the database that would be used)
 863
 864 Parameters:
 865
 866 =for html <blockquote>
 867
 868 =over
 869
 870 =item none
 871
 872 =back
 873
 874 =for html </blockquote>
 875
 876 Returns:
 877
 878 =for html <blockquote>
 879
 880 =over
 881
 882 =item database
 883
 884 =back
 885
 886 =for html </blockquote>
 887
 888 =cut
 889
 890   return $self->{database};
 891 } # database
 892
 893 sub dbset () {
 894   my ($self) = @_;
 895
 896 =pod
 897
 898 =head2 dbset
 899
 900 Returns the current dbset (or the dbset that would be used)
 901
 902 Parameters:
 903
 904 =for html <blockquote>
 905
 906 =over
 907
 908 =item none
 909
 910 =back
 911
 912 =for html </blockquote>
 913
 914 Returns:
 915
 916 =for html <blockquote>
 917
 918 =over
 919
 920 =item dbset
 921
 922 =back
 923
 924 =for html </blockquote>
 925
 926 =cut
 927
 928   return $self->{dbset};
 929 } # dbset
 930
 931 sub dbsets () {
 932   croak ((caller(0))[3] . ' is not implemented');
 933 } # dbsets
 934
 935 sub delete ($$) {
 936   my ($self, $table, $key) = @_;
 937
 938 =pod
 939
 940 =head2 delete ($table, $key)
 941
 942 Deletes a %record from $table.
 943
 944 Parameters:
 945
 946 =for html <blockquote>
 947
 948 =over
 949
 950 =item $table
 951
 952 Table from which to delete a record from (e.g. 'Defect')
 953
 954 =item $key
 955
 956 Key of the record to delete
 957
 958 =back
 959
 960 =for html </blockquote>
 961
 962 Returns:
 963
 964 =for html <blockquote>
 965
 966 =over
 967
 968 =item $errmsg
 969
 970 Error message (if any)
 971
 972 =back
 973
 974 =for html </blockquote>
 975
 976 =cut
 977
 978   my $query = $self->_getInternalID ($table, $key);
 979
 980   # Need to remove $self->{server} from beginning of $query
 981   $query =~ s/^http.*$self->{server}//;
 982
 983   $self->_callREST ('delete', $query);
 984
 985   return $self->errmsg;
 986 } # delete
 987
 988 sub DESTROY () {
 989   my ($self) = @_;
 990
 991   # Attempt to delete session if we still have a rest object. Note that during
 992   # global destruction (like when you die or exit), the ordering of destruction
 993   # is unpredictable so we might not succeed.
 994   return unless $self->{rest};
 995
 996   # Delete session - ignore error as there's really nothing we can do if this
 997   # fails.
 998   $self->_callREST ('delete', '/cqweb/oslc/session/');
 999
1000   croak "Unable to release REST session in destructor" if $self->error;
1001
1002   return;
1003 } # DESTROY
1004
1005 sub disconnect () {
1006   my ($self) = @_;
1007
1008 =pod
1009
1010 =head2 disconnect ()
1011
1012 Disconnects from REST. Note you should take care to call disconnect or use undef
1013 to undefine your instantiated Clearquest::REST object. If your script dies or
1014 exits without disconnecting you may cause web sessions to remain. You might try
1015 something like:
1016
1017  use Clearquest::REST;
1018
1019  my $cq = Clearquest::REST->new;
1020
1021   END {
1022     $cq->disconnect if $cq;
1023   } # END
1024
1025 Parameters:
1026
1027 =for html <blockquote>
1028
1029 =over
1030
1031 =item nothing
1032
1033 =back
1034
1035 =for html </blockquote>
1036
1037 Returns:
1038
1039 =for html <blockquote>
1040
1041 =over
1042
1043 =item $error
1044
1045 Error number (if any)
1046
1047 =back
1048
1049 =for html </blockquote>
1050
1051 =cut
1052
1053   return unless $self->{rest};
1054
1055   $self->_callREST ('delete', '/cqweb/oslc/session/');
1056
1057   return $self->error;
1058 } # disconnect
1059
1060 sub errmsg (;$) {
1061   my ($self, $errmsg) = @_;
1062
1063 =pod
1064
1065 =head2 errmsg ($errmsg)
1066
1067 Returns the last error message. Optionally sets the error message if specified.
1068
1069 Parameters:
1070
1071 =for html <blockquote>
1072
1073 =over
1074
1075 =item $errmsg
1076
1077 Error message to set
1078
1079 =back
1080
1081 =for html </blockquote>
1082
1083 Returns:
1084
1085 =for html <blockquote>
1086
1087 =over
1088
1089 =item $errmsg
1090
1091 Last error message
1092
1093 =back
1094
1095 =for html </blockquote>
1096
1097 =cut
1098
1099   if ($errmsg) {
1100     $self->{errmsg} = $errmsg;
1101   } else {
1102     # User defined errors are in the 600 series. If we have a user defined
1103     # error and the caller did not supply us an errmsg to set then they want
1104     # the user defined error we set so just return that.
1105     if ($self->{responseCode} >= 600) {
1106       return $self->{errmsg};
1107     } else {
1108       my $response = $self->response;
1109
1110       if ($response and $response ne '') {
1111         my %xml = %{XMLin ($self->response)};
1112
1113         if ($xml{Error}{message}) {
1114           $self->{errmsg} = $xml{Error}{message};
1115         } elsif (ref $xml{message} ne 'HASH' and $xml{message}) {
1116           $self->{errmsg} = $xml{message};
1117         } else {
1118           $self->{errmsg} = 'Unknown error';
1119         } # if
1120       } else {
1121         $self->{errmsg} = '';
1122       } # if
1123     } # if
1124   } # if
1125
1126   return $self->{errmsg};
1127 } # errmsg
1128
1129 sub error (;$) {
1130   my ($self, $error) = @_;
1131
1132 =pod
1133
1134 =head2 error ($error)
1135
1136 Returns the last error number. Optional set the error number if specified
1137
1138 Parameters:
1139
1140 =for html <blockquote>
1141
1142 =over
1143
1144 =item $error
1145
1146 Error number to set
1147
1148 =back
1149
1150 =for html </blockquote>
1151
1152 Returns:
1153
1154 =for html <blockquote>
1155
1156 =over
1157
1158 =item $error
1159
1160 Last error
1161
1162 =back
1163
1164 =for html </blockquote>
1165
1166 =cut
1167
1168   if (defined $error) {
1169     $self->{responseCode} = $error;
1170   } else {
1171     # If the user has not yet called any underlying REST functionality yet (for
1172     # example, they could have called the find method but have not asked for the
1173     # $nbrRecs) then we cannot call $self->{rest}->responseCode because the
1174     # REST::Client object has not been instantiated yet. So we'll return no
1175     # error.
1176     if ($self->{rest}{_res}) {
1177       $self->{responseCode} = $self->{rest}->responseCode;
1178     } else {
1179       $self->{responseCode} = 0;
1180     } # if
1181   } # if
1182
1183   return 0 if $self->{responseCode} >= 200 and $self->{responseCode} < 300;
1184   return $self->{responseCode};
1185 } # error
1186
1187 sub fields ($) {
1188   my ($self, $table) = @_;
1189
1190 =pod
1191
1192 =head2 fields ($table)
1193
1194 Returns an array of the fields in a table
1195
1196 Parameters:
1197
1198 =for html <blockquote>
1199
1200 =over
1201
1202 =item $table
1203
1204 Table to return field info from.
1205
1206 =back
1207
1208 =for html </blockquote>
1209
1210 Returns:
1211
1212 =for html <blockquote>
1213
1214 =over
1215
1216 =item @fields
1217
1218 Array of the fields names for $table
1219
1220 =back
1221
1222 =for html </blockquote>
1223
1224 =cut
1225
1226   my $recordID = $self->_getRecordID ($table);
1227
1228   return unless $recordID;
1229
1230   my $url = "$self->{uri}/record-type/$recordID";
1231
1232   $self->_callREST ('get', $url);
1233
1234   return if $self->error;
1235
1236   my %result = %{XMLin ($self->{rest}->responseContent)};
1237
1238   my @fields = keys %{$result{element}{complexType}{choice}{element}};
1239
1240   return @fields;
1241 } # fields
1242
1243 sub fieldType ($$) {
1244   my ($self, $table, $fieldName) = @_;
1245
1246 =pod
1247
1248 =head2 fieldType ($table, $fieldname)
1249
1250 Returns the field type for the $table, $fieldname combination.
1251
1252 Parameters:
1253
1254 =for html <blockquote>
1255
1256 =over
1257
1258 =item $table
1259
1260 Table to return field type from.
1261
1262 =item $fieldname
1263
1264 Fieldname to return the field type from.
1265
1266 =back
1267
1268 =for html </blockquote>
1269
1270 Returns:
1271
1272 =for html <blockquote>
1273
1274 =over
1275
1276 =item $fieldType
1277
1278 Fieldtype enum
1279
1280 =back
1281
1282 =for html </blockquote>
1283
1284 =cut
1285
1286   # If we've already computed the fieldTypes for the fields in this table then
1287   # return the value
1288   if ($FIELDS{$table}) {
1289     # If we already have this fieldType just return it
1290     if (defined $FIELDS{$table}{$fieldName}) {
1291       return $FIELDS{$table}{$fieldName}{FieldType};
1292     } else {
1293       return $UNKNOWN
1294     } # if
1295   } # if
1296
1297   $self->_parseRecordDesc ($table);
1298
1299   if (defined $FIELDS{$table}{$fieldName}) {
1300     return $FIELDS{$table}{$fieldName}{FieldType};
1301   } else {
1302     return $UNKNOWN
1303   } # if
1304 } # fieldType
1305
1306 sub fieldReference ($$) {
1307   my ($self, $table, $fieldName) = @_;
1308
1309 =pod
1310
1311 =head2 fieldReference ($table, $fieldname)
1312
1313 Returns the name of the table this reference or reference list field references
1314 or undef if this is not a reference or reference list field.
1315
1316 Parameters:
1317
1318 =for html <blockquote>
1319
1320 =over
1321
1322 =item $table
1323
1324 Table to return field reference from.
1325
1326 =item $fieldname
1327
1328 Fieldname to return the field type from.
1329
1330 =back
1331
1332 =for html </blockquote>
1333
1334 Returns:
1335
1336 =for html <blockquote>
1337
1338 =over
1339
1340 =item $fieldType
1341
1342 Name of table this reference or reference list field references or undef if
1343 this is not a reference or reference list field.
1344
1345 =back
1346
1347 =for html </blockquote>
1348
1349 =cut
1350
1351   # If we've already computed the fieldTypes for the fields in this table then
1352   # return the value
1353   return $FIELDS{$table}{$fieldName}{References} if $FIELDS{$table};
1354
1355   $self->_parseRecordDesc ($table);
1356
1357   return $FIELDS{$table}{$fieldName}{References};
1358 } # fieldReference
1359
1360 sub find ($;$@) {
1361   my ($self, $table, $condition, @fields) = @_;
1362
1363 =pod
1364
1365 =head2 find ($;$@)
1366
1367 Find records in $table. You can specify a $condition and which fields you wish
1368 to retrieve. Specifying a smaller set of fields means less data transfered and
1369 quicker retrieval so only retrieve the fields you really need.
1370
1371 Parameters:
1372
1373 =for html <blockquote>
1374
1375 =over
1376
1377 =item $table
1378
1379 Name of the table to search
1380
1381 =item $condition
1382
1383 Condition to use. If you want all records then pass in undef. Only simple
1384 conditions are supported. You can specify compound conditions (e.g. field1 ==
1385 'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
1386 supported (yet).
1387
1388 =item @fields
1389
1390 An array of fieldnames to retrieve
1391
1392 =back
1393
1394 =for html </blockquote>
1395
1396 Returns:
1397
1398 =for html <blockquote>
1399
1400 =over
1401
1402 =item $result or ($result, $nbrRecs)
1403
1404 Internal structure to be used with getNext. If in an array context then $nbrRecs
1405 is also returned.
1406
1407 =back
1408
1409 =for html </blockquote>
1410
1411 =cut
1412
1413   $self->{url} = "$self->{uri}/record/?rcm.type=$table&"
1414                . $self->_parseConditional ($table, $condition);
1415
1416   @fields = $self->_setFields ($table, @fields);
1417
1418   # Remove dbid for find
1419   @fields = grep { $_ ne 'dbid' } @fields;
1420
1421   if (@fields) {
1422     $self->{url} .= "&oslc_cm.properties=";
1423     $self->{url} .= join ',', @fields;
1424   } # if
1425
1426   # Save some fields for getNext
1427   $self->{fields} = \@fields;
1428   $self->{table}  = $table;
1429
1430   $self->{url} .= "&oslc_cm.pageSize=1";
1431
1432   return $self->{url} unless wantarray;
1433
1434   # If the user wants an array then he wants ($reesult, $nbrRecs) and so we need
1435   # to go out and get that info.
1436   $self->_callREST ('get', $self->{url});
1437
1438   return (undef, 0) if $self->error;
1439
1440   # Now parse the results
1441   my %result = %{XMLin ($self->{rest}->responseContent)};
1442
1443   return ($self->{url}, $result{'oslc_cm:totalCount'}{content});
1444 } # find
1445
1446 sub get ($$;@) {
1447   my ($self, $table, $key, @fields) = @_;
1448
1449 =pod
1450
1451 =head2 get ($table, $key, @fields)
1452
1453 Retrieve records from $table matching $key. Note $key can be a condition (e.g.
1454 Project = 'Athena'). Return back @fields. If @fields is not specified then all
1455 fields are returned.
1456
1457 Warning: Some Clearquest records are large. It's always better and faster to
1458 return only the fields that you need.
1459
1460 Parameters:
1461
1462 =for html <blockquote>
1463
1464 =over
1465
1466 =item $table
1467
1468 Table to get records from (e.g. 'Defect')
1469
1470 =item $key
1471
1472 Key to use to get the record. Key is the field that is designated to be the key
1473 for the record.
1474
1475 =item @fields
1476
1477 An array of field names to return. It's usually better to specify only those
1478 fields that you need.
1479
1480 =back
1481
1482 =for html </blockquote>
1483
1484 Returns:
1485
1486 =for html <blockquote>
1487
1488 =over
1489
1490 =item %record
1491
1492 An hash representing the qualifying record.
1493
1494 =back
1495
1496 =for html </blockquote>
1497
1498 =cut
1499
1500   my $url = "$self->{uri}/record/?rcm.type=$table&rcm.name=$key";
1501
1502   if (@fields) {
1503     $url .= "&oslc_cm.properties=";
1504     $url .= 'dbid,' unless grep { /dbid/i } @fields;
1505     $url .= join ',', @fields;
1506   } # if
1507
1508   return $self->_getRecord ($table, $url, @fields);
1509 } # get
1510
1511 sub getDBID ($$;@) {
1512   my ($self, $table, $dbid, @fields) = @_;
1513
1514 =pod
1515
1516 =head2 get ($table, $key, @fields)
1517
1518 Retrieve records from $table matching $key. Note $key can be a condition (e.g.
1519 Project = 'Athena'). Return back @fields. If @fields is not specified then all
1520 fields are returned.
1521
1522 Warning: Some Clearquest records are large. It's always better and faster to
1523 return only the fields that you need.
1524
1525 Parameters:
1526
1527 =for html <blockquote>
1528
1529 =over
1530
1531 =item $table
1532
1533 Table to get records from (e.g. 'Defect')
1534
1535 =item $key
1536
1537 Key to use to get the record. Key is the field that is designated to be the key
1538 for the record.
1539
1540 =item @fields
1541
1542 An array of field names to return. It's usually better to specify only those
1543 fields that you need.
1544
1545 =back
1546
1547 =for html </blockquote>
1548
1549 Returns:
1550
1551 =for html <blockquote>
1552
1553 =over
1554
1555 =item %record
1556
1557 An hash representing the qualifying record.
1558
1559 =back
1560
1561 =for html </blockquote>
1562
1563 =cut
1564
1565   my $url  = "$self->{uri}/record/";
1566      $url .= $self->_getRecordID ($table);
1567      $url .= '-';
1568      $url .= $dbid;
1569
1570   if (@fields) {
1571     $url .= "?oslc_cm.properties=";
1572     $url .= 'dbid,' unless grep { /dbid/i } @fields;
1573     $url .= join ',', @fields;
1574   } # if
1575
1576   return $self->_getRecord ($table, $url);
1577 } # getDBID
1578
1579 sub getDynamicList () {
1580   croak ((caller(0))[3] . ' is not implemented');
1581 } # getDynamicList
1582
1583 sub getNext ($) {
1584   my ($self, $result) = @_;
1585
1586 =pod
1587
1588 =head2 getNext ($)
1589
1590 Return the next record that qualifies from a preceeding call to the find method.
1591
1592 Parameters:
1593
1594 =for html <blockquote>
1595
1596 =over
1597
1598 =item $result
1599
1600 The $result returned from find.
1601
1602 =back
1603
1604 =for html </blockquote>
1605
1606 Returns:
1607
1608 =for html <blockquote>
1609
1610 =over
1611
1612 =item %record
1613
1614 Hash of name/value pairs for the @fields specified to find.
1615
1616 =back
1617
1618 =for html </blockquote>
1619
1620 =cut
1621
1622   return unless $self->{url};
1623
1624   my $url = $self->{url};
1625
1626   $self->_callREST ('get', $url);
1627
1628   return if $self->error;
1629
1630   # Now parse the results
1631   my %result = %{XMLin ($self->{rest}->responseContent)};
1632
1633   # Get the next link
1634   undef $self->{url};
1635
1636   if (ref $result{link} eq 'ARRAY') {
1637     foreach (@{$result{link}}) {
1638       if ($$_{rel} eq 'next') {
1639         ($self->{url}) = ($$_{href} =~ /^http.*$self->{server}(.*)/);
1640
1641         last;
1642       } # if
1643     } # foreach
1644   } # if
1645
1646   my %record;
1647
1648   if (ref $result{entry}{content}{$self->{table}} eq 'HASH') {
1649     %record = $self->_parseFields ($self->{table}, %{$result{entry}{content}{$self->{table}}});
1650   } elsif (ref $result{entry} eq 'HASH') {
1651     if ($result{entry}{id}) {
1652       %record = $self->_getRecordURL ($self->{table}, $result{entry}{id}, @{$self->{fields}});
1653     } # if
1654   } # if
1655
1656   # Get dbid
1657   if ($result{entry}{link}{href} =~ /-(\d+)$/) {
1658     $record{dbid} = $1;
1659   } # if
1660
1661   return %record;
1662 } # getNext
1663
1664 sub key ($$) {
1665   my ($self, $table, $dbid) = @_;
1666
1667 =pod
1668
1669 =head2 key ($$)
1670
1671 Return the key of the record given a $dbid
1672
1673 NOTE: Not supported in REST implementation.
1674
1675 Parameters:
1676
1677 =for html <blockquote>
1678
1679 =over
1680
1681 =item $table
1682
1683 Name of the table to lookup
1684
1685 =item $dbid
1686
1687 Database ID of the record to retrieve
1688
1689 =back
1690
1691 =for html </blockquote>
1692
1693 Returns:
1694
1695 =for html <blockquote>
1696
1697 =over
1698
1699 =item key
1700
1701 =back
1702
1703 =for html </blockquote>
1704
1705 =cut
1706
1707   croak "The method key is not support in the REST interface";
1708 } # key
1709
1710 sub modify ($$$$;@) {
1711   my ($self, $table, $key, $action, $values, @ordering) = @_;
1712
1713 =pod
1714
1715 =head2 modify ($table, $key, $action, $values, @ordering)
1716
1717 Updates records from $table matching $key.
1718
1719 Parameters:
1720
1721 =for html <blockquote>
1722
1723 =over
1724
1725 =item $table
1726
1727 Table to modify records (e.g. 'Defect')
1728
1729 =item $key
1730
1731 The $key of the record to modify.
1732
1733 =item $action
1734
1735 Action to use for modification (Default: Modify). You can use this to change
1736 state for stateful records.
1737
1738 =item $values
1739
1740 Hash reference containing name/value that have the new values for the fields
1741
1742 =item @ordering
1743
1744 Array containing field names that need to be processed in order. Not all fields
1745 mentioned in the $values hash need be mentioned here. If you have fields that
1746 must be set in a particular order you can mention them here. So, if you're
1747 modifying the Defect record, but you need Project set before Platform,  you need
1748 only pass in an @ordering of qw(Project Platform). They will be done first, then
1749 all of the rest of the fields in the $values hash. If you have no ordering
1750 dependencies then you can simply omit @ordering.
1751
1752 Note that the best way to determine if you have an ordering dependency try using
1753 a Clearquest client and note the order that you set fields in. If at anytime
1754 setting one field negates another field via action hook code then you have just
1755 figured out that this field needs to be set before the file that just got
1756 negated.
1757
1758 =back
1759
1760 =for html </blockquote>
1761
1762 Returns:
1763
1764 =for html <blockquote>
1765
1766 =over
1767
1768 =item $errmsg
1769
1770 Error message (if any)
1771
1772 =back
1773
1774 =for html </blockquote>
1775
1776 =cut
1777
1778   my %values = %$values;
1779   my $xml    = _startXML $table;
1780
1781   $action ||= 'Modify';
1782
1783   my $query = $self->_getInternalID ($table, $key);
1784
1785   # Remove host portion
1786   $query =~ s/^http.*$self->{server}//;
1787
1788   # Add on action
1789   $query .= "?rcm.action=$action";
1790
1791   # First process all fields in the @ordering, if specified
1792   $xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
1793
1794   foreach my $field (keys %values) {
1795     next if InArray $field, @ordering;
1796
1797     $xml .= $self->_setFieldValue ($table, $field, $values{$field});
1798   } # foreach
1799
1800   $xml .= "</$table>";
1801
1802   $self->_callREST ('put', $query, $xml);
1803
1804   return $self->errmsg;
1805 } # modify
1806
1807 sub modifyDBID ($$$$;@) {
1808   my ($self, $table, $dbid, $action, $values, @ordering) = @_;
1809
1810 =pod
1811
1812 =head2 modifyDBID ($table, $dbid, $action, %update)
1813
1814 Updates records from $table matching $dbid.
1815
1816 Parameters:
1817
1818 =for html <blockquote>
1819
1820 =over
1821
1822 =item $table
1823
1824 Table to modify records (e.g. 'Defect')
1825
1826 =item $dbid
1827
1828 The $dbid of the record to modify.
1829
1830 =item $action
1831
1832 Action to use for modification (Default: Modify). You can use this to change
1833 state for stateful records.
1834
1835 =item $values
1836
1837 Hash reference containing name/value that have the new values for the fields
1838
1839 =item @ordering
1840
1841 Array containing field names that need to be processed in order. Not all fields
1842 mentioned in the $values hash need be mentioned here. If you have fields that
1843 must be set in a particular order you can mention them here. So, if you're
1844 modifying the Defect record, but you need Project set before Platform,  you need
1845 only pass in an @ordering of qw(Project Platform). They will be done first, then
1846 all of the rest of the fields in the $values hash. If you have no ordering
1847 dependencies then you can simply omit @ordering.
1848
1849 Note that the best way to determine if you have an ordering dependency try using
1850 a Clearquest client and note the order that you set fields in. If at anytime
1851 setting one field negates another field via action hook code then you have just
1852 figured out that this field needs to be set before the file that just got
1853 negated.
1854
1855 =back
1856
1857 =for html </blockquote>
1858
1859 Returns:
1860
1861 =for html <blockquote>
1862
1863 =over
1864
1865 =item $errmsg
1866
1867 Error message (if any)
1868
1869 =back
1870
1871 =for html </blockquote>
1872
1873 =cut
1874
1875   my %values = %$values;
1876   my $xml    = _startXML $table;
1877
1878   $action ||= 'Modify';
1879
1880   my $query  = "$self->{uri}/record/";
1881      $query .= $self->_getRecordID ($table);
1882      $query .= '-';
1883      $query .= $dbid;
1884
1885   # Add on action
1886   $query .= "?rcm.action=$action";
1887
1888   # First process all fields in the @ordering, if specified
1889   $xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
1890
1891   foreach my $field (keys %values) {
1892     next if InArray $field, @ordering;
1893
1894     $xml .= $self->_setFieldValue ($table, $field, $values{$field});
1895   } # foreach
1896
1897   $xml .= "</$table>";
1898
1899   $self->_callREST ('put', $query, $xml);
1900
1901   return $self->errmsg;
1902 } # modifyDBID
1903
1904 sub new (;%) {
1905   my ($class, $self) = @_;
1906
1907 =pod
1908
1909 =head2 new (%parms)
1910
1911 Instantiate a new REST object. You can override the standard options by passing
1912 them in as a hash in %parms.
1913
1914 Parameters:
1915
1916 =for html <blockquote>
1917
1918 =over
1919
1920 =item %parms
1921
1922 Hash of overriding options
1923
1924 =back
1925
1926 =for html </blockquote>
1927
1928 Returns:
1929
1930 =for html <blockquote>
1931
1932 =over
1933
1934 =item REST object
1935
1936 =back
1937
1938 =for html </blockquote>
1939
1940 =cut
1941
1942   $self->{server} ||= $Clearquest::OPTS{CQ_SERVER};
1943
1944   $$self{base_url} = "$self->{server}/cqweb/oslc",
1945   $$self{uri}      = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}",
1946   $$self{login}    = {
1947 #    'OSLC-Core-Version' => '2.0',
1948     Accept              => 'application/xml',
1949     Authorization       => 'Basic '
1950       . encode_base64 "$self->{username}:$self->{password}",
1951   };
1952
1953   bless $self, $class;
1954
1955   # We create this UserAgent and Cookie Jar so we can set cookies to be
1956   # remembered and passed back and forth automatically. By doing this we re-use
1957   # the JSESSIONID cookie we allows us to reuse our login and to dispose of the
1958   # login session properly when we are destroyed.
1959   my $userAgent = LWP::UserAgent->new;
1960
1961   # Set the cookie jar to use in-memory cookie management, cookies can be
1962   # persisted to disk, see HTTP::Cookies for more info.
1963   $userAgent->cookie_jar (HTTP::Cookies->new);
1964
1965   $self->{rest} = REST::Client->new (
1966     host      => $self->{server},
1967     timeout   => 15,
1968     follow    => 1,
1969     useragent => $userAgent,
1970   );
1971
1972   return $self;
1973 } # new
1974
1975 sub records () {
1976   my ($self) = @_;
1977
1978 =pod
1979
1980 =head2 records ()
1981
1982 Returns a hash of all records and their record numbers
1983
1984 Parameters:
1985
1986 =for html <blockquote>
1987
1988 =over
1989
1990 =item nothing
1991
1992 =back
1993
1994 =for html </blockquote>
1995
1996 Returns:
1997
1998 =for html <blockquote>
1999
2000 =over
2001
2002 =item %records
2003
2004 Hash of records and their record numbers
2005
2006 =back
2007
2008 =for html </blockquote>
2009
2010 =cut
2011
2012   return if %RECORDS;
2013
2014   my $url = "$self->{uri}/record-type/";
2015
2016   $self->_callREST ('get', $url);
2017
2018   unless ($self->error) {
2019     my %result = %{XMLin ($self->{rest}->responseContent)};
2020
2021     foreach my $uri (keys %{$result{entry}}) {
2022       my ($recordID) = ($uri =~ /\/(\d+)/);
2023
2024       $RECORDS{$result{entry}{$uri}{title}} = $recordID;
2025     } # foreach
2026   } # unless
2027
2028   return %RECORDS;
2029 } # records
2030
2031 sub response () {
2032   my ($self) = @_;
2033
2034 =pod
2035
2036 =head2 response ()
2037
2038 Returns the response content
2039
2040 Parameters:
2041
2042 =for html <blockquote>
2043
2044 =over
2045
2046 =item nothing
2047
2048 =back
2049
2050 =for html </blockquote>
2051
2052 Returns:
2053
2054 =for html <blockquote>
2055
2056 =over
2057
2058 =item $respondContent
2059
2060 Response content from the last REST call
2061
2062 =back
2063
2064 =for html </blockquote>
2065
2066 =cut
2067
2068   return $self->{rest}->responseContent;
2069 } # response
2070
2071 sub username () {
2072   my ($self) = @_;
2073
2074 =pod
2075
2076 =head2 username
2077
2078 Returns the current username (or the username that would be used)
2079
2080 Parameters:
2081
2082 =for html <blockquote>
2083
2084 =over
2085
2086 =item none
2087
2088 =back
2089
2090 =for html </blockquote>
2091
2092 Returns:
2093
2094 =for html <blockquote>
2095
2096 =over
2097
2098 =item username
2099
2100 =back
2101
2102 =for html </blockquote>
2103
2104 =cut
2105
2106   return $self->{username};
2107 } # username
2108
2109 1;
2110
2111 =pod
2112
2113 =head1 CONFIGURATION AND ENVIRONMENT
2114
2115 DEBUG: If set then $debug is set to this level.
2116
2117 VERBOSE: If set then $verbose is set to this level.
2118
2119 TRACE: If set then $trace is set to this level.
2120
2121 =head1 DEPENDENCIES
2122
2123 =head2 Perl Modules
2124
2125 L<Carp>
2126
2127 L<Encode>
2128
2129 L<File::Basename|File::Basename>
2130
2131 L<HTTP::Cookies|HTTP::Cookies>
2132
2133 L<LWP::UserAgent|LWP::UserAgent>
2134
2135 L<MIME::Base64|MIME::Base64>
2136
2137 L<REST::Client|REST::Client>
2138
2139 L<XML::Simple|XML::Simple>
2140
2141 L<MIME::Base64|MIME::Base64>
2142
2143 =head2 ClearSCM Perl Modules
2144
2145 =begin man
2146
2147  GetConfig
2148
2149 =end man
2150
2151 =begin html
2152
2153 <blockquote>
2154 <a href="http://clearscm.com/php/scm_man.php?file=lib/GetConfig.pm">GetConf</a><br>
2155 </blockquote>
2156
2157 =end html
2158
2159 =head1 SEE ALSO
2160
2161 =head1 BUGS AND LIMITATIONS
2162
2163 There are no known bugs in this module.
2164
2165 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
2166
2167 =head1 LICENSE AND COPYRIGHT
2168
2169 Copyright (c) 2012, ClearSCM, Inc. All rights reserved.
2170
2171 =cut