Bio-MAGE-Utils-20030502.0/0000755000175000017500000000000010622036172013776 5ustar jasonsjasonsBio-MAGE-Utils-20030502.0/MAGE/0000755000175000017500000000000010622036172014507 5ustar jasonsjasonsBio-MAGE-Utils-20030502.0/MAGE/Tools/0000755000175000017500000000000010622036172015607 5ustar jasonsjasonsBio-MAGE-Utils-20030502.0/MAGE/Tools/MGEDOntologyPropertyEntry.pm0000644000175000017500000002263410472774470023227 0ustar jasonsjasons############################## # # Bio::MAGE::Tools::MGEDOntologyPropertyEntry # ############################## # C O P Y R I G H T N O T I C E # Copyright (c) 2001-2002 by: # * The MicroArray Gene Expression Database Society (MGED) # * Rosetta Inpharmatics # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this software and associated documentation files # (the "Software"), to deal in the Software without restriction, # including without limitation the rights to use, copy, modify, merge, # publish, distribute, sublicense, and/or sell copies of the Software, # and to permit persons to whom the Software is furnished to do so, # subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS # BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN # ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN # CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE # SOFTWARE. package Bio::MAGE::Tools::MGEDOntologyPropertyEntry; use strict; use Carp; use Bio::MAGE::Base; use Bio::MAGE::Association; use Bio::MAGE::Extendable; use vars qw($VERSION $DEBUG); # Inherit methods from superclass use base qw(Bio::MAGE::Tools::MGEDOntologyEntry); $VERSION = 2006_08_16.1; =head1 Bio::MAGE::Tools::MGEDOntologyPropertyEntry =head2 SYNOPSIS Bio::MAGE::Tools::MGEDOntologyPropertyEntry is a concrete class. Superclass is: Bio::MAGE::Tools::MGEDOntologyEntry Subclasses are: none =head2 DESCRIPTION This provides functionaliy for an ontology-aware OntologyEntry class for entries of type Property. =cut $DEBUG = 0; ############################################################################### # # Constructor # ############################################################################### sub new { my $class = shift; if (ref($class)) { $class = ref($class); } my $self = bless {}, $class; my %args = @_; #### Create this entry and all possible children $self->createEntry(%args); return $self; } ############################################################################### # # Getter and Setter methods for class attributes # ############################################################################### =head2 ATTRIBUTES Attributes are simple data types that belong to a single instance of a class. In the Perl implementation of the MAGE-OM classes, the interface to attributes is implemented using separate setter and getter methods for each attribute. =over =item propertyType Store the type of the property =cut ############################################################################### # setPropertyType ############################################################################### sub setPropertyType { my $self = shift; my $attributeName = 'propertyType'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getPropertyType ############################################################################### sub getPropertyType { my $self = shift; my $attributeName = 'propertyType'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } =item mgedOntologyProperty Stores the name of the equivalent class or property in the MGED Ontology for this OntologyEntry =cut ############################################################################### # setMgedOntologyProperty ############################################################################### sub setMgedOntologyProperty { my $self = shift; my $attributeName = 'mgedOntologyProperty'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getMgedOntologyProperty ############################################################################### sub getMgedOntologyProperty { my $self = shift; my $attributeName = 'mgedOntologyProperty'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } ############################################################################### # # Regular methods # ############################################################################### ############################################################################### # createEntry ############################################################################### sub createEntry { my $self = shift || die ("self not passed"); my %args = @_; my $propertyName = $args{'propertyName'} || die "ERROR: propertyName not passed"; my $propertyType = $args{'propertyType'} || die "ERROR: propertyType not passed"; my $values = $args{'values'} || die("ERROR: values not passed"); my $usedValues = $args{'usedValues'}; my $ontology = $args{'ontology'} || die "ERROR: ontology not passed"; #### Store the parameters in the class attributes $self->setMgedOntologyProperty($propertyName); $self->setPropertyType($propertyType); $DEBUG && print STDERR "DEBUG: Entering [MGEDOntologyPropertyEntry] $propertyName,$propertyType\n"; if ($ontology->classExists($propertyType)) { ## Filler is a MGED Ontology Class #print " This is a class\n"; $self->setIsAssignable(0); $self->setCategory($self->getMgedOntologyProperty()); $self->setValue($self->getMgedOntologyProperty()); $self->setOntologyReference($ontology->getOntologyReference($self->getMgedOntologyProperty())); #$self->addToAssociations(new MGEDOntologyClassEntry($propertyType,$ontology)); $DEBUG && print STDERR " Create new ClassEntry of name $propertyType\n"; my $childObject = Bio::MAGE::Tools::MGEDOntologyClassEntry->new( className => $propertyType, values => $values, usedValues => $usedValues, ontology => $ontology, ); $self->addAssociations($childObject); $DEBUG && print STDERR " Add to parent\n"; } elsif ($propertyType eq "enum") { ## Filler is of the type one-of $self->setIsAssignable(1); $self->setCategory($self->getMgedOntologyProperty()); ## need to be able to store possible choises my @assignableValues = $ontology->getEnumValues($self->getMgedOntologyProperty()); $self->setAssignableValues(\@assignableValues); #### Create all the structure below this using $ontology $self->setOntologyReference($ontology->getOntologyReference("placeholder")); } elsif ($propertyType eq "any" || $propertyType eq "?") { ## Filler is thing, int etc. $self->setIsAssignable(0); ## adjust method names to prevailing style in class (jaw) #$self->set_category($self->getMgedOntologyProperty()); #$self->set_value($self->getMgedOntologyProperty()); $self->setCategory($self->getMgedOntologyProperty()); # FIXME presumably we need to deal with potential subclasses here as well (string values only at the moment)... $self->setValue($values->{$propertyName}); # $self->setOntologyReference($ontology->getOntologyReference($self->getMgedOntologyProperty())); # $self->addToAssociations(Bio::MAGE::Tools::MGEDOntologyPropertyEntry($self->getMgedOntologyProperty(), "thingFiller", # $ontology)); } elsif ($propertyType eq "thingFiller") { ## Thing filler $self->setIsAssignable(1); ## Fix java style setter.(jaw) $self->setCategory($self->getMgedOntologyProperty()); ## Add missing call to set_value (jaw) $self->setValue($self->getMgedOntologyProperty()); ## No MO reference } return 1; } ############################################################################### # assignValue ############################################################################### sub assignValue { my $self = shift || die ("self not passed"); my $val = shift; if ($self->getIsAssignable && !$self->getIsAssigned) { if ($self->getPropertyType() eq "enum" && grep(/^$val$/,@{$self->getAssignableValues()})) { $self->setValue($val); ## Correct the temporary MO DB reference my $ontologyReference = $self->getOntologyReference(); $ontologyReference->setAccession("#$val"); my $URI = $ontologyReference->getURI(); $URI =~ s/placeholder/$val/; $ontologyReference->setURI($URI); } elsif ($self->getPropertyType() eq "thingFiller") { $self->setValue($val); } $self->setIsAssigned(1); } } =head1 BUGS Please send bug reports to mged-mage@lists.sf.net =head1 AUTHOR Eric W. Deutsch (edeutsch@systemsbiology.org) =head1 SEE ALSO perl(1). =cut # # End the module by returning a true value # 1; Bio-MAGE-Utils-20030502.0/MAGE/Tools/MGEDOntologyEntry.pm0000644000175000017500000001760510472774470021464 0ustar jasonsjasons############################## # # Bio::MAGE::Tools::MGEDOntologyEntry # ############################## # C O P Y R I G H T N O T I C E # Copyright (c) 2001-2002 by: # * The MicroArray Gene Expression Database Society (MGED) # * Rosetta Inpharmatics # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this software and associated documentation files # (the "Software"), to deal in the Software without restriction, # including without limitation the rights to use, copy, modify, merge, # publish, distribute, sublicense, and/or sell copies of the Software, # and to permit persons to whom the Software is furnished to do so, # subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS # BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN # ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN # CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE # SOFTWARE. package Bio::MAGE::Tools::MGEDOntologyEntry; use strict; use Carp; use vars qw($VERSION); use base qw(Bio::MAGE::Description::OntologyEntry); $VERSION = 2006_08_16.0; =head1 Bio::MAGE::Tools::MGEDOntologyEntry =head2 SYNOPSIS Bio::MAGE::Tools::MGEDOntologyEntry is an abstract class. Superclass is: Bio::MAGE::Tools::OntologyEntry Subclasses are: Bio::MAGE::Tools::MGEDOntologyClassEntry Bio::MAGE::Tools::MGEDOntologyPropertyEntry =head2 DESCRIPTION This is an abstract class for MGEDOntologyClassEntry and MGEDOntologyPropertyEntry with very little mind of its own. =cut ############################################################################### # # Constructor # ############################################################################### # Constructor is inherited from Base.pm ############################################################################### # # Getter and Setter methods for class attributes # ############################################################################### =head2 ATTRIBUTES Attributes are simple data types that belong to a single instance of a class. In the Perl implementation of the MAGE-OM classes, the interface to attributes is implemented using separate setter and getter methods for each attribute. =over =item isAssignable Stores whether the represented MGED Ontology concept needs to get a value assigned before use or not. (static feature) =cut ############################################################################### # setIsAssignable ############################################################################### sub setIsAssignable { my $self = shift; my $attributeName = 'isAssignable'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getIsAssignable ############################################################################### sub getIsAssignable { my $self = shift; my $attributeName = 'isAssignable'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } =item isAssigned Stores whether an assignable concept has been assigned a value or not (dynamic feature) =cut ############################################################################### # setIsAssigned ############################################################################### sub setIsAssigned { my $self = shift; my $attributeName = 'isAssigned'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getIsAssigned ############################################################################### sub getIsAssigned { my $self = shift; my $attributeName = 'isAssigned'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } =item errorMessage Stores a possible error message that arose while trying to set the category or more likely value attributes of this class. =cut ############################################################################### # setErrorMessage ############################################################################### sub setErrorMessage { my $self = shift; my $attributeName = 'errorMessage'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getErrorMessage ############################################################################### sub getErrorMessage { my $self = shift; my $attributeName = 'errorMessage'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } =item assignableValues Stores the list of values that can be assigned to this category =cut ############################################################################### # SetAssignableValues ############################################################################### sub setAssignableValues { my $self = shift; my $attributeName = 'assignableValues'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getAssignableValues ############################################################################### sub getAssignableValues { my $self = shift; my $attributeName = 'assignableValues'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } ############################################################################### # # Methods that should be in overridden in subclasses # ############################################################################### ############################################################################### # assignValue ############################################################################### sub assignValue { die("ERROR: Method assignValue must be overridden in subclass"); } ############################################################################### # # Regular methods # ############################################################################### ############################################################################### =head1 BUGS Please send bug reports to mged-mage@lists.sf.net =head1 AUTHOR Eric W. Deutsch (edeutsch@systemsbiology.org) =head1 SEE ALSO perl(1). =cut # # End the module by returning a true value # 1; Bio-MAGE-Utils-20030502.0/MAGE/Tools/MGEDOntologyClassEntry.pm0000644000175000017500000004733510472774470022455 0ustar jasonsjasons############################## # # Bio::MAGE::Tools::MGEDOntologyClassEntry # ############################## # C O P Y R I G H T N O T I C E # Copyright (c) 2001-2002 by: # * The MicroArray Gene Expression Database Society (MGED) # * Rosetta Inpharmatics # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this software and associated documentation files # (the "Software"), to deal in the Software without restriction, # including without limitation the rights to use, copy, modify, merge, # publish, distribute, sublicense, and/or sell copies of the Software, # and to permit persons to whom the Software is furnished to do so, # subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS # BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN # ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN # CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE # SOFTWARE. package Bio::MAGE::Tools::MGEDOntologyClassEntry; use strict; use Carp; use vars qw($VERSION $DEBUG); # Inherit methods from superclass use base qw(Bio::MAGE::Tools::MGEDOntologyEntry); $VERSION = 2006_08_16.1; =head1 Bio::MAGE::Tools::MGEDOntologyClassEntry =head2 SYNOPSIS use Bio::MAGE::Tools::MGEDOntologyClassEntry; use Bio::MAGE::Tools::MGEDOntologyHelper; use Bio::MAGE::QuantitationType::MeasuredSignal; my $mo_helper = Bio::MAGE::Tools::MGEDOntologyHelper->new( sourceFile => 'MGEDOntology.owl', ); my $qt = Bio::MAGE::QuantitationType::MeasuredSignal->new( identifier => 'QT1', isBackground => 'false', ); my $ont_entry = Bio::MAGE::Tools::MGEDOntologyClassEntry->new( parentObject => $qt, className => 'QuantitationType', association => 'DataType', values => { DataType => 'float', }, ontology => $mo_helper, ); =head2 DESCRIPTION This provides functionaliy for an ontology-aware OntologyEntry class for entries of type Class. Bio::MAGE::Tools::MGEDOntologyClassEntry is a concrete class. Superclass is: Bio::MAGE::Tools::MGEDOntologyEntry Subclasses are: none =cut $DEBUG = 0; ############################################################################### # # Constructor # ############################################################################### sub new { my $class = shift; if (ref($class)) { $class = ref($class); } my $self = bless {}, $class; my %args = @_; #### Manually define some recursive entries in the ontology. This should #### be moved to the MGEDOntologyHelper class $self->initializeRecursivePropertyMap unless ($self->getRecursivePropertyMap); #### Create this entry and all possible children $self->createEntry(%args); return $self; } ############################################################################### # # Getter and Setter methods for class attributes # ############################################################################### =head2 ATTRIBUTES Attributes are simple data types that belong to a single instance of a class. In the Perl implementation of the MAGE-OM classes, the interface to attributes is implemented using separate setter and getter methods for each attribute. =over =item mgedOntologyClass Stores the name of the equivalent class or property in the MGED Ontology for this OntologyEntry =cut ############################################################################### # setMgedOntologyClass ############################################################################### sub setMgedOntologyClass { my $self = shift; my $attributeName = 'mgedOntologyClass'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getMgedOntologyClass ############################################################################### sub getMgedOntologyClass { my $self = shift; my $attributeName = 'mgedOntologyClass'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } =item isInstantiable Stores true if the class is an instantiable one. =cut ############################################################################### # setIsInstantiable ############################################################################### sub setIsInstantiable { my $self = shift; my $attributeName = 'isInstantiable'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getIsInstantiable ############################################################################### sub getIsInstantiable { my $self = shift; my $attributeName = 'isInstantiable'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } =item isInstantiable Contains a hash reference to a list of OM clases that are circular references which should only be followed one level. =cut ############################################################################### # setRecursivePropertyMap ############################################################################### sub setRecursivePropertyMap { my $self = shift; my $attributeName = 'recursivePropertyMap'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getRecursivePropertyMap ############################################################################### sub getRecursivePropertyMap { my $self = shift; my $attributeName = 'recursivePropertyMap'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; return $self->{"__$attributeName"}; } ############################################################################### # initializeRecursivePropertyMap ############################################################################### sub initializeRecursivePropertyMap { my $self = shift; my %recursivePropertyMap = ( "has_parent_organization" => "Organization", "has_software" => "Software", "has_hardware" => "Hardware", ); $self->setRecursivePropertyMap(\%recursivePropertyMap); return 1; } ############################################################################### # # Regular methods # ############################################################################### ############################################################################### # createEntry ############################################################################### sub createEntry { my $self = shift || die ("self not passed"); my %args = @_; my $className = $args{'className'} || die "ERROR: className not passed"; my $ontology = $args{'ontology'} || die "ERROR: ontology not passed"; my $parentObject = $args{'parentObject'}; my $association = $args{'association'}; my $values = $args{'values'} || die("ERROR: values not passed"); my $usedValues = $args{'usedValues'}; unless (defined($usedValues)) { $usedValues = {}; } #### Set class variable $self->setMgedOntologyClass($className); #### But if there was a parentObject supplied, then the mgedOntologyClass #### should be the association name #### FIXME This needs to be far more complex. First the translation #### from Characteristics needs to be converted to BioMaterialCharacterics #### And we should probably be checking if $className is a MAGE class #### instead of looking for $parentObject if (defined($parentObject) && $parentObject->class_name() ne 'Bio::MAGE::Description::OntologyEntry') { $DEBUG && print STDERR ("Checking Association: $association\n"); if ($ontology->classExists($association)) { $self->setMgedOntologyClass($association); } else { my $test = "$className$association"; $DEBUG && print STDERR ("Checking: $test\n"); if ($ontology->classExists($test)) { $self->setMgedOntologyClass($test); } else { my @superclasses = $parentObject->get_superclasses(); my $found = 0; foreach my $superclass (@superclasses) { $superclass =~ s/^.+:://; $test = "$superclass$association"; $DEBUG && print STDERR ("Checking: $test\n"); if ($ontology->classExists($test)) { $self->setMgedOntologyClass($test); $found = 1; last; } } unless ($found) { die("ERROR: Unable to determine MO class name from class $className with association $association"); } } } } #### If the passed class is defined and exists in the ontology if (defined($self->getMgedOntologyClass()) && $ontology->classExists($className)) { ## Check for Policy 2 : Instantiable MGED Ontology Class if ($ontology->isInstantiable($self->getMgedOntologyClass())) { $DEBUG && print STDERR "--- MGEDOntologyClassEntry working on instantiable ".$self->getMgedOntologyClass."\n"; #### Set the attributes for this case $self->setIsInstantiable(1); $self->setIsAssignable(1); ## Set category to MGED Ontology Class $self->setCategory($self->getMgedOntologyClass()); ## Get list of possible instances my @assignableValues = $ontology->getInstances($self->getMgedOntologyClass()); $self->setAssignableValues(\@assignableValues); # $DEBUG && print STDERR " assignableValues=".join(",",@assignableValues)."\n";; #### See if the user has provided a value for this class my $value; if ($self->getIsAssigned()) { $value = $self->getValue(); } else { $self->setIsAssigned(0); $value = $ontology->getUserSpecifiedValue( className => $self->getMgedOntologyClass(), values => $values, usedValues => $usedValues, ); } #### Check to see whether this is a valid selection if (defined($value)) { $DEBUG && print STDERR "+++ Creating instantiable ".$self->getMgedOntologyClass." => $value\n"; if (grep(/^$value$/,@assignableValues)) { $self->setIsAssigned(1); $self->setOntologyReference($ontology->getOntologyReference($value)); #### Else, this is an invalid entry } else { carp ("Warning: Tried to set $className=$value, but the only allowed values are (".join(",",@assignableValues).")"); } # FIXME the usedValues tracking mechanism probably should be fixed and reinstated at some point # $value = $ontology->retireUserSpecifiedValue( # className => $self->getMgedOntologyClass(), # values => $values, # usedValues => $usedValues, # ); } #### Set the MO structure for this Ontologyentry $self->setValue($value); } ## Policy 3 : Abstract MGED Ontology Class else { $DEBUG && print STDERR "--- MGEDOntologyClassEntry working on abstract ".$self->getMgedOntologyClass."\n"; $self->setIsInstantiable(0); ## Set category and value to the MGED Ontology Class $self->setCategory($self->getMgedOntologyClass()); #### See if the user has provided a value for this class my $value = $ontology->getUserSpecifiedValue( className => $className, values => $values, usedValues => $usedValues, ontology => $ontology, ); # If there's a value, use it; otherwise use the className $self->setValue($value || $self->getMgedOntologyClass()); ## Add MO DB reference $self->setOntologyReference( $ontology->getOntologyReference($self->getValue())); ## Check if a sub class should be assigned my @subclasses = $ontology->getSubclasses($self->getMgedOntologyClass()); if (scalar(@subclasses) == 0) { $self->setIsAssignable(0); } else { $self->setIsAssignable(1); $self->setAssignableValues( [] ); #### Loop through the subclasses to see if the user specified one of them my $selectedSubclass; foreach my $subclass (@subclasses) { #### See if the user has provided a value for this class my $value = $ontology->getUserSpecifiedValue( className => $subclass, values => $values, usedValues => $usedValues, ontology => $ontology, ); #### The the user did mention this class if ($value) { $DEBUG && print STDERR "+++ Creating abstract ".$self->getMgedOntologyClass." => $value\n"; if ($selectedSubclass) { die("ERROR: More that one subclass of ".$self->getMgedOntologyClass(). " specified. This is not permitted. A separate association is required."); } else { $selectedSubclass = $subclass; } } } ## Create subclass OE's and store before assigned. my $nAssignedSubclasses = 0; #### If this is the class that the user specified, then assign it if (defined($selectedSubclass)) { #print STDERR "Setting $subclass as assigned...\n"; my $childClass = Bio::MAGE::Tools::MGEDOntologyClassEntry->new( className => $selectedSubclass, values => $values, usedValues => $usedValues, ontology => $ontology, ); $childClass->setIsAssigned(1); $nAssignedSubclasses++ if ($childClass->getIsAssigned()); #print "New $subclass isAssigned: ".($childClass->getIsAssigned() || '')."\n"; push(@{$self->getAssignableValues()},$childClass); } ## If only one was assigned if ($nAssignedSubclasses == 1) { foreach my $childClass ( @{$self->getAssignableValues()}) { if ($childClass->getIsAssigned()) { $self->addAssociations($childClass); } } } # end if $nAssignedSubclasses == 1 } # end else } # end Policy 3 #### If we know our parent object and association, associate with the parent if (defined($parentObject) && defined($association)) { my %associations = $parentObject->associations(); #print "assoc = $association\n"; #print Data::Dumper->Dump([ \%associations ]); my $cardinality = $associations{lcfirst($association)}->other()->cardinality(); my $setter = "set$association"; if ($cardinality =~ /N$/) { $setter = "add$association"; } $parentObject->$setter($self); } ## Create nested MGEDOntologyEntries for properties of this MGED ## Ontology class and add them to OntologyEntry's ## Associations_list my %propNameType = $ontology->getProperties( $self->getMgedOntologyClass() ); PROPERTY: while (my ($propName,$propType) = each (%propNameType)) { if ($self->getRecursivePropertyMap()->{$propName} && $self->getRecursivePropertyMap()->{$propName} eq $self->getMgedOntologyClass()) { next PROPERTY; } else { $DEBUG && print STDERR ("=== ",$self->getMgedOntologyClass,": $propName -> $propType\n"); #### See if the user has provided a value for this property my $value = $ontology->getUserSpecifiedValue( className => $propName, values => $values, usedValues => $usedValues, ontology => $ontology, ); #### The the user did mention this property if ($value) { # has_accession in the absence of has_database is bad. if ($propName eq 'has_accession' && !$values->{'has_database'}){ carp ("Warning: Accessions (has_accession => $value) should be associated with a database (has_database).\n"); } # Skip creating has_accession or has_value if we have has_database to hang them from if (($propName eq 'has_accession' || $propName eq 'has_value') && $values->{'has_database'}){ #### See if the user has provided a hash with key 'identifier' my $has_database = $ontology->getUserSpecifiedValue( className => 'has_database', values => $values, usedValues => $usedValues, ontology => $ontology, ); next PROPERTY if (ref($has_database) eq 'HASH' && $has_database->{'identifier'}); } # For database entries we create a full MAGE DatabaseEntry. if ($propName eq 'has_database' && ref($value) eq 'HASH' && $value->{'identifier'}){ my $database = Bio::MAGE::Description::Database->new(%$value); my $databaseEntry = Bio::MAGE::Description::DatabaseEntry->new( database => $database, accession => $values->{'has_accession'}, ); $self->setOntologyReference($databaseEntry); $self->setValue($values->{'has_value'}) if $values->{'has_value'}; } else { $DEBUG && print STDERR "+++ Creating abstract ".$propName." => $value\n"; my $childObject = Bio::MAGE::Tools::MGEDOntologyPropertyEntry->new( propertyName => $propName, propertyType => $propType, # If the value is a hash, recurse into that structure values => (ref($value) eq 'HASH' ? $value : $values), usedValues => $usedValues, ontology => $ontology, ); # Don't add empty OntologyEntry objects $self->addAssociations($childObject); # FIXME the usedValues tracking mechanism probably should be fixed and reinstated at some point # $value = $ontology->retireUserSpecifiedValue( # className => $propName, # values => $values, # usedValues => $usedValues, # ); } } } } #### Else if the class is not defined or doesn't exist, complain } else { die("Argh! No class"); } return $self; } ############################################################################### # assignValue ############################################################################### sub assignValue { my $self = shift || die ("self not passed"); my $val = shift; $DEBUG && print STDERR "Setting value $val\n"; if ($self->getIsAssignable() && ! $self->getIsAssigned() && grep(/^$val$/,@{$self->getAssignableValues()})) { ## Instantiable MGED Ontology Class if ($self->getIsInstantiable()) { $self->setValue($val); ## Correct the temporary MO DB reference # Java to be converted FIXME my $ontRef = $self->getOntologyReference(); $ontRef->setAccession("#".$val); my $uri = $ontRef->getURI(); $uri =~ s/placeholder/$val/; $ontRef->setURI($uri); } else { ## Abstract class with assignable subclass ## Add association to selected subclass and delete the other choises #$self->addToAssociations((MGEDOntologyClassEntry) $val); $self->addToAssociations($val); $self->setAssignableValues( [] ); } $self->setIsAssigned(1); } } =head1 BUGS Please send bug reports to the project mailing list: (mged-mage 'at' lists 'dot' sf 'dot' net) =head1 AUTHOR Eric W. Deutsch (edeutsch 'at' systemsbiology 'dot' org) followup work by Jason E. Stewart (jasons 'at' cpan 'dot' org) =head1 SEE ALSO perl(1). =cut # # End the module by returning a true value # 1; Bio-MAGE-Utils-20030502.0/MAGE/Tools/MGEDOntologyHelper.pm0000644000175000017500000006571510472774470021607 0ustar jasonsjasons############################## # # Bio::MAGE::Tools::MGEDOntologyHelper # ############################## # C O P Y R I G H T N O T I C E # Copyright (c) 2001-2002 by: # * The MicroArray Gene Expression Database Society (MGED) # * Rosetta Inpharmatics # # Permission is hereby granted, free of charge, to any person # obtaining a copy of this software and associated documentation files # (the "Software"), to deal in the Software without restriction, # including without limitation the rights to use, copy, modify, merge, # publish, distribute, sublicense, and/or sell copies of the Software, # and to permit persons to whom the Software is furnished to do so, # subject to the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS # BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN # ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN # CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE # SOFTWARE. package Bio::MAGE::Tools::MGEDOntologyHelper; use strict; use Carp; use RDF::Redland; use vars qw($VERSION $DEBUG $model %nodeTypes $NORDF $format @list_members %nodeHash); $NORDF = 0; $DEBUG = 0; $VERSION = q[$Id: MGEDOntologyHelper.pm,v 1.3 2005/09/27 15:38:40 awitney Exp $]; =head1 Bio::MAGE::Tools::MGEDOntologyHelper =head2 SYNOPSIS my $mo_helper = Bio::MAGE::Tools::MGEDOntologyHelper->new( sourceFile=>'MGEDOntology.owl', databaseIdentifier=>'MO', ); =head2 DESCRIPTION =cut ############################################################################### # Constructor ############################################################################### sub new { my $class = shift; if (ref($class)) { $class = ref($class); } my $self = bless {}, $class; my %args = @_; my $sourceFile = $args{'sourceFile'}; if (defined($sourceFile)) { $self->readSourceFile($sourceFile); } my $databaseIdentifier = $args{'databaseIdentifier'}; $self->setDatabaseIdentifier($databaseIdentifier); return $self; } ############################################################################### # classExists ############################################################################### sub classExists { my $self = shift || die("ERROR: self not passed"); my $className = shift || die("ERROR: className not passed"); my $node; if ($NORDF) { $node = 1; } else { $node = get_node($className); } #print "classExists: className=$className node=",$node,"\n"; if (defined($node)) { return(1); } else { return(0); } } ############################################################################### # isInstantiable ############################################################################### sub isInstantiable { my $self = shift || die("ERROR: self not passed"); my $parentClass = shift || die("ERROR: parentClass not passed"); if ($self->getInstances($parentClass)) { return(1); } return 0; } ############################################################################### # getInstances ############################################################################### sub getInstances { my $self = shift || die("ERROR: self not passed"); my $parentClass = shift || die("ERROR: parentClass not passed"); print "[getInstances] $parentClass has instances:\n" if ($DEBUG); my @instances; if ($NORDF) { if ($parentClass eq "PolymerType") { @instances = ('DNA','RNA','protein'); } else { @instances = ('eeny','meeny','moe'); } return(@instances); } my $node = get_node($parentClass); return unless (defined($node)); foreach my $instance (@{get_sources($nodeTypes{type_node}, $node)}) { my $instanceName = clean_MGED($instance->as_string); push(@instances,$instanceName); print " $instanceName\n" if ($DEBUG); } return @instances; } ############################################################################### # getSubclasses ############################################################################### sub getSubclasses { my $self = shift || die("ERROR: self not passed"); my $parentClass = shift || die("ERROR: parentClass not passed"); print "[getSubclasses] $parentClass has subclasses:\n" if ($DEBUG); my @subclasses; my $node = get_node($parentClass); return unless (defined($node)); foreach my $subclass (@{get_sources($nodeTypes{subclass_node}, $node)}) { my $subclassName = clean_MGED($subclass->as_string); push(@subclasses,$subclassName); print " $subclassName\n" if ($DEBUG); } return @subclasses; } ############################################################################### # getSuperclasses ############################################################################### sub getSuperclasses { my $self = shift || die("ERROR: self not passed"); my $parentClass = shift || die("ERROR: parentClass not passed"); print "[getSuperclasses] $parentClass has superclasses:\n" if ($DEBUG); my @superclasses; my $node = get_node($parentClass); return unless (defined($node)); # finds all the subclasses of this class foreach my $subclass (@{get_targets($node, $nodeTypes{subclass_node})}) { my $comment = $model->target($subclass, $nodeTypes{comment_node}); # fetch the list of types for the node foreach my $type (@{get_types($subclass)}) { # these are the superclasses, store them for printing below if ($type eq 'Class') { push(@superclasses, clean_MGED($subclass->as_string)); } } } return @superclasses; } ############################################################################### # getProperties ############################################################################### sub getProperties { my $self = shift || die("ERROR: self not passed"); my $parentClass = shift || die("ERROR: parentClass not passed"); my $DEBUG_THIS = $DEBUG; $DEBUG_THIS = 0; print "[getProperties] $parentClass has properties:\n" if ($DEBUG_THIS); my %properties; @list_members = (); my @used_in_class = (); my $node = get_node($parentClass); return unless (defined($node)); foreach my $subclass (@{get_targets($node, $nodeTypes{subclass_node})}) # finds all the subclasses of this class { my $comment = $model->target($subclass, $nodeTypes{comment_node}); foreach my $type (@{get_types($subclass)}) # fetch the list of types for the node { #----------------------------------------------------------------- # check what type of subClass #----------------------------------------------------------------- if($type eq 'Restriction') { #----------------------------------------------------------------- # find the association e.g. has_units #----------------------------------------------------------------- foreach my $property (@{get_targets($subclass, $nodeTypes{property_node})}) { my $propertyName = clean_MGED($property->as_string); print $propertyName." - " if ($DEBUG_THIS); $properties{$propertyName} = '?'; print "\t=>\t" if ($DEBUG_THIS); #----------------------------------------------------------------- # find the classes associated with the Restriction e.g. Unit #----------------------------------------------------------------- my $node2; if($format eq 'daml'){$node2 = $nodeTypes{hasclass_node}} elsif($format eq 'owl'){$node2 = $nodeTypes{somevaluesfrom_node}} foreach my $class (@{get_targets($subclass, $node2)}) { foreach my $new_type (@{get_types($class)}) # fetch the list of types for the node { if($new_type eq 'Thing') { print $new_type." - " if ($DEBUG_THIS); foreach (@{get_types($class)}) {print "(".$_.") " if ($DEBUG_THIS);} $properties{$propertyName} = join(",",@{get_types($class)}); } elsif($new_type eq 'Class') { foreach my $list (@{get_targets($class, $nodeTypes{oneof_node})}) # finds all the individuals of this class { if($format eq 'owl') { #----------------------------------------------------------------- # OWL: if its a list of instances #----------------------------------------------------------------- foreach (@{get_list_items_owl($list)}) { print "\n\t- ".clean_MGED($_->as_string)." - " if ($DEBUG_THIS); $properties{$propertyName} = join(",",@{get_types($_)}); foreach (@{get_types($_)}) {print "(".$_.") " if ($DEBUG_THIS);} # fetch the list of types for the node } @list_members = (); # reset the array } elsif($format eq 'daml') { #----------------------------------------------------------------- # DAML: if its a list of instances #----------------------------------------------------------------- foreach my $list_type (@{get_types($list)}) # fetch the list of types for the node { #----------------------------------------------------------------- # if it is a List, get the List elements #----------------------------------------------------------------- if($list_type eq 'List') { foreach (@{get_list_items_daml($list)}) { print "\n\t- ".clean_MGED($_->as_string) if ($DEBUG_THIS); print " - " if ($DEBUG_THIS); $properties{$propertyName} = join(",",@{get_types($_)}); foreach (@{get_types($_)}) {print "(".$_.") " if ($DEBUG_THIS);} # fetch the list of types for the node } @list_members = (); # reset the array } } } } #----------------------------------------------------------------- # if its just a class then print the class, eg Unit #----------------------------------------------------------------- unless(clean_MGED($class->as_string) =~ m/r\d+/) # don't print the blank identifiers - HACK JOB! { print clean_MGED($class->as_string) if ($DEBUG_THIS); print " - " if ($DEBUG_THIS); $properties{$propertyName} = clean_MGED($class->as_string); foreach (@{get_types($class)}) {print "(".$_.") " if ($DEBUG_THIS);} # fetch the list of types for the node push(@used_in_class, $class); # for USED IN section, this won't work yet } } if(clean_MGED($class->as_string) =~ m/^string$|^boolean$|^integer$/) # another hack job! { # These are Datatype properties print clean_MGED($class->as_string) if ($DEBUG_THIS); # and so are their own class foreach (@{get_types($class)}) {print "(".$_.") " if ($DEBUG_THIS);} } } } } } } print "\n" if ($DEBUG_THIS); } # Deal with property inheritance here foreach my $superclass ($self->getSuperclasses($parentClass)){ my %superclassProperties; # Don't recurse into the MAGE model itself if ($superclass ne 'MGEDOntology'){ %superclassProperties = $self->getProperties($superclass); } # Merge superclass properties into %properties while (my ($key, $value) = each %superclassProperties){ $properties{$key} ||= $value; } } return %properties; } ############################################################################### # setDatabaseIdentifier ############################################################################### sub setDatabaseIdentifier { my $self = shift; my $attributeName = 'DatabaseIdentifier'; my $methodName = 'set'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: no arguments passed to setter") unless @_; confess(__PACKAGE__ . "::$methodName: too many arguments passed to setter") if @_ > 1; my $val = shift; return $self->{"__$attributeName"} = $val; } ############################################################################### # getDatabaseIdentifier ############################################################################### sub getDatabaseIdentifier { my $self = shift; my $attributeName = 'DatabaseIdentifier'; my $methodName = 'get'.ucfirst($attributeName); confess(__PACKAGE__ . "::$methodName: arguments passed to getter") if @_; # Default MO database identifier is set here return $self->{"__$attributeName"} || 'www.mged.org:Database:MO'; } ############################################################################### # getOntologyReference ############################################################################### sub getOntologyReference { my $self = shift || croak("ERROR: self not passed"); my $term = shift || croak("ERROR: term not passed"); my $databaseEntry = Bio::MAGE::Description::DatabaseEntry->new( accession => "#$term", URI => "http://mged.sourceforge.net/ontologies/MGEDOntology.php#$term", database => Bio::MAGE::Description::Database->new( identifier => $self->getDatabaseIdentifier, name=>"The MGED Ontology", URI => "http://mged.sourceforge.net/ontologies/MGEDOntology.php", version => $self->{version} ), ); return $databaseEntry; } ############################################################################### # getUserSpecifiedValue ############################################################################### sub getUserSpecifiedValue { my $self = shift || die("ERROR: self not passed"); my %args = @_; my $className = $args{'className'} || die "ERROR: className not passed"; my $values = $args{'values'} || die("ERROR: values not passed"); my $usedValues = $args{'usedValues'} || die("ERROR: usedValues not passed"); my $specifiedValue; my @assignableValues = $self->getInstances($className); #### See if the value is in the used hash while (my ($key,$value) = each (%{$usedValues})) { if ($key eq $className) { print Data::Dumper->Dump([$values]); print Data::Dumper->Dump([$usedValues]); die("ERROR: Encountered a duplicate class $className for which a value was already assigned elsewhere"); } } #### See if the value is in the hash while (my ($key,$value) = each (%{$values})) { #print "Looking for user def value at $key with className $className\n"; #### If found if ($key eq $className) { #print STDERR "Found user-specified $className => $value\n"; #### Set this to the returned value and move the entry to usedValues hash $specifiedValue = $value; } } return $specifiedValue; } ############################################################################### # retireUserSpecifiedValue ############################################################################### sub retireUserSpecifiedValue { my $self = shift || die("ERROR: self not passed"); my %args = @_; my $className = $args{'className'} || die "ERROR: className not passed"; my $values = $args{'values'} || die("ERROR: values not passed"); my $usedValues = $args{'usedValues'} || die("ERROR: usedValues not passed"); my $specifiedValue; #### See if the value is in the used hash while (my ($key,$value) = each (%{$usedValues})) { if ($key eq $className) { die("ERROR: Encountered already retired $className."); } } #### See if the value is in the hash while (my ($key,$value) = each (%{$values})) { #### If found if ($key eq $className) { #print "Found user-specified $className\n"; #### Set this to the returned value and move the entry to usedValues hash $specifiedValue = $value; $usedValues->{$key} = $value; delete($values->{$key}); } } return $specifiedValue; } ############################################################################### ############################################################################### # RDF OWL Read related stuff ############################################################################### ############################################################################### ############################################################################### # readSourceFile ############################################################################### sub readSourceFile { my $self = shift || die("ERROR: self not passed"); my $sourceFile = shift || die("ERROR: sourceFile not passwd"); $format = shift || "owl"; unless (-e $sourceFile) { die("ERROR: Unable to find source file '$sourceFile'"); } # specify the RDF parser to use my $parser = new RDF::Redland::Parser("raptor"); # generate Redland URI object pointing to specified RDF file my $uri = new RDF::Redland::URI("file:$sourceFile"); # choose the method for storing the model and then set up model # object, with the specified storage method my $storage = new RDF::Redland::Storage("hashes", "test", "new='yes',hash-type='memory'"); $model = new RDF::Redland::Model($storage, ""); # load the model from the file print "Loading Model..... \n" if ($DEBUG); $parser->parse_into_model($uri, undef, $model); print "Model loaded\tmodel size = ".$model->size."\n" if ($DEBUG); #----------------------------------------------------------------- # define generic nodes (may be able to get this from the RDF # file automatically, but can't see how to do it yet!) #----------------------------------------------------------------- my $owl_namespace = "http://www.w3.org/2002/07/owl"; my $daml_namespace = "http://www.daml.org/2001/03/daml+oil"; my $namespace; my $namespace2; if ($format eq 'daml') { die "\n\nDAML format no longer supported, please use OWL format\n\n"; # $namespace = $daml_namespace; # $namespace2 = $daml_namespace; } elsif ($format eq 'owl') { $namespace = $owl_namespace; $namespace2 = 'http://www.w3.org/1999/02/22-rdf-syntax-ns'; } else { die "\n\nUnknown format\n\n"; } $nodeTypes{subclass_node} = new RDF::Redland::Node->new_from_uri_string("http://www.w3.org/2000/01/rdf-schema#subClassOf"); $nodeTypes{class_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#Class"); $nodeTypes{hasclass_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#hasClass"); $nodeTypes{property_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#onProperty"); $nodeTypes{object_property_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#ObjectProperty"); $nodeTypes{unique_property_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#UniqueProperty"); $nodeTypes{datatype_property_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#DatatypeProperty"); $nodeTypes{type_node} = new RDF::Redland::Node->new_from_uri_string("http://www.w3.org/1999/02/22-rdf-syntax-ns#type"); $nodeTypes{comment_node} = new RDF::Redland::Node->new_from_uri_string("http://www.w3.org/2000/01/rdf-schema#comment"); $nodeTypes{domain_node} = new RDF::Redland::Node->new_from_uri_string("http://www.w3.org/2000/01/rdf-schema#domain"); $nodeTypes{oneof_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#oneOf"); $nodeTypes{thing_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#Thing"); $nodeTypes{list_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#List"); $nodeTypes{rest_node} = new RDF::Redland::Node->new_from_uri_string("$namespace2#rest"); $nodeTypes{first_node} = new RDF::Redland::Node->new_from_uri_string("$namespace2#first"); $nodeTypes{restriction_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#Restriction"); $nodeTypes{file_node} = new RDF::Redland::Node->new_from_uri_string("http://mged.sourceforge.net/ontologies/MGEDOntology.owl"); $nodeTypes{version_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#versionInfo"); $nodeTypes{date_node} = new RDF::Redland::Node->new_from_uri_string("http://www.w3.org/2002/07/dc#date"); $nodeTypes{somevaluesfrom_node} = new RDF::Redland::Node->new_from_uri_string("$namespace#someValuesFrom"); #----------------------------------------------------------------- # print version info from the file #----------------------------------------------------------------- foreach my $version (@{get_targets($nodeTypes{file_node}, $nodeTypes{version_node})}) { $self->{version} = clean_MGED($version->as_string); if ($DEBUG) { print "\nVERSION:\t"; print clean_MGED($version->as_string)."\n" } } foreach my $date (@{get_targets($nodeTypes{file_node}, $nodeTypes{date_node})}) { if ($DEBUG) { print "\nRELEASE DATE:\t"; print clean_MGED($date->as_string)."\n" } } return 1; } ######################################################################## # get_node - Returns the node given a string name ######################################################################## sub get_node { my ($nodeName) = @_; make_node_hash() unless (scalar %nodeHash); return $nodeHash{$nodeName}; } ######################################################################## # make_node_hash - Creates a hash of othe nodes ######################################################################## sub make_node_hash { my $iterator = $model->sources_iterator($nodeTypes{type_node}, $nodeTypes{class_node}); while($iterator && !$iterator->end) { my $node = $iterator->current; $nodeHash{clean_MGED($node->as_string)} = $node; $iterator->next; } return; } ######################################################################## # get_targets - generic subroutine to get targets from source and arc ######################################################################## sub get_targets { my ($source, $arc) = @_; my(@targets) = $model->targets($source, $arc); return \@targets; } ######################################################################## # get_sources - generic subroutine to get sources from target and arc ######################################################################## sub get_sources { my ($arc, $target) = @_; my (@sources) = $model->sources($arc, $target); return \@sources; } ######################################################################## # get_types - retrieves list of types of a Node ######################################################################## sub get_types { my ($source) = @_; my(@targets) = $model->targets($source, $nodeTypes{type_node}); my %seen; # %seen and @unique just used to remove duplicate my @unique; # nodes in the @targets list foreach my $item (@targets) { my $type = clean_MGED($item->as_string); push(@unique, $type) unless $seen{$type}++; } return \@unique; # return only the unique values } ################################################################ # clean_MGED - cleans the stringified Node description ################################################################ sub clean_MGED { my($input) = @_; $input =~ s/\^\^//; $input =~ s/.+#//; $input =~ s/\]$//; return $input; } ######################################################################## # get_list_items_daml - retrieves all the elements of a List from DAML ######################################################################## sub get_list_items_daml { my($list_node) = @_; # get first member of list foreach my $list_item (@{get_targets($list_node, $nodeTypes{first_node})}) { push(@list_members, $list_item); # add item to list } # get second level list (rest Node) foreach my $list_item (@{get_targets($list_node, $nodeTypes{rest_node})}) { foreach my $new_type (@{get_types($list_item)}) { if($new_type eq 'List'){get_list_items_daml($list_item, @list_members)} # recursive subroutine to collect all members of the list elsif($new_type eq 'nil'){} else{die "\n\nUNKNOWN TYPE IN THE LIST\n\n"} } } return \@list_members; } ######################################################################## # get_list_item_owls - retrieves all the elements of a List from OWL ######################################################################## sub get_list_items_owl { my($list_node) = @_; # get first member of list foreach my $list_item (@{get_targets($list_node, $nodeTypes{first_node})}) { push(@list_members, $list_item); # add item to list } # get second level list (rest Node) foreach my $list_item (@{get_targets($list_node, $nodeTypes{rest_node})}) { get_list_items_owl($list_item, @list_members); } return \@list_members; } =head1 BUGS Please send bug reports to the project mailing list: (mged-mage 'at' lists 'dot' sf 'dot' net) =head1 AUTHOR Eric W. Deutsch (edeutsch 'at' systemsbiology 'dot' org) followup work by Jason E. Stewart (jasons 'at' cpan 'dot' org) =head1 SEE ALSO perl(1). =cut # # End the module by returning a true value # 1; Bio-MAGE-Utils-20030502.0/MAGE/XML/0000755000175000017500000000000010622036172015147 5ustar jasonsjasonsBio-MAGE-Utils-20030502.0/MAGE/XML/Writer.pm0000644000175000017500000005777710501440172017003 0ustar jasonsjasons# # Bio::MAGE::XML::Writer.pm # a module for exporting MAGE-ML # package Bio::MAGE::XML::Writer; use strict; use vars qw($VERSION $DEBUG); use Carp; use Bio::MAGE; use XML::Xerces; $VERSION = 2006_08_15.0; =head1 NAME Bio::MAGE::XML::Writer - a module for exporting MAGE-ML =head1 SYNOPSIS use Bio::MAGE::XMLUtils; my $writer = Bio::MAGE::XML::Writer->new(@args); $writer->write($mage); # # attributes to modify where the output is written # # set the output filehandle my $fh = \*STDOUT; $writer->fh($fh); # whether to write data cubes externally (default == FALSE) $writer->external_data($bool); # which directory to write external data cubes (default == /tmp) $writer->external_data_dir($path); # whether the to interpret the C as data or a file # path (default == FALSE) $writer->cube_holds_path($bool); # # attributes to modify the output format # # which format is the external data file $writer->data_format($dataformat); # to change the level of indent for each new tag (defaul == 2) $writer->indent_increment($num); # to change the beginning indent level (defaul == 0) $writer->indent_level($num); # set to true to not format attributes (default == FALSE) $writer->attrs_on_one_line($bool); # how many extra spaces attributes should be indented past start # tag end (default == 1) $writer->attr_indent($num); # whether to write all sub-tags on the same line (default == undef) $writer->collapse_tag($bool); # # attributes to modify the the document # # to change the encoding (default == ISO-8859-1) $writer->encoding($format); # to set the public id (default == undef) $writer->public_id($id); # to change the system id (default == MAGE-ML.dtd) $writer->system_id($id); # check to see that objects set more than just identifier (default == TRUE) $writer->empty_identifiable_check(); # # attributes to handle identifiers # # whether to create identifiers if not specified (default == FALSE) $writer->generate_new_identifiers(); # code reference to be invoked for creating new identifiers $writer->generate_identifier(); =head1 DESCRIPTION Methods for transforming information from a MAGE-OM objects into MAGE-ML. =cut use base qw(Bio::MAGE::Base); $DEBUG = 1; sub initialize { my ($self) = shift; $self->tag_buffer([]); $self->cube_holds_path(0) unless defined $self->cube_holds_path(); $self->attrs_on_one_line(0) unless defined $self->attrs_on_one_line(); $self->attr_indent(1) unless defined $self->attr_indent(); $self->indent_increment(2) unless defined $self->indent_increment(); $self->indent_level(0) unless defined $self->indent_level(); $self->data_format('tab delimited') unless defined $self->data_format(); $self->external_data(0) unless defined $self->external_data(); $self->external_data_dir('/tmp') unless defined $self->external_data_dir(); $self->empty_identifiable_check(1) unless defined $self->empty_identifiable_check(); $self->encoding('ISO-8859-1') unless defined $self->encoding(); $self->system_id('MAGE-ML.dtd') unless defined $self->system_id(); $self->generate_identifier(sub {$self->identifier_generatation(shift)}) unless defined $self->generate_identifier(); $self->generate_new_identifiers(0) unless defined $self->generate_new_identifiers(); } sub incr_indent { my $self = shift; $self->indent_level($self->indent_level + $self->indent_increment); } sub decr_indent { my $self = shift; $self->indent_level($self->indent_level - $self->indent_increment); } =head1 METHODS =item write($MAGE_object); C prints the objects contained in $MAGE_object as MAGE-ML to the file handle used by the writer. =cut sub write { my ($self,$top_level_obj) = @_; die __PACKAGE__."::write: must specify a file handle for output" unless defined $self->fh(); # handle the basics $self->write_xml_decl(); $self->write_doctype(); $top_level_obj->obj2xml($self); } sub write_xml_decl { my $self = shift; my $fh = $self->fh(); my $encoding = $self->encoding(); print $fh <<"MAGEML"; MAGEML } sub write_doctype { my $self = shift; my $public_id = $self->public_id(); my $PUBLIC; if (defined $public_id) { $PUBLIC = qq[PUBLIC "$public_id"]; } else { $PUBLIC = ''; } my $system_id = $self->system_id(); my $SYSTEM; if (defined $public_id) { $SYSTEM = qq["$system_id"]; } else { $SYSTEM = qq[SYSTEM "$system_id"]; } my $fh = $self->fh(); print $fh <<"MAGEML"; MAGEML } sub write_start_tag { my ($self,$tag,$empty,%attrs) = @_; my $indent = ' ' x $self->indent_level(); my $buffer; my (@attrs); foreach my $attribute_name (keys %attrs) { my $attribute_val = $attrs{$attribute_name}; $attribute_val =~ s/\&/&/g; $attribute_val =~ s/\&amp;/&/g; $attribute_val =~ s/\"/"/g; $attribute_val =~ s/\&quot;/"/g; $attribute_val =~ s/\'/'/g; $attribute_val =~ s/\&apos;/'/g; $attribute_val =~ s/\>/>/g; $attribute_val =~ s/\&gt;/>/g; $attribute_val =~ s/\attrs_on_one_line()) { $attrs = join(' ',@attrs); } else { # we add one to compensate for the '<' in the start tag $attr_indent = $self->attr_indent() + 1; $attr_indent += length($tag); $attr_indent = ' ' x $attr_indent . $indent; $attrs = join("\n$attr_indent",@attrs); } if ($attrs) { $buffer .= "$indent<$tag $attrs"; } else { # don't print the space after the tag because Eric said so $buffer .= "$indent<$tag"; } if ($empty) { $buffer .= '/>'; } else { $buffer .= '>'; } $buffer .= "\n" unless $self->collapse_tag(); $self->incr_indent() unless $empty; # we don't actually write out the tag yet. We buffer it on a stack # until we actually know we should write it out push(@{$self->tag_buffer},$buffer); # if this was an empty tag, we immediately flush the buffer $self->flush_tag_buffer() if $empty; } sub flush_tag_buffer { my $self = shift; my $fh = $self->fh(); my $tag_buffer = $self->tag_buffer(); while (my $string = shift @{$tag_buffer}) { print $fh $string; } } sub write_end_tag { my ($self,$tag) = @_; $self->decr_indent(); # if there is still something on the tag buffer, we must not have # had any data to write, so don't write the end tag if (scalar @{$self->tag_buffer}) { pop(@{$self->tag_buffer}); return; } my $indent = ' ' x $self->indent_level(); my $fh = $self->fh(); print $fh "$indent\n"; } # we purposefully avoid copying the text, since it may be BIG sub write_text { my $self = shift; my $fh = $self->fh(); print $fh $_[0]; } # # Helper methods # sub identifier_generation { my ($self,$obj) = @_; my $known_identifiers = $self->identifiers(); return if exists $known_identifiers->{$obj->getIdentifier}; # stringify the object: Bio::MAGE::Identifiable=SCALAR(0x10379980) my $identifier = $obj; # strip of the leading class qualifiers: Identifiable=SCALAR(0x10379980) $identifier =~ s/^Bio::MAGE:://; # convert the '=' to a colon: Identifiable:SCALAR(0x10379980) $identifier =~ tr/=/:/; # remove the SCALAR: Identifiable:10379980 $identifier =~ s/SCALAR\(0x(.*)\)/$1/; $obj->setIdentifier($identifier); } sub obj2xml_ref { my ($self,$obj) = @_; # create the <*_ref> tag my $tag = $obj->class_name(); $tag =~ s/.+:://; $tag .= '_ref'; # we create the empty tag with only the identifier my $empty = 1; $self->write_start_tag($tag,$empty,identifier=>$obj->getIdentifier()); } sub flatten { my ($self,$list) = @_; my @list; foreach my $item (@{$list}) { if (ref($item) eq 'ARRAY') { push(@list,$self->flatten($item)); } else { push(@list,$item); } } return join("\t",@list); } sub external_file_id { my $self = shift; my $num = $self->external_data(); $num++; $self->external_data($num); return "external-data-$num.txt"; } sub write_bio_data_tuples() { my ($self,$obj) = @_; # has no attributes # the tag name is the name of the class my $tag = $obj->class_name(); $tag =~ s/.+:://; $self->write_start_tag($tag,my $empty = 0); # make the data structure my %data; my %des; my %bas; my %qts; foreach my $datum (@{$obj->getBioAssayTupleData()}) { my $de = $datum->getDesignElement(); my $ba = $datum->getBioAssay(); my $qt = $datum->getQuantitationType(); my $ba_id = $ba->getIdentifier(); my $qt_id = $qt->getIdentifier(); my $de_id = $de->getIdentifier(); # store the datum object $data{$ba_id}->{$de_id}{$qt_id} = $datum; # store the design element obj $des{$de_id} = $de; # store the quantitation type obj $qts{$qt_id} = $qt; # store the bioassay obj $bas{$ba_id} = $ba; } # write the container tag $tag = 'BioAssayTuples_assnlist'; my $EMPTY = 0; my $NOT_EMPTY = 1; $self->write_start_tag($tag,$EMPTY); # write the XML foreach my $ba (keys %data) { # write the BioAssayTuple container tag my $bat_tag = 'BioAssayTuple'; $self->write_start_tag($bat_tag,$EMPTY); # write the container tag my $tag = 'BioAssay_assnref'; $self->write_start_tag($tag,$EMPTY); # write the BioAssay ref object my $ba_obj = $bas{$ba};#bioassay $self->obj2xml_ref($ba_obj); # end the BioAssay_ref container tag $self->write_end_tag($tag); # write the container tag $tag = 'DesignElementTuples_assnlist'; $self->write_start_tag($tag,$EMPTY); foreach my $de (keys %{$data{$ba}}) { # write the DesignElementTuple container tag my $det_tag = 'DesignElementTuple'; $self->write_start_tag($det_tag,$EMPTY); my $tag = 'DesignElement_assnref'; # write the container tag $self->write_start_tag($tag,$EMPTY); # write the DesignElement ref object my $de_obj = $des{$de}; #design element $self->obj2xml_ref($de_obj); # end the DesignElement ref container tag $self->write_end_tag($tag); # write the container tag $tag = 'QuantitationTypeTuples_assnlist'; $self->write_start_tag($tag,$EMPTY); foreach my $qt (keys %{$data{$ba}->{$de}}) { # write the QuantitationTypeTuple container tag my $qtt_tag = 'QuantitationTypeTuple'; $self->write_start_tag($qtt_tag,$EMPTY); my $tag = 'QuantitationType_assnref'; # write the container tag $self->write_start_tag($tag,$EMPTY); # write the QuantitationType ref object my $ba_obj = $qts{$qt}; #quantitation type $self->obj2xml_ref($ba_obj); # end the Quantitation Type ref container tag $self->write_end_tag($tag); # write the datum container tag my $datum_tag = 'Datum_assn'; $self->write_start_tag($datum_tag,$EMPTY); # write the datum tag $tag = 'Datum'; my $value = $data{$ba}->{$de}{$qt}->getValue(); die "no $value for BioAssay: ", $ba, ", DesignElement: ", $de, ", QuantitationType: ", $qt, unless defined $value; my %attrs = (value=>$value); $self->write_start_tag($tag,$NOT_EMPTY,%attrs); # end the Datum container tag $self->write_end_tag($datum_tag); # end the QuantitationTypeTuple container tag $self->write_end_tag($qtt_tag); } # end the QuantitationTypeTuples_list container tag $self->write_end_tag($tag); # end the DesignElementTuple container tag $self->write_end_tag($det_tag); } # end the DesignElementTuples_list container tag $self->write_end_tag($tag); # end the BioAssayTuple container tag $self->write_end_tag($bat_tag); } # end the BioAssayTuples_list container tag $self->write_end_tag($tag); # end the BioDataTuples tag $self->write_end_tag('BioDataTuples'); } sub obj2xml { my ($self,$obj) = @_; if ($obj->isa("Bio::MAGE::BioAssayData::BioDataTuples")) { return $self->write_bio_data_tuples($obj); } # all attributes are gathered into a hash my %attributes; my $data; foreach my $attribute ($obj->get_attribute_names()) { # $obj->get_attribute_names can return an array with empty ('') # values. next unless $attribute; my $attribute_val; { no strict 'refs'; my $getter_method = 'get'.ucfirst($attribute); $attribute_val = $obj->$getter_method(); if (defined $attribute_val) { if ($attribute eq 'cube') { if ($self->cube_holds_path()) { # the cube holds the path to an already written file # so we don't bother interpreting it $data = $attribute_val; } else { $data = $self->flatten($attribute_val); } next; } $attribute_val =~ s/\&/&/g; $attribute_val =~ s/\&amp;/&/g; $attribute_val =~ s/\"/"/g; $attribute_val =~ s/\&quot;/"/g; $attribute_val =~ s/\'/'/g; $attribute_val =~ s/\&apos;/'/g; $attribute_val =~ s/\>/>/g; $attribute_val =~ s/\&gt;/>/g; $attribute_val =~ s/\class_name(); $tag =~ s/.+:://; # we create the start tag, with the object attributes represented as # element attributes. If the object has no associations we make it # an empty element - this is to avoid XML validation errors my $empty = not scalar $obj->associations(); my $xml_written = 0; $self->write_start_tag($tag,$empty,%attributes); # if we discover an object that only has it's identifier attribute set # we don't flush the tag buffer unless ($self->empty_identifiable_check() and exists $attributes{identifier} and scalar keys %attributes == 1) { $self->flush_tag_buffer(); $xml_written = 1; } # associations are handled as sub-elements of the current element # and we use the association meta-data to instruct how to represent # each association # # We use the IxHash module because the associations are ordered # in the same order the DTD expects to receive them, and IxHash # preserves insertion order tie my %assns_hash, 'Tie::IxHash', $obj->associations(); foreach my $association (keys %assns_hash) { my $association_obj; { no strict 'refs'; my $getter_method = 'get'.ucfirst($association); $association_obj = $obj->$getter_method(); } if (defined $association_obj) { # we've found an association object, so if we were delaying # the writing of the code, we write it out now unless ($xml_written) { $self->flush_tag_buffer(); $xml_written = 1; } # if this is a bi-navigable association, and we there is an aggregate # association from the other end, we do *not* write the object out # we know it's bi-navigable if self->name is defined # we know it's aggregate if other->is_ref is not true if (defined $assns_hash{$association}->self->name() and not $assns_hash{$association}->other->is_ref() ) { next; } # we first create the container tag with the proper prefix # to know if this is a ref element or not we look at the self # side of the association my $prefix; my $is_ref = $assns_hash{$association}->self->is_ref(); if ($is_ref) { $prefix = '_assnref'; } else { $prefix = '_assn'; } my @association_objects; if ($assns_hash{$association}->other->is_list) { $prefix .= 'list'; @association_objects = @{$association_obj}; } else { @association_objects = ($association_obj); } my $container_tag = ucfirst("$association$prefix"); # container tags must not be empty $self->write_start_tag("$container_tag",my $cont_empty=0); # now we fill in the container with the object(s) foreach $association_obj (@association_objects) { if ($is_ref) { $self->obj2xml_ref($association_obj) } else { $self->obj2xml($association_obj); } } # now end the container tag $self->write_end_tag("$container_tag"); } } if (defined $data) { if ($self->external_data()) { my %attributes; if ($self->cube_holds_path()) { $attributes{filenameURI} = $data; } else { $attributes{filenameURI} = $self->external_file_id(); } $attributes{dataFormat} = $self->data_format(); my $tag = 'DataExternal_assn'; $self->write_start_tag($tag,my $empty=0); # we need to make it external { my $tag = 'DataExternal'; $self->write_start_tag($tag,my $empty=1,%attributes); # if we've been told the cube is already written, we don't # bother re-writing it unless ($self->cube_holds_path()) { my $dir = $self->external_data_dir(); open(DATA, ">$dir/$attributes{filenameURI}") or die "Couldn't open $dir/$attributes{filenameURI} for writing"; print DATA $data; close(DATA); } } $self->write_end_tag($tag); } else { # we make it internal my $tag = 'DataInternal_assn'; $self->write_start_tag($tag,0); { my $tag = 'DataInternal'; $self->write_start_tag($tag,0); $self->flush_tag_buffer; my $fh = $self->fh(); print $fh ""; $self->write_end_tag($tag); } $self->write_end_tag($tag); } } # now end the current element $self->write_end_tag($tag) unless $empty; } sub is_bio_mage_object { my ($self,$obj) = @_; return UNIVERSAL::isa($obj,'Bio::MAGE'); } =head1 ATTRIBUTE METHODS The following methods must all be invoked using an instance of Bio::MAGE::XML::Writer; =over =cut =item indent_level($num) This attribute controls the current level of indentation while writing a document. It should not be manipulated by users, unless for some reason you wanted to set the starting indent level to something other than zero. B 0 (zero) =cut sub indent_level { my $self = shift; if (@_) { $self->{__INDENT_LEVEL} = shift; } return $self->{__INDENT_LEVEL}; } =item indent_increment($num) This attribute controls the the number of spaces that added to the indent for every new level of elements. B 2 =cut sub indent_increment { my $self = shift; if (@_) { $self->{__INDENT_INCREMENT} = shift; } return $self->{__INDENT_INCREMENT}; } =item attrs_on_one_line($bool) This attribute controls whether attribute values should be pretty-printed. If true, attributes will not pretty-printed, but will instead be written out all on one line. B false =cut sub attrs_on_one_line { my $self = shift; if (@_) { $self->{__ATTRS_ON_ONE_LINE} = shift; } return $self->{__ATTRS_ON_ONE_LINE}; } =item attr_indent($bool) Controls how many spaces past the end start tag that attributes should be indented. This example shows an C of 1: The following illustrates and C of -2: B 1 =cut sub attr_indent { my $self = shift; if (@_) { $self->{__ATTR_INDENT} = shift; } return $self->{__ATTR_INDENT}; } =item collapse_tag($bool) This attribute is not very useful at the moment. In the future it may be used to specify tags that should have their contents all on a single line. Currently it controls whether or not to write a newline after each elements start tag, with no method to decide to write or not to write based on the name of the tag. B false =cut sub collapse_tag { my $self = shift; if (@_) { $self->{__COLLAPSE_TAG} = shift; } return $self->{__COLLAPSE_TAG}; } =item encoding($string) This is the value that value be written out as the encoding attribute for the XML Declaration of the output MAGE-ML document: B ISO-8859-1 =cut sub encoding { my $self = shift; if (@_) { $self->{__ENCODING} = shift; } return $self->{__ENCODING}; } =item public)_id($string) If defined, this value will be written out as the value of the PUBLIC attribute of the DOCTYPE tag in the output MAGE-ML document. B undef =cut sub public_id { my $self = shift; if (@_) { $self->{__PUBLIC_ID} = shift; } return $self->{__PUBLIC_ID}; } =item system_id($string) If defined, this value will be written out as the value of the SYSTEM attribute of the DOCTYPE tag in the output MAGE-ML document: B MAGE-ML.dtd =cut sub system_id { my $self = shift; if (@_) { $self->{__SYSTEM_ID} = shift; } return $self->{__SYSTEM_ID}; } =item generate_identifier($code_ref) This attribute stores a code reference that will be invoked to create a new identifier for any object that does not already have one defined. This will happen only if the C attribute is set to true. B \&identifier_generation =cut sub generate_identifier { my $self = shift; if (@_) { $self->{__GENERATE_IDENTIFIER} = shift; } return $self->{__GENERATE_IDENTIFIER}; } =item generate_new_identifier($bool) If this attribute is set to true, the code reference store in the C attribute will be invoked to create a new identifier for any object that does not already have one defined. B false =cut sub generate_new_identifiers { my $self = shift; if (@_) { $self->{__GENERATE_NEW_IDENTIFIERS} = shift; } return $self->{__GENERATE_NEW_IDENTIFIERS}; } =item fh($file_handle) This is the file handle to which the MAGE-ML document will be written. B undef =cut sub fh { my $self = shift; if (@_) { $self->{__FH} = shift; } return $self->{__FH}; } sub tag_buffer { my $self = shift; if (@_) { $self->{__TAG_BUFFER} = shift; } return $self->{__TAG_BUFFER}; } =item external_data($bool) If defined, this will cause all BioAssayData objects to write themselves out using the DataExternal format. B false =cut sub external_data { my $self = shift; if (@_) { $self->{__EXTERNAL_DATA} = shift; } return $self->{__EXTERNAL_DATA}; } =item data_format($format) $format is either 'tab delimited' or 'space delimited' B 'tab delimited' =cut sub data_format { my $self = shift; if (@_) { $self->{__DATA_FORMAT} = shift; } return $self->{__DATA_FORMAT}; } =item external_data_dir($path) The C attribute only controls where the main MAGE-ML document is written. If the C attribute is set, the writer will also create a seperate external data file for each data cube. The C controls what director those files are written to. B /tmp =cut sub external_data_dir { my $self = shift; if (@_) { $self->{__EXTERNAL_DATA_DIR} = shift; } return $self->{__EXTERNAL_DATA_DIR}; } =item cube_holds_path($path) Sometimes, you already have your data written to an external file, and you simply want to reuse the file without any extra overhead. The C attribute controls indicates that you are storing the path to the external file in the C attribute of the C objects. B false =cut sub cube_holds_path { my $self = shift; if (@_) { $self->{__CUBE_HOLDS_PATH} = shift; } return $self->{__CUBE_HOLDS_PATH}; } =item empty_identifiable_check($bool) If true, all objects that define an C attribute and no other attributes will only be included as <*_ref> elements. B Currently no checking of association values is made, only attributes. So if you want to ensure that an Identifiable object is written, make sure that you set the C attribute as well as the C attribute. B true =cut sub empty_identifiable_check { my $self = shift; if (@_) { $self->{__EMPTY_IDENTIFIABLE_CHECK} = shift; } return $self->{__EMPTY_IDENTIFIABLE_CHECK}; } 1; Bio-MAGE-Utils-20030502.0/MAGE/XML/Handler/0000755000175000017500000000000010622036172016524 5ustar jasonsjasonsBio-MAGE-Utils-20030502.0/MAGE/XML/Handler/DocumentHandler.pm0000644000175000017500000000134610501440055022135 0ustar jasonsjasons############################################################################### # Bio::MAGE::XML::Handler::DocumentHandler package: Callbacks to process elements as they come # from the SAX parser ############################################################################### package Bio::MAGE::XML::Handler::DocumentHandler; use strict; use vars qw(@ISA); @ISA = qw(XML::Xerces::PerlDocumentHandler Bio::MAGE::XML::Handler); sub start_element { my ($self,$localname,$attrs) = @_; my %attrs = $attrs->to_hash(); Bio::MAGE::XML::Handler::start_element($self,$localname,\%attrs); } sub end_element { Bio::MAGE::XML::Handler::end_element(@_); } sub characters { Bio::MAGE::XML::Handler::characters(@_); } Bio-MAGE-Utils-20030502.0/MAGE/XML/Handler/ObjectHandler/0000755000175000017500000000000010622036172021230 5ustar jasonsjasonsBio-MAGE-Utils-20030502.0/MAGE/XML/Handler/ObjectHandler/SQL.pm0000644000175000017500000005016310501440055022225 0ustar jasonsjasons# $Id: SQL.pm,v 1.7 2003/04/20 22:15:21 allenday Exp $ # # BioPerl module for Bio::MAGE::XML::Handler::ObjectHandler::SQL # # Cared for by Allen Day # # Copyright Allen Day # # You may distribute this module under the same terms as perl itself # POD documentation - main docs before the code =head1 NAME Bio::MAGE::XML::Handler::ObjectHandler::SQL - DESCRIPTION of Object =head1 SYNOPSIS Give standard usage here =head1 DESCRIPTION Describe the object here =head1 AUTHOR - Allen Day Email allenday@ucla.edu Describe contact details here =head1 CONTRIBUTORS Additional contributors names and emails here =head1 APPENDIX The rest of the documentation details each of the object methods. Internal methods are usually preceded with a _ =cut # Let the code begin... package Bio::MAGE::XML::Handler::ObjectHandler::SQL; use vars qw(@ISA); use strict; use Carp; use Data::Dumper; @ISA = qw(Bio::MAGE::XML::Handler::ObjectHandlerI ); use constant CARD_1 => '1'; use constant CARD_0_OR_1 => '0..1'; use constant CARD_1_TO_N => '1..N'; use constant CARD_0_TO_N => '0..N'; =head2 new Title : new Usage : my $obj = new Bio::MAGE::XML::Handler::ObjectHandler::SQL(); Function: Builds a new Bio::MAGE::XML::Handler::ObjectHandler::SQL object Returns : an instance of Bio::MAGE::XML::Handler::ObjectHandler::SQL Args : =cut sub new { my($class,@args) = @_; my $self = bless {}, $class; return $self; } sub fk { my $self = shift; } ############################################################################### # fh: setter/getter for the file handle ############################################################################### sub fh { my $self = shift; if (@_) { $self->{__FH} = shift; } return $self->{__FH} || \*STDOUT; } sub handle { my($self,$handler,$obj) = @_; self->throw("not a Bio::MAGE object") unless ref($obj) =~ /^Bio::MAGE/; #report that the object is handled if it is package level. # create the <*_ref> tag my $table_name = $obj->class_name(); $table_name =~ s/.+:://; # we create the empty tag with only the identifier my $empty = 1; my $referring = $handler->object_stack->[-1]; my $association = $handler->assn_stack->[-1]; my $target_ID = $self->object_IDs($obj); unless (defined($target_ID)) { #print "+++ Yipe, the target object hasn't been written yet.\n"; #print " Try to write the object:\n"; $self->obj2database($handler,$obj); $target_ID = $self->object_IDs($obj); die "INTERNAL ERROR POS1: Failed to INSERT needed object $obj\n" unless (defined($target_ID)); } #print "referring: ",join(" , ",@{$referring}),"\n"; #print "assn: ",join(" , ",@{$association}),"\n"; #print "cardinality: ",$association->[0]->other->cardinality(),"\n"; #print "name: ",$association->[0]->other->name(),"\n"; #print "class_name: ",$association->[0]->other->class_name(),"\n"; #### If cardinality is 1 or 0..1 #warn Dumper($handler->assn_stack); if ($association->other->cardinality eq CARD_0_OR_1 || $association->other->cardinality eq CARD_1) { my $table_name = $referring->class_name(); $table_name =~ s/.+:://; my $assn_name = $association->other->name(); my %rowdata = ($assn_name.'_fk'=>$target_ID); if($referring->isa('Bio::MAGE::Identifiable')){ $self->update_or_insert_row( update=>1, table_name=>$table_name, rowdata_ref=>\%rowdata, PK=>"ID", PK_value=>$referring->getIdentifier, print_SQL=>1, testonly=>1, ); print "\n"; } #### If cardinality is 0..n or 1..n } elsif ($association->other->cardinality() eq CARD_0_TO_N || $association->other->cardinality() eq CARD_1_TO_N) { my $table_name = $referring->class_name() . $association->other->class_name() . '_link'; $table_name =~ s/.+:://; my $assn_name = $association->other->name(); my $referring_table_name = $referring->class_name(); $referring_table_name =~ s/.+:://; my %rowdata = ($referring_table_name.'_fk'=>$referring, $association->other->name().'_fk'=>$target_ID); $self->update_or_insert_row( insert=>1, table_name=>$table_name, rowdata_ref=>\%rowdata, print_SQL=>1, testonly=>1, ); print "\n"; #### Otherwise plead ignorance } else { print "Don't know what to do with this kind of cardinality yet!\n"; } } ############################################################################### # obj2database: write an object and all its children to the database ############################################################################### sub obj2database { my ($self,$handler,$obj) = @_; # all attributes are gathered into a hash my %attributes; my $data; foreach my $attribute ($obj->attribute_methods()) { my $attribute_val; { no strict 'refs'; my $getter_method = 'get'.ucfirst($attribute); $attribute_val = $obj->$getter_method(); if ($attribute eq 'cube') { $data = $self->flatten($attribute_val); $attribute_val = undef; } else { $attribute_val =~ s/\"/"/g; } } if (defined $attribute_val) { $attributes{$attribute} = $attribute_val; } } # the tag name is the name of the class my $tag = $obj->class_name(); $tag =~ s/.+:://; # we create the start tag, with the object attributes represented as # element attributes. If the object has no associations we make it # an empty element - this is to avoid XML validation errors my $empty = not scalar $obj->associations(); #$self->write_start_tag($tag,$empty,%attributes); #### Get the database handle and write the data to the database my $table_name = $tag; my $returned_PK; #### If the object has already been serialized if ($self->object_IDs($obj)) { #print "=== Okay, well, it appears that this guy was already written\n"; #print " so just sweep on without writing\n\n"; $returned_PK = $self->object_IDs($obj); #### Else write it to the database } else { $returned_PK = $self->update_or_insert_row( insert=>1, table_name=>$table_name, rowdata_ref=>\%attributes, PK=>"ID", return_PK=>1, print_SQL=>1, testonly=>1, ); #### Store the database autogen key to a lookup table: $self->object_IDs($obj,$returned_PK); print " --> returned ID = $returned_PK\n"; print "\n"; } #### Push some information about this object onto the stack push(@{$handler->object_stack},[$obj,$returned_PK]); # associations are handled as sub-elements of the current element # and we use the association meta-data to instruct how to represent # each association # # We use the IxHash module because the associations are ordered # in the same order the DTD expects to receive them, and IxHash # preserves insertion order tie my %assns_hash, 'Tie::IxHash', $obj->associations(); foreach my $association (keys %assns_hash) { my $association_obj; { no strict 'refs'; my $getter_method = 'get'.ucfirst($association); $association_obj = $obj->$getter_method(); } if (defined $association_obj) { # we first create the container tag with the proper prefix my $prefix; my $is_ref = $assns_hash{$association}->other->is_ref(); if ($is_ref) { $prefix = '_assnref'; } else { $prefix = '_assn'; } my @association_objects; my $cardinality = $assns_hash{$association}->other->cardinality(); if (($cardinality eq CARD_1_TO_N) || ($cardinality eq CARD_0_TO_N)) { $prefix .= 'list'; @association_objects = @{$association_obj}; } else { @association_objects = ($association_obj); } my $container_tag = ucfirst("$association$prefix"); # container tags must not be empty #$self->write_start_tag("$container_tag",my $cont_empty=0); #warn "2 $assns_hash{$association}"; push(@{$handler->assn_stack},[$assns_hash{$association}]); # now we fill in the container with the object(s) foreach $association_obj (@association_objects) { if ($is_ref) { #print "** assnref: ",$cardinality,"\n"; if ($cardinality eq CARD_1) { #print " == Cardinality is $cardinality\n"; #print " Need to update the referring with the fk\n"; #print " to the target object.\n"; $self->obj2database_ref($handler,$association_obj); } if ($cardinality eq CARD_0_OR_1) { #print " == Cardinality is $cardinality\n"; #print " Need to update the referring with the fk\n"; #print " to the target object.\n"; $self->obj2database_ref($handler,$association_obj); } if ($cardinality eq CARD_0_TO_N) { #print " == Cardinality is $cardinality\n"; #print " Need to add a row in a linking table, fk'ing\n"; #print " to both referring and target objects.\n\n"; $self->obj2database_ref($handler,$association_obj); } if ($cardinality eq CARD_1_TO_N) { #print " == Cardinality is $cardinality\n"; #print " Need to add a row in a linking table, fk'ing\n"; #print " to both referring and target objects.\n\n"; $self->obj2database_ref($handler,$association_obj); } } else { #print "** assn: ",$cardinality,"\n"; $self->obj2database($handler,$association_obj); } } # now end the container tag #$self->write_end_tag("$container_tag"); pop(@{$handler->assn_stack}); } } #### Special code for BioDataCube if (defined $data) { if ($self->external_data()) { my %attributes; $attributes{filenameURI} = $self->external_file_id(); my $tag = 'DataExternal_assn'; $self->write_start_tag($tag,my $empty=0); # we need to make it external { my $tag = 'DataExternal'; $self->write_start_tag($tag,my $empty=1,%attributes); open(DATA, ">$attributes{filenameURI}") or die "Couldn't open $attributes{filenameURI} for writing"; print DATA $data; close(DATA); } $self->write_end_tag($tag); } else { # we make it internal my $tag = 'DataInternal_assn'; $self->write_start_tag($tag,0); { my $tag = 'DataInternal'; $self->write_start_tag($tag,0); my $fh = $self->fh(); print $fh ""; $self->write_end_tag($tag); } $self->write_end_tag($tag); } } # now end the current element #$self->write_end_tag($tag) # unless $empty; pop(@{$handler->object_stack}); } ############################################################################### # obj2database_ref: write a reference object to the database ############################################################################### sub obj2database_ref { my ($self,$handler,$obj) = @_; # create the <*_ref> tag my $tag = $obj->class_name(); $tag =~ s/.+:://; $tag .= '_ref'; # we create the empty tag with only the identifier my $empty = 1; #$self->write_start_tag($tag,$empty,identifier=>$obj->getIdentifier()); my $table_name = $tag; $table_name =~ s/_ref$//; my $referring = $handler->object_stack->[-1]; my $association = $handler->assn_stack->[-1]; my $target_ID = $self->object_IDs($obj); unless (defined($target_ID)) { #print "+++ Yipe, the target object hasn't been written yet.\n"; #print " Try to write the object:\n"; $self->obj2database($handler,$obj); $target_ID = $self->object_IDs($obj); die "INTERNAL ERROR POS2: Failed to INSERT needed object $obj\n" unless (defined($target_ID)); } #print "referring: ",join(" , ",@{$referring}),"\n"; #print "assn: ",join(" , ",@{$association}),"\n"; #print "cardinality: ",$association->[0]->cardinality(),"\n"; #print "name: ",$association->[0]->name(),"\n"; #print "class_name: ",$association->[0]->class_name(),"\n"; #### If cardinality is 1 or 0..1 if ($association->[0]->other->cardinality() eq CARD_0_OR_1 || $association->[0]->other->cardinality() eq CARD_1) { my $table_name = $referring->[0]->class_name(); $table_name =~ s/.+:://; my $assn_name = $association->[0]->other->name(); my %rowdata = ($assn_name.'_fk'=>$target_ID); $self->update_or_insert_row( update=>1, table_name=>$table_name, rowdata_ref=>\%rowdata, PK=>"ID", PK_value=>$referring->[1], print_SQL=>1, testonly=>1, ); print "\n"; #### If cardinality is 0..n or 1..n } elsif ($association->[0]->other->cardinality() eq CARD_0_TO_N || $association->[0]->other->cardinality() eq CARD_1_TO_N) { my $table_name = $referring->[0]->class_name() . $association->[0]->other->class_name() . '_link'; $table_name =~ s/.+:://; my $assn_name = $association->[0]->other->name(); my $referring_table_name = $referring->[0]->class_name(); $referring_table_name =~ s/.+:://; my %rowdata = ($referring_table_name.'_fk'=>$referring->[1], $association->[0]->other->name().'_fk'=>$target_ID); $self->update_or_insert_row( insert=>1, table_name=>$table_name, rowdata_ref=>\%rowdata, print_SQL=>1, testonly=>1, ); print "\n"; #### Otherwise plead ignorance } else { print "Don't know what to do with this kind of cardinality yet!\n"; } } sub attr_indent { my $self = shift; if (@_) { $self->{__ATTR_INDENT} = shift; } return $self->{__ATTR_INDENT}; } sub attrs_on_one_line { my $self = shift; if (@_) { $self->{__ATTRS_ON_ONE_LINE} = shift; } return $self->{__ATTRS_ON_ONE_LINE}; } sub collapse_tag { my $self = shift; if (@_) { $self->{__COLLAPSE_TAG} = shift; } return $self->{__COLLAPSE_TAG}; } sub flatten { my ($self,$list) = @_; my @list; foreach my $item (@{$list}) { if (ref($item) eq 'ARRAY') { push(@list,$self->flatten($item)); } else { push(@list,$item); } } return join("\t",@list); } sub external_data { my $self = shift; if (@_) { $self->{__EXTERNAL_DATA} = shift; } return $self->{__EXTERNAL_DATA}; } sub external_file_id { my $self = shift; my $num = $self->external_data(); $num++; $self->external_data($num); return "external-data-$num.txt"; } sub incr_indent { my $self = shift; $self->indent_level($self->indent_level + $self->indent_increment); } sub decr_indent { my $self = shift; $self->indent_level($self->indent_level - $self->indent_increment); } sub indent_increment { my $self = shift; if (@_) { $self->{__INDENT_INCREMENT} = shift; } return $self->{__INDENT_INCREMENT}; } sub indent_level { my $self = shift; if (@_) { $self->{__INDENT_LEVEL} = shift; } return $self->{__INDENT_LEVEL}; } sub write_start_tag { my ($self,$tag,$empty,%attrs) = @_; my $indent = ' ' x $self->indent_level(); my $fh = $self->fh(); my (@attrs); foreach my $attribute_name (keys %attrs) { push(@attrs,qq[$attribute_name="$attrs{$attribute_name}"]); } my ($attrs,$attr_indent); if ($self->attrs_on_one_line()) { $attrs = join(' ',@attrs); } else { $attr_indent = $self->attr_indent(); $attr_indent = length($tag) + 2 unless defined $attr_indent; $attr_indent = ' ' x $attr_indent . $indent; $attrs = join("\n$attr_indent",@attrs); } if ($attrs) { print $fh "$indent<$tag $attrs"; } else { # don't print the space after the tag because Eric said so print $fh "$indent<$tag"; } if ($empty) { print $fh '/>'; } else { print $fh '>'; } print $fh "\n" unless $self->collapse_tag(); $self->incr_indent() unless $empty; } sub write_end_tag { my ($self,$tag) = @_; $self->decr_indent(); my $indent = ' ' x $self->indent_level(); my $fh = $self->fh(); print $fh "$indent\n"; } sub update_or_insert_row { my $self = shift || croak("parameter self not passed"); my %args = @_; #### Decode the argument list my $table_name = $args{'table_name'} || die "ERROR: table_name not passed"; my $rowdata_ref = $args{'rowdata_ref'} || die "ERROR: rowdata_ref not passed"; my $database_name = $args{'database_name'} || ""; my $return_PK = $args{'return_PK'} || 0; my $verbose = $args{'verbose'} || 0; my $print_SQL = $args{'print_SQL'} || 0; my $testonly = $args{'testonly'} || 0; my $insert = $args{'insert'} || 0; my $update = $args{'update'} || 0; my $PK = $args{'PK'} || ""; my $PK_value = $args{'PK_value'} || ""; my $quoted_identifiers = $args{'quoted_identifiers'} || "ON"; #### Make sure either INSERT or UPDATE was selected unless ( ($insert or $update) and (!($insert and $update)) ) { croak "ERROR: Need to specify either 'insert' or 'update'\n\n"; } #### If this is an UPDATE operation, make sure that we got the PK and value if ($update) { unless (defined($PK) and defined($PK_value)) { croak "ERROR: Need both PK and PK_value if operation is UPDATE. PK: $PK ; PK_value: $PK_value\n\n"; } } #### Initialize some variables my ($column_list,$value_list,$columnvalue_list) = ("","",""); my ($key,$value,$value_ref); #### Loops over each passed rowdata element, building the query while ( ($key,$value) = each %{$rowdata_ref} ) { #### If quoted identifiers is set, then quote the key $key = '"'.$key.'"'; #### If $value is a reference, assume it's a reference to a hash and #### extract the {value} key value. This is because of Xerces. $value = $value->{value} if (ref($value)); print " $key = $value\n" if ($verbose > 0); #### Add the key as the column name $column_list .= "$key,"; #### Enquote and add the value as the column value $value = $self->convertSingletoTwoQuotes($value); if (uc($value) eq "CURRENT_TIMESTAMP") { $value_list .= "$value,"; $columnvalue_list .= "$key = $value,\n"; } else { $value_list .= "'$value',"; $columnvalue_list .= "$key = '$value',\n"; } } unless ($column_list || 1) { print "ERROR: insert_row(): column_list is empty!\n"; return; } #### Chop off the final commas chop $column_list; chop $value_list; chop $columnvalue_list; # First the \n chop $columnvalue_list; # Then the comma #### Create the final table name my $full_table_name = "$database_name$table_name"; $full_table_name = '"'.$full_table_name.'"' if ($quoted_identifiers); #### Build the SQL statement my $sql; if ($update) { my $PK_tag = $PK; $PK_tag = '"'.$PK.'"' if ($quoted_identifiers); $sql = "UPDATE $full_table_name SET $columnvalue_list WHERE $PK_tag = '$PK_value'"; } else { $sql = "INSERT INTO $full_table_name ( $column_list ) VALUES ( $value_list )"; } print "$sql\n" if ($verbose > 0 || $print_SQL > 0); #### If we're just testing if ($testonly) { #### If the user asked for the PK to be returned, make a random one up if ($return_PK) { return int(rand()*1000); #### Otherwise, just return a 1 } else { return 1; } } #### Execute the SQL $self->executeSQL($sql); #### If user didn't want PK, return with success return "1" unless ($return_PK); #### If user requested the resulting PK, return it if ($update) { return $PK_value; } else { return $self->getLastInsertedPK(table_name=>"$database_name$table_name", PK_column_name=>"$PK"); } } ############################################################################### # convertSingletoTwoQuotes # # Converts all instances of a single quote to two consecutive single # quotes as wanted by an SQL string already enclosed in single quotes ############################################################################### sub convertSingletoTwoQuotes { my $self = shift; my $string = shift; return if (! defined($string)); return '' if ($string eq ''); return 0 unless ($string); my $resultstring = $string; $resultstring =~ s/'/''/g; ####' return $resultstring; } # end convertSingletoTwoQuotes sub object_IDs { my $self = shift; my($k,$v) = @_; if(defined $k and defined $v){ $self->{__OBJECT_IDS}->{$k} = $v; } elsif(defined $k){ return $self->{__OBJECT_IDS}->{$k}; } else { return $self->{__OBJECT_IDS}; } } 1; Bio-MAGE-Utils-20030502.0/MAGE/XML/Handler/ObjectHandlerI.pm0000644000175000017500000000166610501440055021703 0ustar jasonsjasonspackage Bio::MAGE::XML::Handler::ObjectHandlerI; use strict; use Bio::MAGE::Base; use base qw(Bio::MAGE::Base); our $VERSION = '0.99'; sub new { my $pack = shift; my $self = bless {}, $pack; $self->throw_not_implemented("new not defined for ".ref(caller())); } sub handle { my $self = shift; $self->throw_not_implemented("handle not defined for ".ref(caller())); } 1; __END__ =head1 NAME Bio::MAGE::XML::Handler::ObjectHandlerI - Abstract class for processing Bio::MAGE objects. =head1 SYNOPSIS my $objhandler; #get an Bio::MAGE::XML::ObjectHandlerI somehow my $handler; #get an Bio::MAGE::XML::Handler somehow my $reader; #get a Bio::MAGE::XML::Reader somehow $handler->objecthandler($objhandler); $reader->handler($handler) =head1 DESCRIPTION =head1 METHODS =head2 CONSTRUCTORS AND FRIENDS =head2 METHODS =head1 AUTHORS Copyright (c) 2002 Allen Day, =head1 SEE ALSO =cut Bio-MAGE-Utils-20030502.0/MAGE/XML/Handler/ContentHandler.pm0000644000175000017500000000154410501440055021771 0ustar jasonsjasons############################################################################### # ContentHandler package: Callbacks to process elements as they come # from the SAX2 parser ############################################################################### package Bio::MAGE::XML::Handler::ContentHandler; use strict; use vars qw(@ISA); @ISA = qw(XML::Xerces::PerlContentHandler Bio::MAGE::XML::Handler); sub start_element { my ($self,$uri,$localname,$qname,$attrs) = @_; my %attrs = $attrs->to_hash(); foreach my $key (keys %attrs) { $attrs{$key} = $attrs{$key}->{value}; } Bio::MAGE::XML::Handler::start_element($self,$localname,\%attrs); } sub end_element { my ($self,$uri,$localname,$qname) = @_; Bio::MAGE::XML::Handler::end_element($self,$localname); } sub characters { Bio::MAGE::XML::Handler::characters(@_); } 1; Bio-MAGE-Utils-20030502.0/MAGE/XML/Reader.pm0000644000175000017500000003214610472774401016724 0ustar jasonsjasons# # Bio::MAGE::XMLReader # a class for converting MAGE-ML into Perl objects # originally written by Eric Deutsch. Converted into a class # by Jason E. Stewart. # package Bio::MAGE::XML::Reader; use strict; use vars qw(@ISA @EXPORT @EXPORT_OK $DEBUG); use Carp; use XML::Xerces; require Exporter; use Data::Dumper; use Benchmark; use Bio::MAGE qw(:ALL); use Bio::MAGE::Base; use Carp; =head1 NAME Bio::MAGE::XML::Reader - a module for exporting MAGE-ML =head1 SYNOPSIS use Bio::MAGE::XML::Reader; my $reader = Bio::MAGE::XML::Reader->new(handler=>$handler, sax1=>$sax1, verbose=>$verbose, log_file=>\*STDERR, ); # set the sax1 attribute $reader->sax1($bool); # get the current value $value = $reader->sax1(); # set the content/document handler - this method is provided for completeness # the value should be set in the call to the constructor to be effective $reader->handler($HANDLER); # get the current handler $handler = $reader->handler(); # set the attribute $reader->verbose($integer); # get the current value $value = $reader->verbose(); # set the attribute $reader->log_file($filename); # get the current value $value = $reader->log_file(); # whether to read data cubes externally (default == FALSE) $writer->external_data($bool); my $fh = \*STDOUT; my $mage = $reader->read($file_name); =head1 DESCRIPTION Methods for transforming information from a MAGE-OM objects into MAGE-ML. =cut @ISA = qw(Bio::MAGE::Base Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT_OK = qw(); $DEBUG = 1; ############################################################################### # # Description : mageml_reader.pl is a MAGE-ML test reader. # It reads in a MAGE-ML document, instantiating the objects for # the # MAGE-OM class as they are read in. Lots of diagnostic # information # is printed if --verbose is set. In a final step, # a MAGE-ML document # is printed to STDOUT based on all the # information read in. The # result should be (nearly) identical # to the XML read in when # everything is working properly. # # Search for flags: # - FIXME for known bugs/shortcomings # - DUBIOUS for things that are probably okay but could lead # to future problems. # ############################################################################### =head2 ATTRIBUTE METHODS These methods have a polymorphic setter/getter method that sets an attribute which affects the parsing of MAGE-ML. If given a value, the method will save the value to the attribute, if invoked with no argument it will return the current value of the attribute. These attributes can all be set in the call to the constructor using the named parameter style. =over =item sax1 This attribute determines whether a SAX1 parser and DocumentHandler or a SAX2XMLReader and a ContentHandler will be used for parsing. The default is to use a SAX2 parser. =cut sub sax1 { my $self = shift; if (@_) { $self->{__SAX1} = shift; } return $self->{__SAX1}; } ############################################################################### # count: setter/getter for the scalar to track counting ouput ############################################################################### sub count { my $self = shift; if (scalar @_) { $self->{__COUNT} = shift; } return $self->{__COUNT}; } =item handler If an application needs a custom handler it can set this attribute in the call to the constructor. It is advised that the object use inherit either from Bio::MAGE::XML::Handler::ContentHandler (if using SAX2) or Bio::MAGE::DocumentHandler if using SAX1. In particular, whatever class is used, it needs to implement the following methods: =over =item * verbose called with the integer parameter that specifies the desired level of output =item * log_file called with the file handle to which ouput should be sent =item * init called during the constructor for any needed work =back =cut sub handler { my $self = shift; if (@_) { $self->{__HANDLER} = shift; } return $self->{__HANDLER}; } =head2 parser Title : parser Usage : $obj->parser($newval) Function: Example : Returns : value of parser (a scalar) Args : on set, new value (a scalar or undef, optional) =cut sub parser{ my $self = shift; return $self->{__PARSE} = shift if @_; return $self->{__PARSE}; } =item verbose This attribute determines the desired level of output during the parse. The default is no output. A positive value increases the amount of information. =cut sub verbose { my $self = shift; if (@_) { $self->{__VERBOSE} = shift; } return $self->{__VERBOSE}; } =item log_file This attribute specifies a file handle to which parse output will be directed. It is only needed if verbose is positive. =cut sub log_file { my $self = shift; if (@_) { $self->{__LOG_FILE} = shift; } return $self->{__LOG_FILE}; } =item external_data($bool) If defined, this will cause all BioAssayData objects to read themselves out using the DataExternal format. B false =cut sub external_data { my $self = shift; if (@_) { $self->{__EXTERNAL_DATA} = shift; } return $self->{__EXTERNAL_DATA}; } =item resolve_identifiers This attribute specifies whether the reader should attempt to track unhandled identifiers in the document, and then resolve them when parsing is over. This can be a huge performance hit if you know that all identifiers wil not resolve. B false =cut sub resolve_identifiers { my $self = shift; if (@_) { $self->{__RESOLVE_IDENTIFIERS} = shift; } return $self->{__RESOLVE_IDENTIFIERS}; } =pod =back =head2 INSTANCE METHODS =over =item $self->read($file_name) This method will open the MAGE-ML file specified by $file_name and if the C attribute is not set, it will create either a SAX2 parser or a SAX1 parser (depending on the value of the C attribute) and parse the file. C can read from STDIN by specifying '-' as the filename. This enables you to handle compressed XML files: gzip -dc file.xml.gz | read.pl [options] =cut sub read { my ($self,$file) = @_; unless ($file eq '-') { croak "File '$file' does not exist!\n" unless (-f $file); } my $parser = $self->parser(); my $HANDLER = $self->handler(); $HANDLER->count($self->count) if defined $self->count(); # my $LOG = $self->log_file(); my $LOG = new IO::File $self->log_file() , "w"; my $VERBOSE = $self->verbose(); #### Actually do the file parsing and loading if ($file eq '-') { $parser->parse (XML::Xerces::StdInInputSource->new()); } else { my ($path) = $file =~ m|(.*/)|; $HANDLER->dir($path) if defined $path; $parser->parse (XML::Xerces::LocalFileInputSource->new($file)); } #### Try to process any remaining unhandled objects. These are #### most likely to be references encountered before the #### definition of that referenced object, but they might be dangling #### references which are permitted with the hope that some other #### entity can provide the needed information at some later time. #### #### Deutsch says: I'm not really thrilled with this way of doing things. #### It's a legacy from v1 of this code. Couldn't we just check before #### instantiating an object to see if its identifier is already on the #### unhandled list and if so, don't even bother calling new() but rather #### flesh out the stub object into what it's really supposed to be? #### Deutsch continues: Maybe that wouldn't be any easier... leave it #### for now. DUBIOUS. #### #### Will this even work if there are multiple unresolved references #### of the same type? FIXME if not or remove this comment. print $LOG <resolve_identifiers) { my $UNHANDLED = $HANDLER->unhandled(); foreach my $identifier (keys %{$UNHANDLED}) { print $LOG "Looking for unhandled: $identifier\n" if ($VERBOSE); my $array_ref = $UNHANDLED->{$identifier}; #### Each item in unhandled is a three element array containing #### the object, classname and method that needs to be called to #### make the association foreach my $obj_array_ref (@{$array_ref}) { #### Obtain the object and method and classname my ($attribute,$object,$class) = @{$obj_array_ref}; #### If there now is an object with this identifier, make the link if (exists $HANDLER->id->{$class}->{$identifier}) { print $LOG "There now is corresponding object: $identifier\n" if ($VERBOSE); no strict 'refs'; #### If the place where the reference is supposed to be is in fact #### an array, this must be an array of references instead, so deal #### with that. This may be a performance hit if there are thousands #### of objects in the array, but it works for now. DUBIOUS my $value = $object->get_slot($attribute); if (ref($value) eq 'ARRAY') { #### So loop of each element in the array for (my $i=0;$i[$i]->getIdentifier() eq $identifier) { $value->[$i] = $HANDLER->id->{$class}->{$identifier}; } } #### Otherwise it's just a single reference so make the link directly } else { $object->set_slot($attribute,$HANDLER->id->{$class}->{$identifier}); } #### Delete the identifier from the unhandled list delete $UNHANDLED->{$identifier}; #### Otherwise this identifier must not be in the document which #### is allowed. It may mean that the data are just stored someplace #### else, or that it could indicate a mistake. } else { print STDERR "WARNING: There is an unresolved ". "$attribute '$identifier'\n" if ($VERBOSE); } } } } #### If we're verbose mode, print $LOG out a good bit of information #### about what's sitting in the HANDLER hash if ($VERBOSE) { print $LOG "\n-------------------------------------------------\n"; my ($key,$value); my ($key2,$value2); #### Print $LOG out all the items in the HANDLER hash print $LOG "HANDLER:\n"; while (($key,$value) = each %{$HANDLER}) { print $LOG "HANDLER->{$key} = $value:\n"; } print $LOG "\n"; #### Loop over the various items in the HANDLER hash #### and print $LOG out details about them while (($key,$value) = each %{$HANDLER}) { print $LOG "HANDLER->{$key}\n"; if ($key eq "__ID" or $key eq "__UNHANDLED") { while (($key2,$value2) = each %{$HANDLER->{$key}}) { print $LOG " $key2 = $value2\n"; } } elsif ($key eq "__OBJ_STACK" or $key eq "__ASSN_STACK") { foreach $key2 (@{$HANDLER->{$key}}) { print $LOG " $key2\n"; } } elsif ($key eq '__MAGE' || $key eq '__CLASS2FULLCLASS' || $key eq '__DIR' || $key eq '__READER') { #### Skip those ones #### __DIR and __READER must be an array reference but they are not (__DIR : scalar ; __READER : HASH ref) } else { foreach $key2 (@{$HANDLER->{$key}}) { print $LOG " $key2\n"; } } } } #### Obtain the MAGE object from the HANDLER my $mage = $HANDLER->MAGE(); #### If there was no MAGE object defined, die unless ($mage) { croak < tag! This should never happen. complain to your MAGE-ML provider. ERR } return $mage; } sub initialize { my $self = shift; my $HANDLER; my $parser; $self->verbose(0) unless $self->verbose(); # Added by Mohammad on 19/11/03 shoja@ebi.ac.uk , Change begin $self->external_data(0) unless defined $self->external_data(); # Added by Mohammad on 19/11/03 shoja@ebi.ac.uk , Change end if ($self->sax1) { $parser = XML::Xerces::SAXParser->new(); $parser->setValidationScheme($XML::Xerces::SAXParser::Val_Always); $parser->setDoNamespaces(0); $parser->setDoSchema(0); if (defined $self->handler()) { $HANDLER = $self->handler(); } else { $HANDLER = Bio::MAGE::XML::Handler::DocumentHandler->new(); $self->handler($HANDLER); } $parser->setDocumentHandler($HANDLER); } else { $parser = XML::Xerces::XMLReaderFactory::createXMLReader(); $parser->setFeature("http://xml.org/sax/features/namespaces", 0); $parser->setFeature("http://xml.org/sax/features/validation", 1); $parser->setFeature("http://apache.org/xml/features/validation/dynamic", 0); if (defined $self->handler()) { $HANDLER = $self->handler(); } else { $HANDLER = Bio::MAGE::XML::Handler::ContentHandler->new(); $self->handler($HANDLER); } $parser->setContentHandler($HANDLER); } $self->resolve_identifiers(1) unless defined $self->resolve_identifiers; # this way the handler can access our attributes (verbose, log_file, etc) $HANDLER->reader($self); $HANDLER->init(); my $error_handler = XML::Xerces::PerlErrorHandler->new(); $parser->setErrorHandler($error_handler); $self->parser($parser); return 1; } =pod =back =cut 1; Bio-MAGE-Utils-20030502.0/MAGE/XML/Handler.pm0000644000175000017500000007045310472774401017102 0ustar jasonsjasons############################################################################### # Bio::MAGE::Handler package: Callbacks to process elements as they come # from the SAX or SAX2 parser ############################################################################### package Bio::MAGE::XML::Handler; use strict; use Data::Dumper; use IO::File; # import the cardinality constants use Bio::MAGE::Association qw(:CARD); ############################################################################### # new: initialize the content handler ############################################################################### sub init { my $self = shift; $self->object_stack([]); $self->assn_stack([]); $self->unhandled({}); $self->id({}); } sub reader { my $self = shift; if (scalar @_) { $self->{__READER} = shift; } return $self->{__READER}; } sub dir { my $self = shift; if (scalar @_) { $self->{__DIR} = shift; } return $self->{__DIR}; } ############################################################################### # object_stack: setter/getter for the stack on which objects are placed ############################################################################### sub object_stack { my $self = shift; #### If an argument was supplied (should be an array ref), set it if (scalar @_) { $self->{__OBJ_STACK} = shift; } #### Return a reference to the stack return $self->{__OBJ_STACK}; } ############################################################################### # assn_stack: setter/getter for the stack on which associations are placed ############################################################################### sub assn_stack { my $self = shift; #### If an argument was supplied (should be an array ref), set it if (scalar @_) { $self->{__ASSN_STACK} = shift; } #### Return a reference to the stack return $self->{__ASSN_STACK}; } ############################################################################### # unhandled: setter/getter for the hash into which unhandled references # are placed ############################################################################### sub unhandled { my $self = shift; #### If an argument was supplied (should be a hash ref), set it if (scalar @_) { $self->{__UNHANDLED} = shift; } #### Return a reference to the hash return $self->{__UNHANDLED}; } ############################################################################### # count: setter/getter for the scalar to track counting ouput ############################################################################### sub count { my $self = shift; if (scalar @_) { $self->{__COUNT} = shift; } return $self->{__COUNT}; } ############################################################################### # num_tabs: setter/getter for the scalar to track number of tags processed ############################################################################### sub num_tags { my $self = shift; if (scalar @_) { $self->{__NUM_TAGS} = shift; } return $self->{__NUM_TAGS}; } sub MAGE { my $self = shift; if (scalar @_) { $self->{__MAGE} = shift; } return $self->{__MAGE}; } sub id { my $self = shift; if (scalar @_) { $self->{__ID} = shift; } return $self->{__ID}; } sub data { my $self = shift; if (scalar @_) { $self->{__PRIVATE}{DATA} = shift; } return $self->{__PRIVATE}{DATA}; } sub class2fullclass { my $self = shift; if (scalar @_) { $self->{__CLASS2FULLCLASS} = shift; } return $self->{__CLASS2FULLCLASS}; } =pod =item start_element_objecthandler($handler) Use this method to get/set the start handler that will be called to process Bio::MAGE objects as they are created. $handler must be instances of the Bio::MAGE::XMLUtils::ObjectHandlerI class. Calling start_element objecthandler() with no arguments returns a reference to the currently registered Bio::MAGE::XMLUtils::ObjectHandlerI object. =cut sub start_element_objecthandler { my $self = shift; if (@_) { $self->{__SE_OBJHANDLER} = shift; } return $self->{__SE_OBJHANDLER}; } =pod =item end_element_objecthandler($handler) Use this method to get/set the end handler that will be called to process Bio::MAGE objects as they are finished (when the end tag event occurs. $handler must be instances of the Bio::MAGE::XMLUtils::ObjectHandlerI class. Calling end_element_objecthandler() with no arguments returns a reference to the currently registered Bio::MAGE::XMLUtils::ObjectHandlerI object. =cut sub end_element_objecthandler { my $self = shift; if (@_) { $self->{__EE_OBJHANDLER} = shift; } return $self->{__EE_OBJHANDLER}; } =pod =item character_objecthandler($handler) Use this method to get/set the start handler that will be called to process character data as it is . $handler must be instances of the Bio::MAGE::XMLUtils::ObjectHandlerI class. Calling character_objecthandler() with no arguments returns a reference to the currently registered Bio::MAGE::XMLUtils::ObjectHandlerI object. =cut sub character_objecthandler { my $self = shift; if (@_) { $self->{__C_OBJHANDLER} = shift; } return $self->{__C_OBJHANDLER}; } ############################################################################### # handle_ref ############################################################################### sub handle_ref { my ($self,$class,$identifier) = @_; #### Determine the full class name from the class my $full_class_name = $self->class2fullclass->{$class}; #### Try to obtain the object that is referenced my $obj = $self->id->{$full_class_name}->{$identifier}; #### If the referenced object doesn't exist, then create a new object #### with that name with the hope that we'll find it later in the document, #### and if we don't, we'll still be left with an empty object of the #### appropriate type unless (defined $obj) { #### Get the object expecting resolution my $expecting_obj = $self->object_stack->[-1]; #### Get the name of the container my $method = lcfirst($self->assn_stack()->[-1]->other->name) || die "ASSN_STACK doesn't have $identifier on top!"; #### return a reference to an otherwise empty object with just the #### correct identifier and suitably obtuse name $obj = $full_class_name->new(identifier=>$identifier); if ($self->reader->resolve_identifiers) { #### Push it on the unhandled list so that we know what all the problem #### references are for later resolution or reporting push(@{$self->unhandled->{$identifier}}, [$method,$expecting_obj,$full_class_name]); } } #### Return the object return $obj; } ############################################################################### # get_quantitation_type_dimension ############################################################################### sub get_quantitation_type_dimension { my ($self) = @_; my $bioassay = $self->object_stack->[-2]; die "Expected BioAssayData but got: $bioassay" unless $bioassay->isa('Bio::MAGE::BioAssayData::BioAssayData'); return scalar @{$bioassay->getQuantitationTypeDimension->getQuantitationTypes()}; } ############################################################################### # get_design_element_dimension ############################################################################### sub get_design_element_dimension { my ($self) = @_; my $bioassaydata = $self->object_stack->[-2]; die "Expected BioAssayData but got: $bioassaydata" unless $bioassaydata->isa('Bio::MAGE::BioAssayData::BioAssayData'); # Added by Mohammad on 20/11/03 shoja@ebi.ac.uk , Change begin # Should have the following control to get the right stuff. my $ded = $bioassaydata->getDesignElementDimension(); if ($ded->isa('Bio::MAGE::BioAssayData::FeatureDimension')) { return scalar @{$bioassaydata->getDesignElementDimension->getContainedFeatures()}; } elsif ($ded->isa('Bio::MAGE::BioAssayData::ReporterDimension')) { return scalar @{$bioassaydata->getDesignElementDimension->getReporters()}; } elsif ($ded->isa('Bio::MAGE::BioAssayData::CompositeSequenceDimension')) { return scalar @{$bioassaydata->getDesignElementDimension->getCompositeSequences()}; } #### Otherwise, confess we don't know what to do with this type of element #### This should never happen else { die "ERROR: Unknown DesignElementDimension\n"; } # Added by Mohammad on 20/11/03 shoja@ebi.ac.uk , Change end } ############################################################################### # get_bioassay_dimension ############################################################################### sub get_bioassay_dimension { my ($self) = @_; my $bioassay = $self->object_stack->[-2]; die "Expected BioAssayData but got: $bioassay" unless $bioassay->isa('Bio::MAGE::BioAssayData::BioAssayData'); return scalar @{$bioassay->getBioAssayDimension->getBioAssays()}; } ############################################################################### # get_cube ############################################################################### sub get_cube { my ($self,$order,$string) = @_; my %index; $index{B} = $self->get_bioassay_dimension(); $index{Q} = $self->get_quantitation_type_dimension(); $index{D} = $self->get_design_element_dimension(); my ($a,$b,$c) = split('', $order); my ($i_lim,$j_lim,$k_lim); $i_lim = $index{$a}; $j_lim = $index{$b}; $k_lim = $index{$c}; my @bad; $string =~ s/\n/\t/g; my @list = split("\t",$string); for (my $i=0;$i<$i_lim;$i++) { my $ded = []; for (my $j=0;$j<$j_lim;$j++) { my $qtd = []; for (my $k=0;$k<$k_lim;$k++) { my $item = shift(@list); $item =~ s/&space;/ /g; push(@{$qtd},$item); } push(@{$ded},$qtd); } push(@bad,$ded); } return \@bad; } ############################################################################### # characters: SAX callback function for handling character data in an element ############################################################################### sub characters { my ($self,$string,$len) = @_; #flag whether or not the object handler has accepted the request #to handle the object. my $rc = 1; #try to handle the object externally if(defined $self->character_objecthandler){ $rc = $self->character_objecthandler->handle($self,$self->object_stack->[-1]); } #if the object hasn't been handled ($rc still == 1), attach the object #to its parent. if($rc){ # print $self->reader->log_file() "Characters called with $len characters\n"; return unless exists $self->{__PRIVATE}{DATA}; $self->{__PRIVATE}{DATA} .= $string; } } ############################################################################### # start_element: SAX callback function for handling a XML start element ############################################################################### sub start_element { my ($self,$localname,$attrs) = @_; if (defined $self->count) { my $tags = $self->num_tags() + 1; $self->num_tags($tags); print STDERR "$tags\n" if $tags % $self->count == 0; } #### Dereference the attributes hash my %attrs = %{$attrs}; # my $LOG = $self->reader->log_file(); my $LOG = new IO::File $self->reader->log_file(),"w"; my $VERBOSE = $self->reader->verbose(); #### Special handling for DataInternal or DataExternal (ie, nastiness) my $filename_uri; if ($localname eq 'DataInternal') { $self->{__PRIVATE}{DATA} = ''; return; } elsif ($localname eq 'DataExternal') { # we had to wait until we had pushed the tag onto the object stack if ($attrs{filenameURI}) { local $/; # enable slurp mode my $file; $file = $self->dir() . '/' if $self->dir; $file .= $attrs{filenameURI}; open(DATA, $file) or die "Couldn't open $file for reading"; my $bio_data_cube = $self->object_stack->[-1]; die "Expected a Bio::MAGE::BioAssayData::BioDataCube but got $bio_data_cube" unless $bio_data_cube->isa('Bio::MAGE::BioAssayData::BioDataCube'); # $bio_data_cube->setCube($self->get_cube($attrs{order},$data)); # $bio_data_cube->setCube($self->get_cube($bio_data_cube->getOrder,$data)); # Added by Mohammad on 19/11/03 shoja@ebi.ac.uk , Change begin # This assist us to read external files AS IS if (!$self->reader->external_data) { my $data = ; # slurp whole file $bio_data_cube->setCube($self->get_cube($bio_data_cube->getOrder,$data)); } else { $bio_data_cube->setOrder($bio_data_cube->getOrder); $bio_data_cube->setCube($attrs{filenameURI}); } # Added by Mohammad on 19/11/03 shoja@ebi.ac.uk , Change end #warn Dumper($bio_data_cube->getCube); } return; } elsif (scalar @{$self->object_stack} and UNIVERSAL::isa($self->object_stack->[-1], 'Bio::MAGE::BioAssayData::BioDataTuples')) { # Handle BioDataTuples # if we're a <*_ref>, keep track of the element if ($localname =~ /_ref/) { #### Determine the name of the referenced class my $refclass = $localname; $refclass =~ s/_ref$//; my $refinstance = $self->handle_ref($refclass,$attrs{identifier}); my $key; if ($refinstance->isa('Bio::MAGE::BioAssay::BioAssay')) { $key = 'bioAssay'; } elsif ($refinstance->isa('Bio::MAGE::QuantitationType::QuantitationType')) { $key = 'quantitationType'; } elsif ($refinstance->isa('Bio::MAGE::DesignElement::DesignElement')) { $key = 'designElement'; } else { die "Bad ref element when handling BioDataTuples: $localname, with id: $attrs{identifier}"; } $self->{__PRIVATE}{BioDataTuples}{$key} = $refinstance; } elsif ($localname eq 'Datum') { # if we're a add it $attrs{bioAssay} = $self->{__PRIVATE}{BioDataTuples}{bioAssay}; $attrs{quantitationType} = $self->{__PRIVATE}{BioDataTuples}{quantitationType}; $attrs{designElement} = $self->{__PRIVATE}{BioDataTuples}{designElement}; foreach my $key (qw(value bioAssay designElement quantitationType)) { die "No $key defined for datum" unless defined $attrs{$key}; } my $obj = Bio::MAGE::BioAssayData::BioAssayDatum->new(%attrs); $self->object_stack->[-1]->addBioAssayTupleData($obj); } return; } #### Top level tag MAGE-ML signals creation of MAGE object if ($localname eq 'MAGE-ML') { print $LOG "<$localname> Begin the MAGE-ML document\n" if ($VERBOSE); #### Simply create the MAGE object with the supplied attributes $self->MAGE(Bio::MAGE->new(%attrs)); #### Obtain the full class path lookup hash and store it for reuse $self->class2fullclass({Bio::MAGE->class2fullclass}); #### Add the MAGE object to the stack push(@{$self->object_stack},$self->MAGE); #### If there's no underscore in the tag, it must be a class #### This seems a little flimsy, but as long as the OM/ML follows this #### convention, this will work. DUBIOUS. } elsif ($localname !~ /_/) { print $LOG "\n<$localname> has attributes:\n" if ($VERBOSE); #try to handle the object externally. note that $rc is not really paid #attention to, because we may need object again if there is an #object handler registered with end_element_objecthandler. now, #we can do a test for the end_element_objecthandler... this is an #incomplete thought. if(defined $self->start_element_objecthandler){ my $rc = $self->start_element_objecthandler->handle($self,$self->object_stack->[-1]); } #### Determine the parent object (if there is one) my $parent = $self->object_stack->[-1]; #### Determine the full class name from the class my $class = $self->class2fullclass->{$localname}; #### Create the object and push it onto object stack my $instance = $class->new(%attrs); push(@{$self->object_stack},$instance); print $LOG " I am $instance\n" if ($VERBOSE); #### If object is identifiable, then add its identifier to ID hash if ($instance->isa('Bio::MAGE::Identifiable')) { #### For the moment, we have made the rule that any single document #### must have all totally unique identifiers. We crash if this #### is ever violated. DUBIOUS. if ($self->id->{$class}->{$attrs{identifier}}) { die "ERROR: duplicate identifier '$attrs{identifier}'." . "Identifiers must be unique for a given class within a document!\n"; #### Add this object to the ID hash under its indentifier } else { $self->id->{$class}->{$attrs{identifier}} = $instance; } } #### Print $LOG out the associations for this class for fun if very verbose if ($VERBOSE > 1) { my ($association,$key,$value); my %associations = $instance->associations(); print $LOG " and also has associations: \n"; while ( ($key,$value) = each %associations) { print $LOG "\t$key = $value\n"; } } #### Otherwise, if the tag is a "_package" then just register it with #### the CONTENT_HANDLER and push it onto the object stack. } elsif ($localname =~ /_package$/) { print $LOG "\n<$localname> is package\n" if ($VERBOSE); #### Determine the class and create the object my $method = 'get' . $localname; my $instance = $self->MAGE->$method(); #### Add the Package object to the stack push(@{$self->object_stack},$instance); #### If the tag is a _assn, _assnlist, _assnref, or assnreflist #### push the object onto the assn_stack for later use } elsif ($localname =~ /_assn/){ #_assn #_assnlist #_assnref #_assnreflist my $assn; my $assn_name = $localname; $assn_name =~ s/_.*//; $assn_name = lcfirst($assn_name); #### #I'm not sure what I'm doing here, but it seems to have resolved a problem that there was a missing "End" object #when parsing a DataExternal_assn element. Whether or not it does what it is supposed to, I don't know, but I no longer #get runtime exceptions. my %associations = $self->object_stack->[-1]->can('associations') ? $self->object_stack->[-1]->associations : (); $assn = $associations{$assn_name}; if(!defined($assn)){ my $other = new Bio::MAGE::Association::End(name=>$assn_name, cardinality=>Bio::MAGE::Association::CARD_0_TO_N, ); $assn = new Bio::MAGE::Association(other=>$other); } #### # if($self->object_stack->[-1]->can('associations')){ # my %associations = $self->object_stack->[-1]->associations; # $assn = $associations{$assn_name}; # } else { # my $other = new Bio::MAGE::Association::End(name=>$assn_name, # cardinality=>Bio::MAGE::Association::CARD_0_TO_N, # ); # $assn = new Bio::MAGE::Association(other=>$other); # } #### push(@{$self->assn_stack},$assn); #### If the tag is a "_ref" then we need to store the reference(s) in #### the parent object } elsif ($localname =~ /_ref$/) { print $LOG "\n<$localname> is a reference\n" if ($VERBOSE); #### Determine the name of the referenced class my $refclass = $localname; $refclass =~ s/_ref$//; #### Determine the parent object my $parent = $self->object_stack->[-1]; print $LOG "\tMy parent is $parent\n" if ($VERBOSE); #### Get the instance of the referenced object. This function #### will always return something even if it has to create a dummy #### object to refer to. my $refinstance = $self->handle_ref($refclass,$attrs{identifier}); #### Get the information about the container assn my $assn = $self->assn_stack()->[-1]; #### Determine the method name used to store the reference(s) my $method = 'add' . ucfirst($assn->other->name); #### If only a single reference is allowed, then just set it if( $assn->other->cardinality eq Bio::MAGE::Association::CARD_1 or $assn->other->cardinality eq Bio::MAGE::Association::CARD_0_OR_1 ){ $method = 'set'. ucfirst($assn->other->name); print $LOG "\tSet parent's attribute $method = $refinstance\n" if ($VERBOSE); { no strict 'refs'; $self->object_stack->[-1]->$method($refinstance); } #### If multiple references are allowed, store the list as an array } elsif ( $assn->other->cardinality eq Bio::MAGE::Association::CARD_1_TO_N or $assn->other->cardinality eq Bio::MAGE::Association::CARD_0_TO_N ) { $method = 'add'. ucfirst($assn->other->name); print $LOG "\tAdd parent's attribute $method = $refinstance\n" if ($VERBOSE); { no strict 'refs'; $self->object_stack->[-1]->$method($refinstance); } #### If neither SINGLE or LIST, we're hopelessly confused } else { die "ERROR: Unknown cardinality: '$assn->other->cardinality'\n"; } #### Otherwise, confess we don't know what to do with this type of element #### This should never happen } else { die "ERROR: <$localname> Don't know what to do with <$localname>\n"; } } ############################################################################### # end_element: SAX callback function for handling a XML end element ############################################################################### sub end_element { my ($self,$localname) = @_; #### Special case of BioDataCube data if ($localname eq 'DataExternal') { return; } elsif ($localname eq 'DataInternal') { my $bio_data_cube = $self->object_stack->[-1]; die "Expected a Bio::MAGE::BioDataCube but got $bio_data_cube" unless $bio_data_cube->isa('Bio::MAGE::BioAssayData::BioDataCube'); $bio_data_cube->setCube($self->get_cube($self->{__PRIVATE}{DATA})); delete $self->{__PRIVATE}{DATA}; return; } elsif ($localname eq 'BioDataTuples') { delete $self->{__PRIVATE}{BioDataTuples} } elsif (scalar @{$self->object_stack} and UNIVERSAL::isa($self->object_stack->[-1], 'Bio::MAGE::BioAssayData::BioDataTuples')) { # do nothing return; } # my $LOG = $self->reader->log_file(); my $LOG = new IO::File $self->reader->log_file(),"w"; my $VERBOSE = $self->reader->verbose(); #### If finishing a _assn* element, pop it off the assn_stack if (($localname =~ /_assn$/ or $localname =~ /_assnlist$/ or $localname =~ /_assnref$/ or $localname =~ /_assnreflist$/ ) # and $localname !~ /DataExternal/ #is this reasonable??? -allen ) { #warn $localname; #### Determine the association name my $assn = $self->assn_stack()->[-1]; #warn $localname unless defined $assn; #warn Dumper($self->assn_stack()) unless defined $assn; #warn Dumper($self->assn_stack()->[-1]) unless defined $assn; my $assn_name = $assn->other->name; $assn_name =~ s/_assn[a-z]*$//; #### If there's something on the stack if (scalar @{$self->assn_stack()}) { #### If the top object on the stack is the correct one, pop it off if ($self->assn_stack()->[-1]->other->name eq $assn_name) { pop(@{$self->assn_stack}); #### Otherwise, die bitterly } else { my $problem = $self->assn_stack()->[-1]->other->name; die "ERROR: Wanted to pop '$assn_name' off the ASSN_STACK, ". "but instead I found '$problem'! ". "This should never happen.\n"; } #### but if there's nothing on the stack and we got here, die bitterly } else { die "ERROR: Wanted to pop '$assn_name' off the ASSN_STACK, ". "but there's nothing on the stack at all! ". "This should never happen.\n"; } #### If finishing a _package element, pop it off the object_stack } elsif ($localname =~ /_package$/ ) { #### Determine the association name my $instance = $self->object_stack()->[-1]; my $package_name = $localname; $package_name =~ s/_package$//; $package_name = "Bio::MAGE::$package_name"; #### If there's something on the stack if (scalar @{$self->object_stack()}) { #### If the top object on the stack is the correct one, pop it off if (ref($self->object_stack()->[-1]) eq $package_name) { pop(@{$self->object_stack}); #### Otherwise, die bitterly } else { my $problem = ref $self->object_stack()->[-1]; die "ERROR: Wanted to pop '$package_name' off the OBJECT_STACK, ". "but instead I found '$problem'! ". "This should never happen.\n"; } #### but if there's nothing on the stack and we got here, die bitterly } else { die "ERROR: Wanted to pop '$package_name' off the OBJECT_STACK, ". "but there's nothing on the stack at all! ". "This should never happen.\n"; } #### Otherwise see if it's just a plain object #### This is based on the assumption that plain objects have no #### underscores!! DUBIOUS } elsif ($localname =~ /MAGE-ML/) { if (scalar @{$self->object_stack()}){ #### If the top object on the stack is the correct one, pop it off if (ref $self->object_stack->[-1] eq 'Bio::MAGE') { pop(@{$self->object_stack}); ### check that object stack is now empty if (scalar @{$self->object_stack}) { my $count = scalar @{$self->object_stack}; my $problem = ref $self->object_stack->[-1]; die <object_stack->[-1]; die <object_stack()}){ #### Determine the full class name from the class my $full_class_name = $self->class2fullclass->{$localname}; #### If the top object on the stack is the correct one, pop it off if ($self->object_stack->[-1]->class_name eq $full_class_name) { #flag whether or not the object handler has accepted the request #to handle the object. my $rc = 1; #try to handle the object externally if(defined $self->end_element_objecthandler){ $rc = $self->end_element_objecthandler->handle($self,$self->object_stack->[-1]); } #if the object hasn't been handled ($rc still == 1), attach the object #to its parent. if($rc){ my $instance = $self->object_stack()->[-1]; #### Determine the parent object (if there is one) my $parent = $self->object_stack->[-2]; #### If we have a parent, then associate with it if ($parent) { #### Get the information about the container assn my $assn = $self->assn_stack()->[-1]; print $LOG " and has parent $parent\n" if ($VERBOSE); #### If only a single reference is allowed, then just set it if( $assn->other->cardinality eq Bio::MAGE::Association::CARD_1 or $assn->other->cardinality eq Bio::MAGE::Association::CARD_0_OR_1 ){ my $method = 'set'. ucfirst($assn->other->name); print $LOG " so set parent attribute $method = $instance\n" if ($VERBOSE); $self->object_stack->[-2]->$method($instance); #### If multiple references are allowed, store the list as an array } elsif ( $assn->other->cardinality eq Bio::MAGE::Association::CARD_1_TO_N or $assn->other->cardinality eq Bio::MAGE::Association::CARD_0_TO_N ) { my $method = 'add'. ucfirst($assn->other->name); $self->object_stack->[-2]->$method($instance); #### If neither SINGLE or LIST, we're hopelessly confused } else { die "INTERNAL ERROR: Unknown cardinality: '$assn->other->cardinality'\n"; } #### Otherwise, if there's no parent, die } else { die <object_stack}); #### Otherwise, die bitterly } else { my $problem = $self->object_stack->[-1]->class_name; die "ERROR: Wanted to pop '$full_class_name' off the ". "OBJECT_STACK, but instead I found '$problem'! ". "This should never happen.\n"; } #### but if there's nothing on the stack and we got here, die bitterly } else { die < '1'; use constant CARD_0_OR_1 => '0..1'; use constant CARD_1_TO_N => '1..N'; use constant CARD_0_TO_N => '0..N'; =head1 NAME Bio::MAGE::SQLWriter - a module for exporting MAGE-OM objects to a database =head1 SYNOPSIS use Bio::MAGE::SQLWriter; my $writer = Bio::MAGE::SQLWriter->new(@args); use dbhandle; my $dbhandle = dbhandle->new(); $writer->obj2database($dbhandle,@object_list); =head1 DESCRIPTION Methods for transforming information from a MAGE-OM objects into tuples in a MAGE database. =cut @ISA = qw(Bio::MAGE::Base Exporter); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT_OK = qw(obj2database); $DEBUG = 1; sub indent_level { my $self = shift; if (@_) { $self->{__INDENT_LEVEL} = shift; } return $self->{__INDENT_LEVEL}; } sub indent_increment { my $self = shift; if (@_) { $self->{__INDENT_INCREMENT} = shift; } return $self->{__INDENT_INCREMENT}; } sub attrs_on_one_line { my $self = shift; if (@_) { $self->{__ATTRS_ON_ONE_LINE} = shift; } return $self->{__ATTRS_ON_ONE_LINE}; } sub attr_indent { my $self = shift; if (@_) { $self->{__ATTR_INDENT} = shift; } return $self->{__ATTR_INDENT}; } sub collapse_tag { my $self = shift; if (@_) { $self->{__COLLAPSE_TAG} = shift; } return $self->{__COLLAPSE_TAG}; } sub encoding { my $self = shift; if (@_) { $self->{__ENCODING} = shift; } return $self->{__ENCODING}; } sub public_id { my $self = shift; if (@_) { $self->{__PUBLIC_ID} = shift; } return $self->{__PUBLIC_ID}; } sub system_id { my $self = shift; if (@_) { $self->{__SYSTEM_ID} = shift; } return $self->{__SYSTEM_ID}; } sub generate_identifier { my $self = shift; if (@_) { $self->{__GENERATE_IDENTIFIER} = shift; } return $self->{__GENERATE_IDENTIFIER}; } sub generate_new_identifiers { my $self = shift; if (@_) { $self->{__GENERATE_NEW_IDENTIFIERS} = shift; } return $self->{__GENERATE_NEW_IDENTIFIERS}; } sub indent_level { my $self = shift; if (@_) { $self->{__INDENT_LEVEL} = shift; } return $self->{__INDENT_LEVEL}; } sub external_data { my $self = shift; if (@_) { $self->{__EXTERNAL_DATA} = shift; } return $self->{__EXTERNAL_DATA}; } ############################################################################### # fh: setter/getter for the file handle ############################################################################### sub fh { my $self = shift; if (@_) { $self->{__FH} = shift; } return $self->{__FH}; } ############################################################################### # dbhandle: setter/getter for the database handle ############################################################################### sub dbhandle { my $self = shift; if (@_) { $self->{__DBHANDLE} = shift; } return $self->{__DBHANDLE}; } ############################################################################### # object_stack: setter/getter for the stack on which objects are placed ############################################################################### sub object_stack { my $self = shift; if (@_) { $self->{__OBJECT_STACK} = shift; } return $self->{__OBJECT_STACK}; } ############################################################################### # assn_stack: setter/getter for the stack on which assn's are placed ############################################################################### sub assn_stack { my $self = shift; if (@_) { $self->{__ASSN_STACK} = shift; } return $self->{__ASSN_STACK}; } ############################################################################### # object_IDs: setter/getter for the hash table which holds database ID's ############################################################################### sub object_IDs { my $self = shift; if (@_) { $self->{__OBJECT_IDS} = shift; } return $self->{__OBJECT_IDS}; } sub identifier { my $self = shift; if (@_) { $self->{__IDENTIFIER} = shift; } return $self->{__IDENTIFIER}; } sub initialize { my ($self) = shift; $self->indent_increment(2); $self->indent_level(0); $self->external_data(0) unless defined $self->external_data(); $self->encoding('ISO-8859-1') unless defined $self->encoding(); $self->system_id('MAGE-ML.dtd') unless defined $self->system_id(); $self->generate_identifier(sub {$self->identifier_generatation(shift)}) unless defined $self->generate_identifier(); $self->generate_new_identifiers(0) unless defined $self->generate_new_identifiers(); #### Initialize the various stacks and lookup tables $self->object_stack([]); $self->assn_stack([]); $self->object_IDs({}); } sub incr_indent { my $self = shift; $self->indent_level($self->indent_level + $self->indent_increment); } sub decr_indent { my $self = shift; $self->indent_level($self->indent_level - $self->indent_increment); } =head1 METHODS =item write($MAGE_object); C prints the objects contained in $MAGE_object as MAGE-ML to the file handle used by the writer. =cut sub write { my ($self,$top_level_obj) = @_; die "Bio::MAGE::SQLWriter::write: must specify a file handle and a ". "database handle for output" unless ((defined $self->fh()) && (defined $self->dbhandle())); # handle the basics #$self->write_xml_decl(); #$self->write_doctype(); $top_level_obj->obj2database($self); } sub write_xml_decl { my $self = shift; my $fh = $self->fh(); my $encoding = $self->encoding(); print $fh <<"MAGEML"; MAGEML } sub write_doctype { my $self = shift; my $public_id = $self->public_id(); my $PUBLIC; if (defined $public_id) { $PUBLIC = qq[PUBLIC "$public_id"]; } else { $PUBLIC = ''; } my $system_id = $self->system_id(); my $SYSTEM = qq[SYSTEM "$system_id"]; my $fh = $self->fh(); print $fh <<"MAGEML"; MAGEML } sub write_start_tag { my ($self,$tag,$empty,%attrs) = @_; my $indent = ' ' x $self->indent_level(); my $fh = $self->fh(); my (@attrs); foreach my $attribute_name (keys %attrs) { push(@attrs,qq[$attribute_name="$attrs{$attribute_name}"]); } my ($attrs,$attr_indent); if ($self->attrs_on_one_line()) { $attrs = join(' ',@attrs); } else { $attr_indent = $self->attr_indent(); $attr_indent = length($tag) + 2 unless defined $attr_indent; $attr_indent = ' ' x $attr_indent . $indent; $attrs = join("\n$attr_indent",@attrs); } if ($attrs) { print $fh "$indent<$tag $attrs"; } else { # don't print the space after the tag because Eric said so print $fh "$indent<$tag"; } if ($empty) { print $fh '/>'; } else { print $fh '>'; } print $fh "\n" unless $self->collapse_tag(); $self->incr_indent() unless $empty; } sub write_end_tag { my ($self,$tag) = @_; $self->decr_indent(); my $indent = ' ' x $self->indent_level(); my $fh = $self->fh(); print $fh "$indent\n"; } # we purposefully avoid copying the text, since it may be BIG sub write_text { my $self = shift; my $fh = $self->fh(); print $fh $_[0]; } # # Helper methods # sub identifier_generation { my ($self,$obj) = @_; my $known_identifiers = $self->identifiers(); return if exists $known_identifiers->{$obj->getIdentifier}; # stringify the object: Bio::MAGE::Identifiable=SCALAR(0x10379980) my $identifier = $obj; # strip of the leading class qualifiers: Identifiable=SCALAR(0x10379980) $identifier =~ s/^Bio::MAGE:://; # convert the '=' to a colon: Identifiable:SCALAR(0x10379980) $identifier =~ tr/=/:/; # remove the SCALAR: Identifiable:10379980 $identifier =~ s/SCALAR\(0x(.*)\)/$1/; $obj->setIdentifier($identifier); } ############################################################################### # obj2database_ref: write a reference object to the database ############################################################################### sub obj2database_ref { my ($self,$obj) = @_; # create the <*_ref> tag my $tag = $obj->class_name(); $tag =~ s/.+:://; $tag .= '_ref'; # we create the empty tag with only the identifier my $empty = 1; #$self->write_start_tag($tag,$empty,identifier=>$obj->getIdentifier()); my $dbhandle = $self->dbhandle(); my $table_name = $tag; $table_name =~ s/_ref$//; my $referring = $self->object_stack->[-1]; my $association = $self->assn_stack->[-1]; my $target_ID = $self->object_IDs->{$obj}; unless ($target_ID) { #print "+++ Yipe, the target object hasn't been written yet.\n"; #print " Try to write the object:\n"; $self->obj2database($obj); $target_ID = $self->object_IDs->{$obj}; die "INTERNAL ERROR: Failed to INSERT needed object $obj\n" unless ($target_ID); } #print "referring: ",join(" , ",@{$referring}),"\n"; #print "assn: ",join(" , ",@{$association}),"\n"; #print "cardinality: ",$association->[0]->cardinality(),"\n"; #print "name: ",$association->[0]->name(),"\n"; #print "class_name: ",$association->[0]->class_name(),"\n"; #### If cardinality is 1 or 0..1 if ($association->[0]->other->cardinality() eq CARD_0_OR_1 || $association->[0]->other->cardinality() eq CARD_1) { my $table_name = $referring->[0]->class_name(); $table_name =~ s/.+:://; my $assn_name = $association->[0]->other->name(); my %rowdata = ($assn_name.'_fk'=>$target_ID); $dbhandle->updateOrInsertRow( update=>1, table_name=>$table_name, rowdata_ref=>\%rowdata, PK=>"ID", PK_value=>$referring->[1], print_SQL=>1, testonly=>1, ); print "\n"; #### If cardinality is 0..n or 1..n } elsif ($association->[0]->other->cardinality() eq CARD_0_TO_N || $association->[0]->other->cardinality() eq CARD_1_TO_N) { my $table_name = $referring->[0]->class_name() . $association->[0]->other->class_name() . '_link'; $table_name =~ s/.+:://; my $assn_name = $association->[0]->other->name(); my $referring_table_name = $referring->[0]->class_name(); $referring_table_name =~ s/.+:://; my %rowdata = ($referring_table_name.'_fk'=>$referring->[1], $association->[0]->other->name().'_fk'=>$target_ID); $dbhandle->updateOrInsertRow( insert=>1, table_name=>$table_name, rowdata_ref=>\%rowdata, print_SQL=>1, testonly=>1, ); print "\n"; #### Otherwise plead ignorance } else { print "Don't know what to do with this kind of cardinality yet!\n"; } } sub flatten { my ($self,$list) = @_; my @list; foreach my $item (@{$list}) { if (ref($item) eq 'ARRAY') { push(@list,$self->flatten($item)); } else { push(@list,$item); } } return join("\t",@list); } sub external_file_id { my $self = shift; my $num = $self->external_data(); $num++; $self->external_data($num); return "external-data-$num.txt"; } ############################################################################### # obj2database: write an object and all its children to the database ############################################################################### sub obj2database { my ($self,$obj) = @_; # all attributes are gathered into a hash my %attributes; my $data; foreach my $attribute ($obj->attribute_methods()) { my $attribute_val; { no strict 'refs'; my $getter_method = 'get'.ucfirst($attribute); $attribute_val = $obj->$getter_method(); if ($attribute eq 'cube') { $data = $self->flatten($attribute_val); $attribute_val = undef; } else { $attribute_val =~ s/\"/"/g; } } if (defined $attribute_val) { $attributes{$attribute} = $attribute_val; } } # the tag name is the name of the class my $tag = $obj->class_name(); $tag =~ s/.+:://; # we create the start tag, with the object attributes represented as # element attributes. If the object has no associations we make it # an empty element - this is to avoid XML validation errors my $empty = not scalar $obj->associations(); #$self->write_start_tag($tag,$empty,%attributes); #### Get the database handle and write the data to the database my $dbhandle = $self->dbhandle(); my $table_name = $tag; my $returned_PK; #### If the object has already been serialized if ($self->object_IDs->{$obj}) { #print "=== Okay, well, it appears that this guy was already written\n"; #print " so just sweep on without writing\n\n"; $returned_PK = $self->object_IDs->{$obj}; #### Else write it to the database } else { $returned_PK = $dbhandle->updateOrInsertRow( insert=>1, table_name=>$table_name, rowdata_ref=>\%attributes, PK=>"ID", return_PK=>1, print_SQL=>1, testonly=>1, ); #### Store the database autogen key to a lookup table: $self->object_IDs->{$obj} = $returned_PK; print " --> returned ID = $returned_PK\n"; print "\n"; } #### Push some information about this object onto the stack push(@{$self->object_stack},[$obj,$returned_PK]); # associations are handled as sub-elements of the current element # and we use the association meta-data to instruct how to represent # each association # # We use the IxHash module because the associations are ordered # in the same order the DTD expects to receive them, and IxHash # preserves insertion order tie my %assns_hash, 'Tie::IxHash', $obj->associations(); foreach my $association (keys %assns_hash) { my $association_obj; { no strict 'refs'; my $getter_method = 'get'.ucfirst($association); $association_obj = $obj->$getter_method(); } if (defined $association_obj) { # we first create the container tag with the proper prefix my $prefix; my $is_ref = $assns_hash{$association}->other->is_ref(); if ($is_ref) { $prefix = '_assnref'; } else { $prefix = '_assn'; } my @association_objects; my $cardinality = $assns_hash{$association}->other->cardinality(); if (($cardinality eq CARD_1_TO_N) || ($cardinality eq CARD_0_TO_N)) { $prefix .= 'list'; @association_objects = @{$association_obj}; } else { @association_objects = ($association_obj); } my $container_tag = ucfirst("$association$prefix"); # container tags must not be empty #$self->write_start_tag("$container_tag",my $cont_empty=0); push(@{$self->assn_stack},[$assns_hash{$association}]); # now we fill in the container with the object(s) foreach $association_obj (@association_objects) { if ($is_ref) { #print "** assnref: ",$cardinality,"\n"; if ($cardinality eq CARD_1) { #print " == Cardinality is $cardinality\n"; #print " Need to update the referring with the fk\n"; #print " to the target object.\n"; $self->obj2database_ref($association_obj); } if ($cardinality eq CARD_0_OR_1) { #print " == Cardinality is $cardinality\n"; #print " Need to update the referring with the fk\n"; #print " to the target object.\n"; $self->obj2database_ref($association_obj); } if ($cardinality eq CARD_0_TO_N) { #print " == Cardinality is $cardinality\n"; #print " Need to add a row in a linking table, fk'ing\n"; #print " to both referring and target objects.\n\n"; $self->obj2database_ref($association_obj); } if ($cardinality eq CARD_1_TO_N) { #print " == Cardinality is $cardinality\n"; #print " Need to add a row in a linking table, fk'ing\n"; #print " to both referring and target objects.\n\n"; $self->obj2database_ref($association_obj); } } else { #print "** assn: ",$cardinality,"\n"; $self->obj2database($association_obj); } } # now end the container tag #$self->write_end_tag("$container_tag"); pop(@{$self->assn_stack}); } } #### Special code for BioDataCube if (defined $data) { if ($self->external_data()) { my %attributes; $attributes{filenameURI} = $self->external_file_id(); my $tag = 'DataExternal_assn'; $self->write_start_tag($tag,my $empty=0); # we need to make it external { my $tag = 'DataExternal'; $self->write_start_tag($tag,my $empty=1,%attributes); open(DATA, ">$attributes{filenameURI}") or die "Couldn't open $attributes{filenameURI} for writing"; print DATA $data; close(DATA); } $self->write_end_tag($tag); } else { # we make it internal my $tag = 'DataInternal_assn'; $self->write_start_tag($tag,0); { my $tag = 'DataInternal'; $self->write_start_tag($tag,0); my $fh = $self->fh(); print $fh ""; $self->write_end_tag($tag); } $self->write_end_tag($tag); } } # now end the current element #$self->write_end_tag($tag) # unless $empty; pop(@{$self->object_stack}); } sub is_object { my ($self,$obj) = @_; my $ref = ref($obj); return $ref && $ref ne 'ARRAY' && $ref ne 'SCALAR' && $ref ne 'HASH' && $ref ne 'CODE' && $ref ne 'GLOB' && $ref ne 'REF'; } sub is_bio_mage_object { my ($self,$obj) = @_; return $self->is_object($obj) && ref($obj) =~ /^Bio::MAGE/; } 1; Bio-MAGE-Utils-20030502.0/MANIFEST0000644000175000017500000000073710622036172015136 0ustar jasonsjasonsMAGE/XML/Handler.pm MAGE/XML/Handler/ContentHandler.pm MAGE/XML/Handler/DocumentHandler.pm MAGE/XML/Handler/ObjectHandler/SQL.pm MAGE/XML/Handler/ObjectHandlerI.pm MAGE/XML/Reader.pm MAGE/XML/Writer.pm MAGE/XMLUtils.pm MAGE/Tools/MGEDOntologyClassEntry.pm MAGE/Tools/MGEDOntologyEntry.pm MAGE/Tools/MGEDOntologyHelper.pm MAGE/Tools/MGEDOntologyPropertyEntry.pm MAGE/SQLUtils.pm MANIFEST Makefile.PL META.yml Module meta-data (added by MakeMaker) Bio-MAGE-Utils-20030502.0/Makefile.PL0000644000175000017500000000072310622022643015750 0ustar jasonsjasonsuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Bio::MAGE::Utils', 'VERSION' => '20030502.0', 'PREREQ_PM' => {Tie::IxHash=>1.21}, ($] >= 5.005 ? (ABSTRACT => 'Classes for MAGE-OM', AUTHOR => q[The MAGE-Perl Hackers ]) : ()), ); Bio-MAGE-Utils-20030502.0/META.yml0000644000175000017500000000052410622036172015250 0ustar jasonsjasons# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Bio-MAGE-Utils version: 20030502.0 version_from: installdirs: site requires: Tie::IxHash: 1.21 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.30_01