=back
=cut
-
+
our (%RECORDS, %FIELDS);
# FieldTypes ENUM
sub _callREST ($$$;%) {
my ($self, $type, $url, $body, %parms) = @_;
-
+
# Set error and errmsg to no error
$self->error (0);
$self->{errmsg} = '';
-
+
# Upshift the call type as the calls are actually like 'GET' and not 'get'
$type = uc $type;
-
+
# We only support these call types
croak "Unknown call type \"$type\""
unless $type eq 'GET' or
$type eq 'PUT' or
$type eq 'DELETE' or
$type eq 'HEAD';
-
+
# If the caller did not give us authorization then use the login member we
# already have in the object
unless ($parms{Authorization}) {
if ($url =~ /oslc.where/) {
$parms{'OSLC-Core-Version'} = '2.0';
} # if
-
+
# Remove the host portion if any
$url =~ s/^http.*$self->{server}//;
-
+
# Call the REST call (Different calls have different numbers of parameters)
if ($type eq 'GET' or
$type eq 'DELETE' or
} else {
$self->{rest}->$type ($url, $body, \%parms);
} # if
-
+
return $self->error;
} # _callREST
sub _getRecordName ($) {
my ($self, $query) = @_;
-
+
$self->_callREST ('get', $query);
-
+
if ($self->error) {
$self->errmsg ("Unable to get record name for $query");
-
+
return;
} # if
my %record = %{XMLin ($self->{rest}->responseContent)};
-
+
return $record{element}{name};
} # _getRecordName
sub _getAttachmentList ($$) {
my ($self, $result, $fields) = @_;
-
+
croak ((caller(0))[3] . ' is not implemented');
return;
$query .= "rcm.name=$key";
$self->_callREST ('get', $query);
-
+
unless ($self->error) {
my %result = %{XMLin ($self->{rest}->responseContent)};
return $result{entry}{id};
} else {
$self->errmsg ("Record not found (Table: $table, Key: \"$key\")");
-
+
return $self->errmsg;
} # unless
} # _getInternalID
my ($self, $table, $url, @fields) = @_;
$self->{fields} = [$self->_setFields ($table, @fields)];
-
+
$self->_callREST ('get', $url);
-
+
return if $self->error;
# Now parse the results
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
if ($result{entry}{content}{$table}) {
return $self->_parseFields ($table, %{$result{entry}{content}{$table}});
} elsif (ref \%result eq 'HASH') {
# The if test above will create an empty $result{entry}{content}. We need
# to delete that
delete $result{entry};
-
+
return $self->_parseFields ($table, %result);
} else {
return;
my ($self, $table) = @_;
$self->records;
-
+
return $RECORDS{$table};
} # _getRecordID
my ($self, $table, $url, @fields) = @_;
$self->{fields} = [$self->_setFields ($table, @fields)];
-
+
$self->error ($self->_callREST ('get', $url));
-
+
return if $self->error;
-
+
return $self->_parseFields ($table, %{XMLin ($self->{rest}->responseContent)});
} # _getRecordURL
sub _getReferenceList ($$) {
my ($self, $url, $field) = @_;
-
+
$self->error ($self->_callREST ('get', $url));
-
+
return if $self->error;
-
+
my %result = %{XMLin ($self->{rest}->responseContent)};
my @values;
-
+
# Need to find the field array here...
foreach my $key (keys %result) {
if (ref $result{$key} eq 'ARRAY') {
foreach (@{$result{$key}}) {
push @values, $$_{'oslc_cm:label'};
} # foreach
-
+
last;
} elsif (ref $result{$key} eq 'HASH' and $result{$key}{'oslc_cm:label'}) {
push @values, $result{$key}{'oslc_cm:label'};
} # if
} # foreach
-
+
return @values;
} # _getReferenceList
sub _parseCondition ($$) {
my ($self, $table, $condition) = @_;
-
+
# Parse simple conditions only
my ($field, $operator, $value);
return "$field in [$value]"
} # if
} # if
-
+
if ($operator eq '=' and $value =~ /^null$/i) {
return "$field in [\"\"]";
} elsif ($operator eq '!=' and $value =~ /^null$/i) {
return "$field in [*]";
} # if
-
+
# Trim quotes if any:
if ($value =~ /^\s*\'/) {
$value =~ s/^\s*\'//;
$value =~ s/^\s*\"//;
$value =~ s/\"\s*$//;
} # if
-
+
# Trim leading and trailing whitespace
$value =~ s/^\s+//;
$value =~ s/\s+$//;
-
+
# Convert datetimes to Zulu
if ($self->fieldType ($table, $field) == $DATE_TIME and
$value !~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/) {
$value = Clearquest::_UTCTime ($value);
} # if
-
+
return "$field $operator \"$value\"";
} # _parseCondition
my ($self, $table, $condition) = @_;
return 'oslc_cm.query=' unless $condition;
-
+
my $parsedConditional;
-
+
# Special case when the condition is ultra simple
if ($condition !~ /(\w+)\s*(==|=|!=|<>|<|>|<=|>=|in|is\s+null|is\s+not\s+null)\s*(.*)/i) {
return "rcm.name=$condition";
} # if
-
+
# TODO: This section needs improvement to handle more complex conditionals
while () {
if ($condition =~ /(.+?)\s+(and|or)\s+(.+)/i) {
my $leftSide = $self->_parseCondition ($table, $1);
-
+
$parsedConditional .= "$leftSide $2 ";
$condition = $3;
} else {
$parsedConditional .= $self->_parseCondition ($table, $condition);
-
+
last;
} # if
} # while
-
+
# TODO: How would this work if we have a condition like 'f1 = "value" and
# f2 is not null'?
if ($parsedConditional =~ /in \[\*\]/) {
sub _parseFields ($%) {
my ($self, $table, %record) = @_;
-
+
foreach my $field (keys %record) {
if ($field =~ /:/ or
$field eq 'xmlns' or
grep {/^$field$/} @{$self->{fields}} == 0) {
delete $record{$field};
-
+
next;
} # if
-
+
my $fieldType = $self->fieldType ($table, $field);
if (ref $record{$field} eq 'HASH') {
$record{$field} = \@values;
} elsif ($fieldType == $ATTACHMENT_LIST) {
my @attachments = $self->_getAttachmentList ($record{$field}{'oslc_cm:collref'}, $field);
-
+
$record{$field} = \@attachments;
} elsif ($fieldType == $RECORD_TYPE) {
$record{$field} = $record{$field}{'oslc_cm:label'};
$record{$field} = undef;
} # if
} # if
-
+
$record{$field} ||= '' if $self->{emptyStringForUndef};
if ($fieldType == $DATE_TIME) {
$record{$field} = Clearquest::_UTC2Localtime $record{$field};
} # if
} # foreach
-
+
return %record;
} # _parseFields
sub _parseRecordDesc ($) {
my ($self, $table) = @_;
-
+
# Need to get fieldType info
my $recordID = $self->_getRecordID ($table);
-
+
return unless $recordID;
-
+
my $url = "$self->{uri}/record-type/$recordID";
-
+
$self->_callREST ('get', $url);
-
+
return if $self->error;
-
+
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
# Reach in deep for field definitions
my %fields = %{$result{element}{complexType}{choice}{element}};
} else {
$FIELDS{$table}{$_}{FieldType} = $UNKNOWN;
} # if
-
+
if ($fields{$_}{'cq:systemOwned'} and $fields{$_}{'cq:systemOwned'} eq 'true') {
$FIELDS{$table}{$_}{SystemField} = 1;
} else {
$FIELDS{$table}{$_}{SystemField} = 0;
} # if
} # foreach
-
- return;
+
+ return;
} # _parseRecordDesc
sub _isSystemField ($$) {
# Cause %FIELDS to be expanded for $table
$self->_parseRecordDesc ($table);
-
+
unless (@fields) {
foreach ($self->fields ($table)) {
unless ($self->{returnSystemFields}) {
next if $FIELDS{$table}{$_}{SystemField}
} # unless
-
+
push @fields, $_;
} # foreach
} # unless
-
+
push @fields, 'dbid' unless grep { /dbid/ } @fields;
return @fields;
my ($self, $table, $fieldName, $fieldValue) = @_;
return if $self->_isSystemField ($table, $fieldName);
-
+
my $xml .= "<$fieldName>";
-
+
my $fieldType = $self->fieldType ($table, $fieldName);
if ($fieldType == $STRING or
# Fix MULTILINE_STRINGs
if ($fieldType == $MULTILINE_STRING and ref $fieldValue eq 'ARRAY') {
chomp @{$fieldName};
-
+
$fieldValue= join "\n", @$fieldValue;
} # if
-
+
$xml .= escapeHTML $fieldValue;
} elsif ($fieldType == $REFERENCE) {
my $tableReferenced = $self->fieldReference ($table, $fieldName);
-
+
if ($tableReferenced) {
$xml .= $self->_getInternalID ($tableReferenced, $fieldValue);
} else {
$self->error (600);
$self->errmsg ("Could not determine reference for $fieldName");
-
+
return;
} # if
} elsif ($fieldType == $REFERENCE_LIST) {
# We'll allow either an array reference or a single value, which we will
# turn into an array
my @values;
-
+
@values = ref $fieldValue eq 'ARRAY' ? @$fieldValue
: ($fieldValue);
-
+
my $tableReferenced = $self->fieldReference ($table, $fieldName);
-
+
unless ($tableReferenced) {
$self->error (600);
$self->errmsg ("Could not determine reference for $fieldName");
-
+
return;
} # if
-
+
foreach (@values) {
my $internalID = $self->_getInternalID ($tableReferenced, $_);
} else {
$self->error (600);
$self->errmsg ("Could not find a valid/active $tableReferenced with a key of \"$_\"");
-
+
return
} # if
} # foreach
} # if
$xml .= "</$fieldName>\n";
-
+
return $xml;
} # _setFieldValue
sub _startXML ($) {
my ($table) = @_;
-
+
my $xml = << "XML";
<?xml version="1.0" encoding="UTF-8"?>
<$table
xmlns:dc="http://purl.org/dc/terms/"
xmlns:oslc_cm="http://open-services.net/xmlns/cm/1.0/">
XML
-
+
return $xml
} # _startXML
# First process all fields in the @ordering, if specified
$xml .= $self->_setFieldValue ($table, $_, $record{$_}) foreach (@ordering);
-
+
foreach my $field (keys %record) {
next if InArray $field, @ordering;
-
+
$xml .= $self->_setFieldValue ($table, $field, $record{$field});
} # foreach
-
+
$xml .= "</$table>";
-
+
$self->_callREST ('post', $uri, $xml);
# Get the DBID of the newly created record
sub connect (;$$$$) {
my ($self, $username, $password, $database, $dbset) = @_;
-
+
=pod
=head2 connect (;$$$$)
if (ref $username eq 'HASH') {
my %opts = %$username;
-
+
$self->{username} = delete $opts{CQ_USERNAME};
$self->{password} = delete $opts{CQ_PASSWORD};
$self->{database} = delete $opts{CQ_DATABASE};
$self->{database} = $database if $database;
$self->{dbset} = $dbset if $dbset;
} # if
-
+
# Set URI in case anything changed
$self->{uri} = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}";
$self->{loggedin} = 1;
-
+
return 1;
} # connect
sub connected () {
my ($self) = @_;
-
+
=pod
=head2 connected ()
=for html </blockquote>
=cut
-
+
return $self->{loggedin};
} # connected
sub delete ($$) {
my ($self, $table, $key) = @_;
-
+
=pod
=head2 delete ($table, $key)
=cut
my $query = $self->_getInternalID ($table, $key);
-
+
# Need to remove $self->{server} from beginning of $query
$query =~ s/^http.*$self->{server}//;
# global destruction (like when you die or exit), the ordering of destruction
# is unpredictable so we might not succeed.
return unless $self->{rest};
-
+
# Delete session - ignore error as there's really nothing we can do if this
# fails.
$self->_callREST ('delete', '/cqweb/oslc/session/');
-
+
croak "Unable to release REST session in destructor" if $self->error;
-
+
return;
} # DESTROY
=cut
return unless $self->{rest};
-
+
$self->_callREST ('delete', '/cqweb/oslc/session/');
-
+
return $self->error;
} # disconnect
return $self->{errmsg};
} else {
my $response = $self->response;
-
+
if ($response and $response ne '') {
my %xml = %{XMLin ($self->response)};
-
+
if ($xml{Error}{message}) {
$self->{errmsg} = $xml{Error}{message};
} elsif (ref $xml{message} ne 'HASH' and $xml{message}) {
} # if
} # if
} # if
-
+
return $self->{errmsg};
} # errmsg
sub error (;$) {
my ($self, $error) = @_;
-
+
=pod
=head2 error ($error)
=for html </blockquote>
=cut
-
-
+
if (defined $error) {
$self->{responseCode} = $error;
} else {
sub fields ($) {
my ($self, $table) = @_;
-
+
=pod
=head2 fields ($table)
=cut
my $recordID = $self->_getRecordID ($table);
-
+
return unless $recordID;
-
+
my $url = "$self->{uri}/record-type/$recordID";
$self->_callREST ('get', $url);
-
+
return if $self->error;
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
my @fields = keys %{$result{element}{complexType}{choice}{element}};
-
+
return @fields;
} # fields
=for html </blockquote>
=cut
-
+
# If we've already computed the fieldTypes for the fields in this table then
# return the value
if ($FIELDS{$table}) {
sub find ($;$@) {
my ($self, $table, $condition, @fields) = @_;
-
+
=pod
=head2 find ($;$@)
$self->{url} = "$self->{uri}/record/?rcm.type=$table&"
. $self->_parseConditional ($table, $condition);
-
+
@fields = $self->_setFields ($table, @fields);
-
+
# Remove dbid for find
@fields = grep { $_ ne 'dbid' } @fields;
-
+
if (@fields) {
$self->{url} .= "&oslc_cm.properties=";
$self->{url} .= join ',', @fields;
} # if
-
+
# Save some fields for getNext
$self->{fields} = \@fields;
$self->{table} = $table;
-
+
$self->{url} .= "&oslc_cm.pageSize=1";
-
+
return $self->{url} unless wantarray;
-
+
# If the user wants an array then he wants ($reesult, $nbrRecs) and so we need
# to go out and get that info.
$self->_callREST ('get', $self->{url});
-
+
return (undef, 0) if $self->error;
# Now parse the results
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
return ($self->{url}, $result{'oslc_cm:totalCount'}{content});
} # find
sub getDBID ($$;@) {
my ($self, $table, $dbid, @fields) = @_;
-
+
=pod
=head2 get ($table, $key, @fields)
$url .= $self->_getRecordID ($table);
$url .= '-';
$url .= $dbid;
-
+
if (@fields) {
$url .= "?oslc_cm.properties=";
$url .= 'dbid,' unless grep { /dbid/i } @fields;
$url .= join ',', @fields;
} # if
-
+
return $self->_getRecord ($table, $url);
} # getDBID
sub getNext ($) {
my ($self, $result) = @_;
-
+
=pod
=head2 getNext ($)
=for html </blockquote>
=cut
-
+
return unless $self->{url};
-
+
my $url = $self->{url};
$self->_callREST ('get', $url);
-
+
return if $self->error;
# Now parse the results
my %result = %{XMLin ($self->{rest}->responseContent)};
-
+
# Get the next link
undef $self->{url};
-
+
if (ref $result{link} eq 'ARRAY') {
foreach (@{$result{link}}) {
if ($$_{rel} eq 'next') {
($self->{url}) = ($$_{href} =~ /^http.*$self->{server}(.*)/);
-
+
last;
} # if
} # foreach
} # if
-
+
my %record;
-
+
if (ref $result{entry}{content}{$self->{table}} eq 'HASH') {
%record = $self->_parseFields ($self->{table}, %{$result{entry}{content}{$self->{table}}});
} elsif (ref $result{entry} eq 'HASH') {
%record = $self->_getRecordURL ($self->{table}, $result{entry}{id}, @{$self->{fields}});
} # if
} # if
-
+
# Get dbid
if ($result{entry}{link}{href} =~ /-(\d+)$/) {
$record{dbid} = $1;
} # if
-
+
return %record;
} # getNext
sub key ($$) {
my ($self, $table, $dbid) = @_;
-
+
=pod
=head2 key ($$)
sub modify ($$$$;@) {
my ($self, $table, $key, $action, $values, @ordering) = @_;
-
+
=pod
=head2 modify ($table, $key, $action, $values, @ordering)
my %values = %$values;
my $xml = _startXML $table;
-
+
$action ||= 'Modify';
-
+
my $query = $self->_getInternalID ($table, $key);
-
+
# Remove host portion
$query =~ s/^http.*$self->{server}//;
-
+
# Add on action
$query .= "?rcm.action=$action";
-
+
# First process all fields in the @ordering, if specified
$xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
-
+
foreach my $field (keys %values) {
next if InArray $field, @ordering;
-
+
$xml .= $self->_setFieldValue ($table, $field, $values{$field});
} # foreach
-
+
$xml .= "</$table>";
$self->_callREST ('put', $query, $xml);
-
+
return $self->errmsg;
} # modify
sub modifyDBID ($$$$;@) {
my ($self, $table, $dbid, $action, $values, @ordering) = @_;
-
+
=pod
=head2 modifyDBID ($table, $dbid, $action, %update)
my %values = %$values;
my $xml = _startXML $table;
-
+
$action ||= 'Modify';
-
+
my $query = "$self->{uri}/record/";
$query .= $self->_getRecordID ($table);
$query .= '-';
$query .= $dbid;
-
+
# Add on action
$query .= "?rcm.action=$action";
-
+
# First process all fields in the @ordering, if specified
$xml .= $self->_setFieldValue ($table, $_, $values{$_}) foreach (@ordering);
-
+
foreach my $field (keys %values) {
next if InArray $field, @ordering;
-
+
$xml .= $self->_setFieldValue ($table, $field, $values{$field});
} # foreach
-
+
$xml .= "</$table>";
$self->_callREST ('put', $query, $xml);
-
+
return $self->errmsg;
} # modifyDBID
sub new (;%) {
my ($class, $self) = @_;
-
+
=pod
=head2 new (%parms)
=cut
$self->{server} ||= $Clearquest::OPTS{CQ_SERVER};
-
+
$$self{base_url} = "$self->{server}/cqweb/oslc",
$$self{uri} = "/cqweb/oslc/repo/$self->{dbset}/db/$self->{database}",
$$self{login} = {
Authorization => 'Basic '
. encode_base64 "$self->{username}:$self->{password}",
};
-
+
bless $self, $class;
-
+
# We create this UserAgent and Cookie Jar so we can set cookies to be
# remembered and passed back and forth automatically. By doing this we re-use
# the JSESSIONID cookie we allows us to reuse our login and to dispose of the
# login session properly when we are destroyed.
my $userAgent = LWP::UserAgent->new;
-
+
# Set the cookie jar to use in-memory cookie management, cookies can be
# persisted to disk, see HTTP::Cookies for more info.
$userAgent->cookie_jar (HTTP::Cookies->new);
-
+
$self->{rest} = REST::Client->new (
host => $self->{server},
timeout => 15,
sub records () {
my ($self) = @_;
-
+
=pod
=head2 records ()
=cut
return if %RECORDS;
-
+
my $url = "$self->{uri}/record-type/";
$self->_callREST ('get', $url);
-
+
unless ($self->error) {
my %result = %{XMLin ($self->{rest}->responseContent)};
foreach my $uri (keys %{$result{entry}}) {
my ($recordID) = ($uri =~ /\/(\d+)/);
-
+
$RECORDS{$result{entry}{$uri}{title}} = $recordID;
} # foreach
} # unless
-
+
return %RECORDS;
} # records
sub response () {
my ($self) = @_;
-
+
=pod
=head2 response ()
projects / clearscm.git / blobdiff