[Bio] / Sprout / AttributeTest.pl Repository:
ViewVC logotype

View of /Sprout/AttributeTest.pl

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.1 - (download) (as text) (annotate)
Fri Feb 9 22:58:32 2007 UTC (13 years, 5 months ago) by parrello
Branch: MAIN
Added as a way to test standard attribute capabilities.

#!/usr/bin/perl -w

=head1 Attribute Test Script

This method will run a short test of the attribute system. It will use a
dummy attribute called C<Frog> that will be created and deleted by this
test process.

The currently-supported command-line options are as follows.

=over 4

=item user

Name suffix to be used for log files. If omitted, the PID is used.

=item trace

Numeric trace level. A higher trace level causes more messages to appear. The
default trace level is 2. Tracing will be directly to the standard output
as well as to a C<trace>I<User>C<.log> file in the FIG temporary directory,
where I<User> is the value of the B<user> option above.

=item sql

If specified, turns on tracing of SQL activity.

=item background

Save the standard and error output to files. The files will be created
in the FIG temporary directory and will be named C<err>I<User>C<.log> and
C<out>I<User>C<.log>, respectively, where I<User> is the value of the
B<user> option above.

=item h

Display this command's parameters and options.

=item phone

Phone number to message when the script is complete.



use strict;
use Tracer;
use DocUtils;
use TestUtils;
use Cwd;
use File::Copy;
use File::Path;
use FIG;
use CustomAttributes;

