[MOBY-guts] biomoby commit
Mark Wilkinson
mwilkinson at pub.open-bio.org
Wed Aug 17 19:30:19 UTC 2005
mwilkinson
Wed Aug 17 15:30:18 EDT 2005
Update of /home/repository/moby/moby-live/Perl/MOBY
In directory pub.open-bio.org:/tmp/cvs-serv13880/MOBY
Modified Files:
Central.pm OntologyServer.pm
Log Message:
this code attempts to traverse a newly created object to ensure that no articleNames appear at the same level of XML in the final object. It is curently untested so caveat emptor
moby-live/Perl/MOBY Central.pm,1.202,1.203 OntologyServer.pm,1.72,1.73
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/Central.pm,v
retrieving revision 1.202
retrieving revision 1.203
diff -u -r1.202 -r1.203
--- /home/repository/moby/moby-live/Perl/MOBY/Central.pm 2005/08/17 17:58:13 1.202
+++ /home/repository/moby/moby-live/Perl/MOBY/Central.pm 2005/08/17 19:30:18 1.203
@@ -273,8 +273,7 @@
unless ( defined $term && defined $desc && defined $auth && defined $email )
{
if ( $term =~ /FAILED/ ) { return &_error( "Malformed XML;", "" ); }
- return &_error(
-"Malformed XML; may be missing required parameters objectType, Description, authURI or contactEmail",
+ return &_error("Malformed XML; may be missing required parameters objectType, Description, authURI or contactEmail",
""
);
}
@@ -282,13 +281,11 @@
if $auth =~ '[/:]';
return &_error( "Malformed authURI - must take the form NNN.NNN.NNN", "" )
unless $auth =~ /\./;
- return &_error(
-"Malformed email - must be a valid email address of the form name\@organization.foo",
+ return &_error("Malformed email - must be a valid email address of the form name\@organization.foo",
""
)
unless $email =~ /\S\@\S+\.\S+/;
- return &_error(
-"Object name may not contain spaces or other characters invalid in a URN",
+ return &_error("Object name may not contain spaces or other characters invalid in a URN",
""
)
if $term =~ /\s\"\&\<\>\[\]\^\`\{\|\}\~/;
@@ -367,6 +364,7 @@
);
($success == 0) && return &_error( $message, $URI );
my @failures;
+ my $messages = "";
if ( keys %{$relationships} ) {
while ( my ( $reltype, $obj ) = each %{$relationships} ) {
foreach ( @{$obj} ) {
@@ -380,7 +378,10 @@
authority => $auth,
contact_email => $email
);
- ($success == 0) && push @failures, $objectType;
+ unless ($success){
+ push @failures, $objectType;
+ $messages .= $message."; ";
+ }
}
}
}
@@ -393,8 +394,7 @@
and subsequently failed deletion. This is a critical error,
and may indicate corruption of the MOBY Central registry.", $deleteURI
);
- return &_error(
-"object failed to register due to unexplained failure during registration of ISA/HASA relationships"
+ return &_error("object failed to register due to failure during registration of ISA/HASA relationships. Message returned was $messages"
. ( join ",", (@failures) ) . "\n",
""
);
@@ -2927,10 +2927,12 @@
if ( keys %reltypes ) {
next unless $reltypes{ $rellsid}; # next unless it is one ofthe relationship types we requested
}
- my $lsids = $rels{$rellsid};
- next unless $lsids->[0];
+ next unless $rels{$rellsid};
+ my @lsids_articles = @{$rels{$rellsid}};
+ next unless scalar @lsids_articles;
$response .= "<Relationship relationshipType='$_' lsid='$rellsid'>\n";
- foreach my $lsid ( @{$lsids} ) {
+ foreach my $lsid_article ( @lsids_articles ) {
+ my ($lsid, $articleName) = @$lsid_article;
# ugh... I have to cheat here because the term is not returned from the Ontology Server
# one day we may have to fix this...
$lsid =~ /urn\:lsid\:[^\:]+\:[^\:]+\:([^\:]+)/; # get the term portion of the LSID
===================================================================
RCS file: /home/repository/moby/moby-live/Perl/MOBY/OntologyServer.pm,v
retrieving revision 1.72
retrieving revision 1.73
diff -u -r1.72 -r1.73
--- /home/repository/moby/moby-live/Perl/MOBY/OntologyServer.pm 2005/08/02 15:18:00 1.72
+++ /home/repository/moby/moby-live/Perl/MOBY/OntologyServer.pm 2005/08/17 19:30:18 1.73
@@ -457,7 +457,6 @@
return ( 0, "WRONG ONTOLOGY!", '' ) unless ( $self->ontology eq 'object' );
-# my ( $subj_id, $subj_lsid, $obj_id, $obj_lsid );
my $result = $adaptor->query_object(type => $args{subject_node});
my $row = shift(@$result);
my $subj_lsid = $row->{object_lsid};
@@ -480,16 +479,23 @@
}
my $OE = MOBY::OntologyServer->new( ontology => 'relationship' );
my ( $success, $desc, $rel_lsid ) = $OE->relationshipExists(
- term => $args{relationship},
- ontology => 'object' );
- ($success)
- || return ( 0,
+ term => $args{relationship},
+ ontology => 'object' );
+ ($success) || return ( 0,
qq{Relationship $args{relationship} does not exist in the ontology},
'' );
+
+ unless ($rel_lsid =~ /urn\:lsid\:biomoby\.org\:objectrelation\:isa/){
+ my $articleNameInvalid = &_testIdenticalArticleName(term => $subj_lsid, articleName => $args{articleName});
+ return (0, "Object will have conflicting articleName", '') if $articleNameInvalid;
+ }
+
my $insertid = $adaptor->insert_object_term2term(relationship_type => $rel_lsid,
object1_type => $subj_lsid,
object2_type => $obj_lsid,
object2_articlename => $args{articleName});
+
+
if ($insertid ) {
return ( 1, "Object relationsihp created successfully", '' );
} else {
@@ -498,6 +504,54 @@
}
}
+sub _testIdenticalArticleName {
+ my (%args)= @_;
+ my $term = $args{term};
+ my $articleName = $args{articleName};
+ my $foundCommonArticleNameFlag = 0;
+ # need to first traverse down the ISA pathway to root
+ # then for each ISA test the hAS and HASA's for their articlenames and see if they are the same
+ # case insensitive?
+ my $OS = MOBY::OntologyServer->new(ontology => 'relationship');
+ my $relationships = $OS->Relationships(
+ ontology => 'object',
+ term => $args{term},
+ relationship => 'isa',
+ direction => 'root',
+ expand => 1);
+ #relationships{relationship} = [[lsid1,articleNmae], [lsid2, articleName], [lsid3, articleName]]
+ my ($isa) = keys(%$relationships); # can only be one key returned, and must be isa in this case
+ my @ISAlist = @{$relationships->{$isa}};
+ foreach my $ISA(@ISAlist){ # $ISA = [lsid, articleName] (but articleName shuld be null anyway in this case)
+ my $what_it_is = shift @$ISA;
+ my $hasarelationships = $OS->Relationships(
+ ontology => 'object',
+ term => $what_it_is,
+ relationship => 'hasa',
+ direction => 'root',
+ );
+ #$hasarelationships{relationship} = [[lsid1,articleNmae], [lsid2, articleName], [lsid3, articleName]]
+ my ($hasa) = keys(%$hasarelationships);
+ my @HASAlist = @{$hasarelationships->{$hasa}};
+ foreach my $HASA(@HASAlist){
+ $foundCommonArticleNameFlag = 1 if ($HASA->[1] eq $articleName);
+ }
+ my $hasrelationships = $OS->Relationships(
+ ontology => 'object',
+ term => $what_it_is,
+ relationship => 'has',
+ direction => 'root',
+ );
+ #$hasrelationships{relationship} = [[lsid1,articleNmae], [lsid2, articleName], [lsid3, articleName]]
+ my ($has) = keys(%$hasrelationships);
+ my @HASlist = @{$hasrelationships->{$hasa}};
+ foreach my $HAS(@HASlist){
+ $foundCommonArticleNameFlag = 1 if ($HAS->[1] eq $articleName);
+ }
+ }
+ return $foundCommonArticleNameFlag;
+}
+
=head2 addServiceRelationship
=cut
@@ -1065,18 +1119,21 @@
return {[]} unless $defs; # somethig has gone terribly wrong!
my $lsid;
my $rel;
+ my $articleName;
foreach ( @{$defs} ) {
$lsid = $_->[0];
$rel = $_->[1];
+ $articleName = $_->[2];
+ $articleName ||="";
$debug
&& _LOG("\t\tADDING RELATIONSHIP $_ : $lsid to $rel\n");
- push @{ $results{$rel} }, $lsid;
+ push @{ $results{$rel} }, [$lsid, $articleName];
}
last unless ($expand);
last unless ( $direction eq "root" ); # if we aren't going to root, then be careful or we'll loop infnitely
$term = $lsid; # this entire subroutine assumes that there is NOT multiple parenting...
}
- return \%results; #results(relationship} = [lsid1, lsid2, lsid3]
+ return \%results; #results(relationship} = [[lsid1,articleNmae], [lsid2, articleName], [lsid3, articleName]]
}
sub _doRelationshipsQuery {
@@ -1157,9 +1214,9 @@
if ( $IDS{$termthingy} eq "tested" )
; # if it has been tested already then move on
my $lsids = $self->Relationships(
- term => $termthingy,
- relationship => $relationship,
- direction => $direction
+ term => $termthingy,
+ relationship => $relationship,
+ direction => $direction
)
; # get the related terms for this type; this should return a single hash value
if ( $IDS{$termthingy} =~ /root/ )
@@ -1173,8 +1230,9 @@
}
#${$lsids}{relationshiptype}=[lsid, lsid, lsid];
- foreach my $lsid ( @{ $lsids->{$relationship} } )
+ foreach my $lsid_article ( @{ $lsids->{$relationship} } )
{ # go through the related terms
+ my ($lsid, $article) = @{$lsid_article};
$debug && _LOG("found $lsid as relationship");
next
if ( defined $IDS{$lsid} )
More information about the MOBY-guts
mailing list