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
1169   if (defined $error) {
1170     $self->{responseCode} = $error;
1171   } else {
1172     # If the user has not yet called any underlying REST functionality yet (for
1173     # example, they could have called the find method but have not asked for the
1174     # $nbrRecs) then we cannot call $self->{rest}->responseCode because the
1175     # REST::Client object has not been instantiated yet. So we'll return no
1176     # error.
1177     if ($self->{rest}{_res}) {
1178       $self->{responseCode} = $self->{rest}->responseCode;
1179     } else {
1180       $self->{responseCode} = 0;
1181     } # if
1182   } # if
1183
1184   return 0 if $self->{responseCode} >= 200 and $self->{responseCode} < 300;
1185   return $self->{responseCode};
1186 } # error
1187
1188 sub fields ($) {
1189   my ($self, $table) = @_;
1190
1191 =pod
1192
1193 =head2 fields ($table)
1194
1195 Returns an array of the fields in a table
1196
1197 Parameters:
1198
1199 =for html <blockquote>
1200
1201 =over
1202
1203 =item $table
1204
1205 Table to return field info from.
1206
1207 =back
1208
1209 =for html </blockquote>
1210
1211 Returns:
1212
1213 =for html <blockquote>
1214
1215 =over
1216
1217 =item @fields
1218
1219 Array of the fields names for $table
1220
1221 =back
1222
1223 =for html </blockquote>
1224
1225 =cut
1226
1227   my $recordID = $self->_getRecordID ($table);
1228
1229   return unless $recordID;
1230
1231   my $url = "$self->{uri}/record-type/$recordID";
1232
1233   $self->_callREST ('get', $url);
1234
1235   return if $self->error;
1236
1237   my %result = %{XMLin ($self->{rest}->responseContent)};
1238
1239   my @fields = keys %{$result{element}{complexType}{choice}{element}};
1240
1241   return @fields;
1242 } # fields
1243
1244 sub fieldType ($$) {
1245   my ($self, $table, $fieldName) = @_;
1246
1247 =pod
1248
1249 =head2 fieldType ($table, $fieldname)
1250
1251 Returns the field type for the $table, $fieldname combination.
1252
1253 Parameters:
1254
1255 =for html <blockquote>
1256
1257 =over
1258
1259 =item $table
1260
1261 Table to return field type from.
1262
1263 =item $fieldname
1264
1265 Fieldname to return the field type from.
1266
1267 =back
1268
1269 =for html </blockquote>
1270
1271 Returns:
1272
1273 =for html <blockquote>
1274
1275 =over
1276
1277 =item $fieldType
1278
1279 Fieldtype enum
1280
1281 =back
1282
1283 =for html </blockquote>
1284
1285 =cut
1286
1287   # If we've already computed the fieldTypes for the fields in this table then
1288   # return the value
1289   if ($FIELDS{$table}) {
1290     # If we already have this fieldType just return it
1291     if (defined $FIELDS{$table}{$fieldName}) {
1292       return $FIELDS{$table}{$fieldName}{FieldType};
1293     } else {
1294       return $UNKNOWN
1295     } # if
1296   } # if
1297
1298   $self->_parseRecordDesc ($table);
1299
1300   if (defined $FIELDS{$table}{$fieldName}) {
1301     return $FIELDS{$table}{$fieldName}{FieldType};
1302   } else {
1303     return $UNKNOWN
1304   } # if
1305 } # fieldType
1306
1307 sub fieldReference ($$) {
1308   my ($self, $table, $fieldName) = @_;
1309
1310 =pod
1311
1312 =head2 fieldReference ($table, $fieldname)
1313
1314 Returns the name of the table this reference or reference list field references
1315 or undef if this is not a reference or reference list field.
1316
1317 Parameters:
1318
1319 =for html <blockquote>
1320
1321 =over
1322
1323 =item $table
1324
1325 Table to return field reference from.
1326
1327 =item $fieldname
1328
1329 Fieldname to return the field type from.
1330
1331 =back
1332
1333 =for html </blockquote>
1334
1335 Returns:
1336
1337 =for html <blockquote>
1338
1339 =over
1340
1341 =item $fieldType
1342
1343 Name of table this reference or reference list field references or undef if
1344 this is not a reference or reference list field.
1345
1346 =back
1347
1348 =for html </blockquote>
1349
1350 =cut
1351
1352   # If we've already computed the fieldTypes for the fields in this table then
1353   # return the value
1354   return $FIELDS{$table}{$fieldName}{References} if $FIELDS{$table};
1355
1356   $self->_parseRecordDesc ($table);
1357
1358   return $FIELDS{$table}{$fieldName}{References};
1359 } # fieldReference
1360
1361 sub find ($;$@) {
1362   my ($self, $table, $condition, @fields) = @_;
1363
1364 =pod
1365
1366 =head2 find ($;$@)
1367
1368 Find records in $table. You can specify a $condition and which fields you wish
1369 to retrieve. Specifying a smaller set of fields means less data transfered and
1370 quicker retrieval so only retrieve the fields you really need.
1371
1372 Parameters:
1373
1374 =for html <blockquote>
1375
1376 =over
1377
1378 =item $table
1379
1380 Name of the table to search
1381
1382 =item $condition
1383
1384 Condition to use. If you want all records then pass in undef. Only simple
1385 conditions are supported. You can specify compound conditions (e.g. field1 ==
1386 'foo' and field1 == 'bar' or field2 is not null). No parenthesizing is
1387 supported (yet).
1388
1389 =item @fields
1390
1391 An array of fieldnames to retrieve
1392
1393 =back
1394
1395 =for html </blockquote>
1396
1397 Returns:
1398
1399 =for html <blockquote>
1400
1401 =over
1402
1403 =item $result or ($result, $nbrRecs)
1404
1405 Internal structure to be used with getNext. If in an array context then $nbrRecs
1406 is also returned.
1407
1408 =back
1409
1410 =for html </blockquote>
1411
1412 =cut
1413
1414   $self->{url} = "$self->{uri}/record/?rcm.type=$table&"
1415                . $self->_parseConditional ($table, $condition);
1416
1417   @fields = $self->_setFields ($table, @fields);
1418
1419   # Remove dbid for find
1420   @fields = grep { $_ ne 'dbid' } @fields;
1421
1422   if (@fields) {
1423     $self->{url} .= "&oslc_cm.properties=";
1424     $self->{url} .= join ',', @fields;
1425   } # if
1426
1427   # Save some fields for getNext
1428   $self->{fields} = \@fields;
1429   $self->{table}  = $table;
1430
1431   $self->{url} .= "&oslc_cm.pageSize=1";
1432
1433   return $self->{url} unless wantarray;
1434
1435   # If the user wants an array then he wants ($reesult, $nbrRecs) and so we need
1436   # to go out and get that info.
1437   $self->_callREST ('get', $self->{url});
1438
1439   return (undef, 0) if $self->error;
1440
1441   # Now parse the results
1442   my %result = %{XMLin ($self->{rest}->responseContent)};
1443
1444   return ($self->{url}, $result{'oslc_cm:totalCount'}{content});
1445 } # find
1446
1447 sub get ($$;@) {
1448   my ($self, $table, $key, @fields) = @_;
1449
1450 =pod
1451
1452 =head2 get ($table, $key, @fields)
1453
1454 Retrieve records from $table matching $key. Note $key can be a condition (e.g.
1455 Project = 'Athena'). Return back @fields. If @fields is not specified then all
1456 fields are returned.
1457
1458 Warning: Some Clearquest records are large. It's always better and faster to
1459 return only the fields that you need.
1460
1461 Parameters:
1462
1463 =for html <blockquote>
1464
1465 =over
1466
1467 =item $table
1468
1469 Table to get records from (e.g. 'Defect')
1470
1471 =item $key
1472
1473 Key to use to get the record. Key is the field that is designated to be the key
1474 for the record.
1475
1476 =item @fields
1477
1478 An array of field names to return. It's usually better to specify only those
1479 fields that you need.
1480
1481 =back
1482
1483 =for html </blockquote>
1484
1485 Returns:
1486
1487 =for html <blockquote>
1488
1489 =over
1490
1491 =item %record
1492
1493 An hash representing the qualifying record.
1494
1495 =back
1496
1497 =for html </blockquote>
1498
1499 =cut
1500
1501   my $url = "$self->{uri}/record/?rcm.type=$table&rcm.name=$key";
1502
1503   if (@fields) {
1504     $url .= "&oslc_cm.properties=";
1505     $url .= 'dbid,' unless grep { /dbid/i } @fields;
1506     $url .= join ',', @fields;
1507   } # if
1508
1509   return $self->_getRecord ($table, $url, @fields);
1510 } # get
1511
1512 sub getDBID ($$;@) {
1513   my ($self, $table, $dbid, @fields) = @_;
1514
1515 =pod
1516
1517 =head2 get ($table, $key, @fields)
1518
1519 Retrieve records from $table matching $key. Note $key can be a condition (e.g.
1520 Project = 'Athena'). Return back @fields. If @fields is not specified then all
1521 fields are returned.
1522
1523 Warning: Some Clearquest records are large. It's always better and faster to
1524 return only the fields that you need.
1525
1526 Parameters:
1527
1528 =for html <blockquote>
1529
1530 =over
1531
1532 =item $table
1533
1534 Table to get records from (e.g. 'Defect')
1535
1536 =item $key
1537
1538 Key to use to get the record. Key is the field that is designated to be the key
1539 for the record.
1540
1541 =item @fields
1542
1543 An array of field names to return. It's usually better to specify only those
1544 fields that you need.
1545
1546 =back
1547
1548 =for html </blockquote>
1549
1550 Returns:
1551
1552 =for html <blockquote>
1553
1554 =over
1555
1556 =item %record
1557
1558 An hash representing the qualifying record.
1559
1560 =back
1561
1562 =for html </blockquote>
1563
1564 =cut
1565
1566   my $url  = "$self->{uri}/record/";
1567      $url .= $self->_getRecordID ($table);
1568      $url .= '-';
1569      $url .= $dbid;
1570
1571   if (@fields) {
1572     $url .= "?oslc_cm.properties=";
1573     $url .= 'dbid,' unless grep { /dbid/i } @fields;
1574     $url .= join ',', @fields;
1575   } # if
1576
1577   return $self->_getRecord ($table, $url);
1578 } # getDBID
1579
1580 sub getDynamicList () {
1581   croak ((caller(0))[3] . ' is not implemented');
1582 } # getDynamicList
1583
1584 sub getNext ($) {
1585   my ($self, $result) = @_;
1586
1587 =pod
1588
1589 =head2 getNext ($)
1590
1591 Return the next record that qualifies from a preceeding call to the find method.
1592
1593 Parameters:
1594
1595 =for html <blockquote>
1596
1597 =over
1598
1599 =item $result
1600
1601 The $result returned from find.
1602
1603 =back
1604
1605 =for html </blockquote>
1606
1607 Returns:
1608
1609 =for html <blockquote>
1610
1611 =over
1612
1613 =item %record
1614
1615 Hash of name/value pairs for the @fields specified to find.
1616
1617 =back
1618
1619 =for html </blockquote>
1620
1621 =cut
1622
1623   return unless $self->{url};
1624
1625   my $url = $self->{url};
1626
1627   $self->_callREST ('get', $url);
1628
1629   return if $self->error;
1630
1631   # Now parse the results
1632   my %result = %{XMLin ($self->{rest}->responseContent)};
1633
1634   # Get the next link
1635   undef $self->{url};
1636
1637   if (ref $result{link} eq 'ARRAY') {
1638     foreach (@{$result{link}}) {
1639       if ($$_{rel} eq 'next') {
1640         ($self->{url}) = ($$_{href} =~ /^http.*$self->{server}(.*)/);
1641
1642         last;
1643       } # if
1644     } # foreach
1645   } # if
1646
1647   my %record;
1648
1649   if (ref $result{entry}{content}{$self->{table}} eq 'HASH') {
1650     %record = $self->_parseFields ($self->{table}, %{$result{entry}{content}{$self->{table}}});
1651   } elsif (ref $result{entry} eq 'HASH') {
1652     if ($result{entry}{id}) {
1653       %record = $self->_getRecordURL ($self->{table}, $result{entry}{id}, @{$self->{fields}});
1654     } # if
1655   } # if
1656
1657   # Get dbid
1658   if ($result{entry}{link}{href} =~ /-(\d+)$/) {
1659     $record{dbid} = $1;
1660   } # if
1661
1662   return %record;
1663 } # getNext
1664
1665 sub key ($$) {
1666   my ($self, $table, $dbid) = @_;
1667
1668 =pod
1669
1670 =head2 key ($$)
1671
1672 Return the key of the record given a $dbid
1673
1674 NOTE: Not supported in REST implementation.
1675
1676 Parameters:
1677
1678 =for html <blockquote>
1679
1680 =over
1681
1682 =item $table
1683
1684 Name of the table to lookup
1685
1686 =item $dbid
1687
1688 Database ID of the record to retrieve
1689
1690 =back
1691
1692 =for html </blockquote>
1693
1694 Returns:
1695
1696 =for html <blockquote>
1697
1698 =over
1699
1700 =item key
1701
1702 =back
1703
1704 =for html </blockquote>
1705
1706 =cut
1707
1708   croak "The method key is not support in the REST interface";
1709 } # key
1710
1711 sub modify ($$$$;@) {
1712   my ($self, $table, $key, $action, $values, @ordering) = @_;
1713
1714 =pod
1715
1716 =head2 modify ($table, $key, $action, $values, @ordering)
1717
1718 Updates records from $table matching $key.
1719
1720 Parameters:
1721
1722 =for html <blockquote>
1723
1724 =over
1725
1726 =item $table
1727
1728 Table to modify records (e.g. 'Defect')
1729
1730 =item $key
1731
1732 The $key of the record to modify.
1733
1734 =item $action
1735
1736 Action to use for modification (Default: Modify). You can use this to change
1737 state for stateful records.
1738
1739 =item $values
1740
1741 Hash reference containing name/value that have the new values for the fields
1742
1743 =item @ordering
1744
1745 Array containing field names that need to be processed in order. Not all fields
1746 mentioned in the $values hash need be mentioned here. If you have fields that
1747 must be set in a particular order you can mention them here. So, if you're
1748 modifying the Defect record, but you need Project set before Platform,  you need
1749 only pass in an @ordering of qw(Project Platform). They will be done first, then
1750 all of the rest of the fields in the $values hash. If you have no ordering
1751 dependencies then you can simply omit @ordering.
1752
1753 Note that the best way to determine if you have an ordering dependency try using
1754 a Clearquest client and note the order that you set fields in. If at anytime
1755 setting one field negates another field via action hook code then you have just
1756 figured out that this field needs to be set before the file that just got
1757 negated.
1758
1759 =back
1760
1761 =for html </blockquote>
1762
1763 Returns:
1764
1765 =for html <blockquote>
1766
1767 =over
1768
1769 =item $errmsg
1770
1771 Error message (if any)
1772
1773 =back
1774
1775 =for html </blockquote>
1776
1777 =cut
1778
1779   my %values = %$values;
1780   my $xml    = _startXML $table;
1781
1782   $action ||= 'Modify';
1783
1784   my $query = $self->_getInternalID ($table, $key);
1785
1786   # Remove host portion
1787   $query =~ s/^http.*$self->{server}//;
1788
1789   # Add on action
1790   $query .= "?rcm.action=$action";
1791
1792   # First process all fields in the @ordering, if specified
1793   $xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
1794
1795   foreach my $field (keys %values) {
1796     next if InArray $field, @ordering;
1797
1798     $xml .= $self->_setFieldValue ($table, $field, $values{$field});
1799   } # foreach
1800
1801   $xml .= "</$table>";
1802
1803   $self->_callREST ('put', $query, $xml);
1804
1805   return $self->errmsg;
1806 } # modify
1807
1808 sub modifyDBID ($$$$;@) {
1809   my ($self, $table, $dbid, $action, $values, @ordering) = @_;
1810
1811 =pod
1812
1813 =head2 modifyDBID ($table, $dbid, $action, %update)
1814
1815 Updates records from $table matching $dbid.
1816
1817 Parameters:
1818
1819 =for html <blockquote>
1820
1821 =over
1822
1823 =item $table
1824
1825 Table to modify records (e.g. 'Defect')
1826
1827 =item $dbid
1828
1829 The $dbid of the record to modify.
1830
1831 =item $action
1832
1833 Action to use for modification (Default: Modify). You can use this to change
1834 state for stateful records.
1835
1836 =item $values
1837
1838 Hash reference containing name/value that have the new values for the fields
1839
1840 =item @ordering
1841
1842 Array containing field names that need to be processed in order. Not all fields
1843 mentioned in the $values hash need be mentioned here. If you have fields that
1844 must be set in a particular order you can mention them here. So, if you're
1845 modifying the Defect record, but you need Project set before Platform,  you need
1846 only pass in an @ordering of qw(Project Platform). They will be done first, then
1847 all of the rest of the fields in the $values hash. If you have no ordering
1848 dependencies then you can simply omit @ordering.
1849
1850 Note that the best way to determine if you have an ordering dependency try using
1851 a Clearquest client and note the order that you set fields in. If at anytime
1852 setting one field negates another field via action hook code then you have just
1853 figured out that this field needs to be set before the file that just got
1854 negated.
1855
1856 =back
1857
1858 =for html </blockquote>
1859
1860 Returns:
1861
1862 =for html <blockquote>
1863
1864 =over
1865
1866 =item $errmsg
1867
1868 Error message (if any)
1869
1870 =back
1871
1872 =for html </blockquote>
1873
1874 =cut
1875
1876   my %values = %$values;
1877   my $xml    = _startXML $table;
1878
1879   $action ||= 'Modify';
1880
1881   my $query  = "$self->{uri}/record/";
1882      $query .= $self->_getRecordID ($table);
1883      $query .= '-';
1884      $query .= $dbid;
1885
1886   # Add on action
1887   $query .= "?rcm.action=$action";
1888
1889   # First process all fields in the @ordering, if specified
1890   $xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
1891
1892   foreach my $field (keys %values) {
1893     next if InArray $field, @ordering;
1894
1895     $xml .= $self->_setFieldValue ($table, $field, $values{$field});
1896   } # foreach
1897
1898   $xml .= "</$table>";
1899
1900   $self->_callREST ('put', $query, $xml);
1901
1902   return $self->errmsg;
1903 } # modifyDBID
1904
1905 sub new (;%) {
1906   my ($class, $self) = @_;
1907
1908 =pod
1909
1910 =head2 new (%parms)
1911
1912 Instantiate a new REST object. You can override the standard options by passing
1913 them in as a hash in %parms.
1914
1915 Parameters:
1916
1917 =for html <blockquote>
1918
1919 =over
1920
1921 =item %parms
1922
1923 Hash of overriding options
1924
1925 =back
1926
1927 =for html </blockquote>
1928
1929 Returns:
1930
1931 =for html <blockquote>
1932
1933 =over
1934
1935 =item REST object
1936
1937 =back
1938
1939 =for html </blockquote>
1940
1941 =cut
1942
1943   $self->{server} ||= $Clearquest::OPTS{CQ_SERVER};
1944
1945   $$self{base_url} = "$self->{server}/cqweb/oslc",
1946   $$self{uri}      = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}",
1947   $$self{login}    = {
1948 #    'OSLC-Core-Version' => '2.0',
1949     Accept              => 'application/xml',
1950     Authorization       => 'Basic '
1951       . encode_base64 "$self->{username}:$self->{password}",
1952   };
1953
1954   bless $self, $class;
1955
1956   # We create this UserAgent and Cookie Jar so we can set cookies to be
1957   # remembered and passed back and forth automatically. By doing this we re-use
1958   # the JSESSIONID cookie we allows us to reuse our login and to dispose of the
1959   # login session properly when we are destroyed.
1960   my $userAgent = LWP::UserAgent->new;
1961
1962   # Set the cookie jar to use in-memory cookie management, cookies can be
1963   # persisted to disk, see HTTP::Cookies for more info.
1964   $userAgent->cookie_jar (HTTP::Cookies->new);
1965
1966   $self->{rest} = REST::Client->new (
1967     host      => $self->{server},
1968     timeout   => 15,
1969     follow    => 1,
1970     useragent => $userAgent,
1971   );
1972
1973   return $self;
1974 } # new
1975
1976 sub records () {
1977   my ($self) = @_;
1978
1979 =pod
1980
1981 =head2 records ()
1982
1983 Returns a hash of all records and their record numbers
1984
1985 Parameters:
1986
1987 =for html <blockquote>
1988
1989 =over
1990
1991 =item nothing
1992
1993 =back
1994
1995 =for html </blockquote>
1996
1997 Returns:
1998
1999 =for html <blockquote>
2000
2001 =over
2002
2003 =item %records
2004
2005 Hash of records and their record numbers
2006
2007 =back
2008
2009 =for html </blockquote>
2010
2011 =cut
2012
2013   return if %RECORDS;
2014
2015   my $url = "$self->{uri}/record-type/";
2016
2017   $self->_callREST ('get', $url);
2018
2019   unless ($self->error) {
2020     my %result = %{XMLin ($self->{rest}->responseContent)};
2021
2022     foreach my $uri (keys %{$result{entry}}) {
2023       my ($recordID) = ($uri =~ /\/(\d+)/);
2024
2025       $RECORDS{$result{entry}{$uri}{title}} = $recordID;
2026     } # foreach
2027   } # unless
2028
2029   return %RECORDS;
2030 } # records
2031
2032 sub response () {
2033   my ($self) = @_;
2034
2035 =pod
2036
2037 =head2 response ()
2038
2039 Returns the response content
2040
2041 Parameters:
2042
2043 =for html <blockquote>
2044
2045 =over
2046
2047 =item nothing
2048
2049 =back
2050
2051 =for html </blockquote>
2052
2053 Returns:
2054
2055 =for html <blockquote>
2056
2057 =over
2058
2059 =item $respondContent
2060
2061 Response content from the last REST call
2062
2063 =back
2064
2065 =for html </blockquote>
2066
2067 =cut
2068
2069   return $self->{rest}->responseContent;
2070 } # response
2071
2072 sub username () {
2073   my ($self) = @_;
2074
2075 =pod
2076
2077 =head2 username
2078
2079 Returns the current username (or the username that would be used)
2080
2081 Parameters:
2082
2083 =for html <blockquote>
2084
2085 =over
2086
2087 =item none
2088
2089 =back
2090
2091 =for html </blockquote>
2092
2093 Returns:
2094
2095 =for html <blockquote>
2096
2097 =over
2098
2099 =item username
2100
2101 =back
2102
2103 =for html </blockquote>
2104
2105 =cut
2106
2107   return $self->{username};
2108 } # username
2109
2110 1;
2111
2112 =pod
2113
2114 =head1 CONFIGURATION AND ENVIRONMENT
2115
2116 DEBUG: If set then $debug is set to this level.
2117
2118 VERBOSE: If set then $verbose is set to this level.
2119
2120 TRACE: If set then $trace is set to this level.
2121
2122 =head1 DEPENDENCIES
2123
2124 =head2 Perl Modules
2125
2126 L<Carp>
2127
2128 L<Encode>
2129
2130 L<File::Basename|File::Basename>
2131
2132 L<HTTP::Cookies|HTTP::Cookies>
2133
2134 L<LWP::UserAgent|LWP::UserAgent>
2135
2136 L<MIME::Base64|MIME::Base64>
2137
2138 L<REST::Client|REST::Client>
2139
2140 L<XML::Simple|XML::Simple>
2141
2142 L<MIME::Base64|MIME::Base64>
2143
2144 =head2 ClearSCM Perl Modules
2145
2146 =begin man
2147
2148  GetConfig
2149
2150 =end man
2151
2152 =begin html
2153
2154 <blockquote>
2155 <a href="http://clearscm.com/php/cvs_man.php?file=lib/GetConfig.pm">GetConf</a><br>
2156 </blockquote>
2157
2158 =end html
2159
2160 =head1 SEE ALSO
2161
2162 =head1 BUGS AND LIMITATIONS
2163
2164 There are no known bugs in this module.
2165
2166 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
2167
2168 =head1 LICENSE AND COPYRIGHT
2169
2170 Copyright (c) 2012, ClearSCM, Inc. All rights reserved.
2171
2172 =cut