# Get the command-line options and parameters.
my ($options, @parameters) = StandardSetup([qw(CustomAttributes) ],
                                              phone => ["", "phone number (international format) to call when load finishes"],
# Set a variable to contain return type information.
my $rtype;
# Insure we catch errors.
eval {
    # Get a FIG object.
    my $fig = FIG->new();
    # Get the CustomAttributes object.
    my $ca = $fig->{_ca};
    # Insure the attribute server is local.
    if (ref $ca ne 'CustomAttributes') {
        Confess("This test must be run on a local attribute server.");
    } else {
        # Build a hash of the data we want to put into the attribute load file.
        my %loadHash = (0 => "# This is a comment.",
                        'Family:aclame|cluster103' => ['egg', 'beaters'],
                        'Feature:fig|100226.1.peg.3361' => ['tadpole'],
                        'Genome:83333.1' => ['adult'],
                        1 => '',
                        'Subsystem:4-Hydroxyphenylacetic_acid_catabolic_pathway' => ['wiggle'],
                        'Role:1,4-alpha-glucan phosphorylase (EC' => ['swim'],
                        'Genome:100226.1' => ['hip','hop']
        # Create the load file.
        my $loadFileName = "$FIG_Config::temp/FrogLoader$$.tbl";
        Trace("Creating load file $loadFileName.") if T(2);
        my $oh = Open(undef, ">$loadFileName");
        # Loop through the hash of load values.
        for my $key (keys %loadHash) {
            my $value = $loadHash{$key};
            # If the value is an array, we have an attribute value line.
            if (ref $value eq 'ARRAY') {
                # Format the ID.
                $key =~ /([^:]+):(.+)/;
                my $idValue = FIG::form_oid($1, $2);
                # Format the value.
                my $valueValue = join($ca->{splitter}, @{$value});
                # Write the line.
                Tracer::PutLine($oh, [$idValue, $valueValue]);
            } else {
                # Here we have a comment line.
                Tracer::PutLine($oh, [$value]);
                # Delete this line from the hash so we don't expect it when
                # we test "get_attributes".
                delete $loadHash{$key};
        # Close the load file.
        close $oh;
        # Create the attribute.
        my @groups = qw(Feature Genome);
        Trace("Creating Frog attribute.") if T(2);
        $ca->StoreAttributeKey('Frog', 'string',
                               "This attribute is a special one used to test the attribute system. It was created by the AttributeTest script.",
        # Verify that it is in the correct groups.
        my @allGroups = $ca->GetGroups();
        for my $group (@allGroups) {
            Trace("Checking group $group.") if T(3);
            # Get the current group's attributes in a hash.
            my %keys = $ca->GetAttributeData(group => $group);
            # Find out if we should be in this group.
            my $inGroup = grep { $_ eq $group } @groups;
            if (! exists $keys{Frog} && $inGroup) {
                Confess("Frog not found in $group group.");
            } elsif (exists $keys{Frog} && ! $inGroup) {
                Confess("Frog found in $group group.");
        # Load the attribute.
        Trace("Loading Frog data.") if T(3);
        my $ih = Open(undef, "<$loadFileName");
        my $stats = $ca->LoadAttributeKey('Frog', $ih, 0, 1);
        # Now we need to test the data against what's in the hash. First we get the data.
        my @attributes = $fig->get_attributes(undef, 'Frog');
        # Loop through the attributes, checking against the hash. As we find an attribute,
        # we delete it from the hash. When we're done, the hash should be empty.
        for my $attributeRow (@attributes) {
            # Get the ID from this row.
            my @rowData = ();
            push @rowData, @{$attributeRow};
            my $idValue = shift @rowData;
            # Parse it into an ID and type, then combine them to get the hash key.
            my ($type, $id) = FIG::parse_oid($idValue);
            my $hashKey = "$type:$id";
            # Check the hash.
            if (! exists $loadHash{$hashKey}) {
                Confess("Object $type($id) not found in load hash.");
            } else {
                # Insure this is a Frog attribute.
                my $key = shift @rowData;
                if ($key ne 'Frog') {
                    Confess("Attribute key is $key, but it should be Frog.");
                } else {
                    # Get the values for this key.
                    my $valueList = $loadHash{$hashKey};
                    my @valueData = ();
                    push @valueData, @{$valueList};
                    # Compare them against the actual values.
                    if (length(@valueData) != length(@rowData)) {
                        Confess("Row for $hashKey does not match length of row retrieved from get_attributes.");
                    } else {
                        for (my $i = 0; $i <= $#valueData; $i++) {
                            if ($rowData[$i] ne $valueData[$i]) {
                                Confess("Value at position $i in row for $hashKey has mismatched data.");
                        # Remove this key from the hash.
                        Trace("$hashKey processed in retrieval check.") if T(3);
                        delete $loadHash{$hashKey};
        # Verify that the load hash is empty.
        if (scalar(keys %loadHash)) {
            my @keys = sort keys %loadHash;
            Trace("Attribute object IDs not found: " . join(" ", @keys)) if T(0);
            Confess("Not all expected attribute values were found.");
        } else {
            # Now we do an insert and a delete.
            Trace("Insert/delete test.") if T(2);
            # Create an attribute row.
            my @testArray = ('Reaction:R00001', 'Frog', 'simplicity');
            # Insert it into the database.
            # Verify that it's there.
            my @tuple = $fig->get_attributes(@testArray);
            if (! @tuple) {
                Confess("Insert failed.");
            } else {
                # Delete it.
                # Verify that it's gone.
                my @nonTuple = $fig->get_attributes(@testArray);
                if (@nonTuple) {
                    Confess("Delete failed.");
                } else {
                    # Delete the key.
                    # Verify that it has no values.
                    my @values = $fig->get_attributes(undef, 'Frog');
                    if (@values) {
                        Confess("Not all Frog attributes were deleted.");
                    } else {
                        # Insure there is no Frog attribute.
                        my %keys = $ca->GetAttributeData(name => 'Frog');
                        if (exists $keys{Frog}) {
                            Confess("Frog attribute was not deleted.");
    Trace("Test complete.") if T(2);

if ($@) {
    Trace("Script failed with error: $@") if T(0);
    $rtype = "error";
} else {
    Trace("Script complete.") if T(2);
    $rtype = "no error";
if ($options->{phone}) {
    my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");
    if ($msgID) {
        Trace("Phone message sent with ID $msgID.") if T(2);
    } else {
        Trace("Phone message not sent.") if T(2);


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3