[Bio] / FigKernelPackages / Subsystem.pm Repository:
ViewVC logotype

View of /FigKernelPackages/Subsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (download) (as text) (annotate)
Thu Jun 17 18:31:45 2004 UTC (15 years, 9 months ago) by olson
Branch: MAIN
Changes since 1.15: +4 -3 lines
subsystem extension filename tweaks

package Subsystem;

use FIG;

use FIGAttributes;
use base 'FIGAttributes';

use POSIX;
use DirHandle;
use Data::Dumper;
use File::Copy;
use File::Spec;
use IPC::Open2;

use strict;

=pod

=head1 Subsystem manipulation.

Any manipulation of subsystem data should happen through this interface.
This allows us to assure ourselves that the relational tables that 
mirror and index the subsystem data are kept up to date with the 
canonical version of the subsystem information in the flat-files
kept in $FIG_Config::data/Subsystems.

=head2 Thoughts on locking

It is currently dangerous for multiple users to modify spreadsheets at once.
It will likely remain dangerous while the subsystem backend is fairly
stateless, as it is with the CGI mechanism.

We'd like to make this a little safer. One mechanism might be to allow
a user to open a subsystem for modification, and others for readonly access.
For this to work we have to be able to tell which users is allowed; current
implementation uses the curator of the subsystem for this purpose.

NB: This module does not currently attempt to handle locking or exclusion.
It is up to the caller (user application, CGI script, etc) to do so.
It does attempt to use locking internally where appropriate.

=head2 Data structures

We maintain the following data structures (all members of %$self).

=over 4

=item dir

Directory in which the subsystem is stored.

=item notes

The current notes contents for the subsystem

=item version

Current subsystem version.

=item exchangable

1 if subsystem is exchangable, 0 otherwise.


=item roles

list of role names

=item role_index

hash that maps from role name to index

=item role_abbrs

list of role abbreviations

=item abbr

hash mapping from role abbreviation to role name

=item col_subsets

list of column subset names

=item col_subset_members

hash that maps from column subset name to subset members

=item col_active_subset

currently-active column subset

=item row_active_subset

currently-active row subset

=item genome

List (1-indexed, so element 0 is undef) of genome IDs.

=item variant_code

List (1-indexed, so element 0 is undef) of variant codes.

=item genome_index

Hash mapping from genome ID to genome index.

=item variant_code

List (1-indexed, so element 0 is undef) of variant codes.

=item spreadsheet

Spreadsheet data. Structured as a list of rows, each of  which
is a list of entries. An entry is a list of PEG numbers.

=item spreadsheet_inv

Inverted structure of spreadsheet - list of columns, each of which is a list
of rows.

=back

=cut

use FIG;

=pod

=head1 Subsystem constructor

usage: $sub = Subsystem->new("subsystem name", $fig, $createFlag)

Load the subsystem. If it does not exist, and $createFlag is true, create
a new empty subsystem.

=cut

sub new
{
    my($class, $name, $fig, $create) = @_;

    my $ssa_dir = get_dir_from_name($name);

    #
    # For loading, the subsystem directory must already exist.
    #
    
    if (! -d $ssa_dir)
    {
	if ($create)
	{
	    return create_subsystem($class, $name, $fig);
	}
	else
	{
#	    warn "Subsystem $name does not exist\n";
	    return undef;
	}
    }

    my $self = {
	dir => $ssa_dir,
	name => $name,
	fig => $fig,
    };

    bless($self, $class);

    $self->load();

    return $self;
}

sub create_subsystem
{
    my($class, $name, $fig) = @_;

    return undef;
}

#
# Retrieve the diagrams associated with this subsystem.
#
# This is done via a lookup into FIG/Data/SubsystemDiagrams/<ssaname>/<diagram-name>.
#
# Returned is a list of names.
#

sub get_diagrams
{
    my($self) = @_;

    my $b = $self->{name};
    $b =~ s/ /_/g;
    my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b);

    my $dh = new DirHandle($dir);
    
    my @names = grep(/^[^.]/, $dh->read());

    return @names;
}

#
# Return a Subsystem::Diagram object for this diagram.
#
sub get_diagram
{
    my($self, $name) = @_;

    my $b = $self->{name};
    $b =~ s/ /_/g;
    my $dir = File::Spec->catfile($FIG_Config::data, 'SubsystemDiagrams', $b, $name);

    if (-d $dir)
    {
	return Subsystem::Diagram->new($self, $self->{fig}, $name, $dir);
    }
    else
    {
	return undef;
    }
}
    
#
# Synchronize the database index for this subsystem to the
# subsystem data.
#
# We assume the table already exists.
# 

sub db_sync
{
    my($self, $skip_delete) = @_;

    my $rdbH = $self->{fig}->db_handle();

    if (!$skip_delete)
    {
	$rdbH->SQL("DELETE FROM subsystem_index where subsystem = '$self->{name}'")
    }

    #
    # We run thru all the cells, writing an entry in the database for the peg/subsystem/role.
    #

    my $sth = $rdbH->{_dbh}->prepare("INSERT INTO subsystem_index values(?, ?, ?)");

    for my $role ($self->get_roles())
    {
	my $ridx = $self->get_role_index($role);
	my $col = $self->get_col($ridx);
	for my $cell (@$col)
	{
	    if ($cell)
	    {
		for my $peg (@$cell)
		{
		    $sth->execute($peg, $self->{name}, $role);
		}
	    }
	}
    }
}

sub load
{
    my($self) = @_;

    #
    # Load the subsystem.
    #

    my $ssa;
    if  (!open($ssa,"<$self->{dir}/spreadsheet"))
    {
	warn "Spreadsheet does not exist in subsystem\n";
	return;
    }

    local $/ = "//\n";

    my $roles = <$ssa>;
    if ($roles)
    {
	$roles =~ s,$/$,,;
	#
	# Split on newline, filter for non-empty lines.
	#
	my @roles = split("\n", $roles);
	
	@roles = grep { $_ ne "" } @roles;
	
	$self->load_roles(@roles);
    }

    my $subsets = <$ssa>;
    if ($subsets)
    {
	$subsets =~ s,$/$,,;
	$self->load_subsets($subsets);
    }

    $/ = "\n";

    $self->load_genomes($ssa);

    #
    # Now load the rest of the info.
    #

    $self->load_notes();
    $self->load_version();
    $self->load_exchangable();
}

sub load_notes
{
    my($self) = @_;

    $self->{notes} = &FIG::file_read(File::Spec->catfile($self->{dir}, "notes"));
}

sub load_version
{
    my($self) = @_;

    my @l = &FIG::file_head(File::Spec->catfile($self->{dir}, "VERSION"), 1);
    my $l = $l[0];
    chomp $l;
    $self->{version} = $l;
}

sub load_exchangable
{
    my($self) = @_;

    my $file = File::Spec->catfile($self->{dir}, "EXCHANGABLE");

    if (-f $file)
    {
	my($l, @l);

	@l = &FIG::file_head($file, 1);
	$l = $l[0];
	chomp $l;
	$self->{exchangable} = $l;
    }
    else
    {
	$self->{exchangable} = 0;
    }
}


sub load_roles
{
    my($self, @roles) = @_;

    $self->{abbr} = {};
    $self->{role_index} = {};
    $self->{roles} = [];
    $self->{role_abbrs} = [];

    my $i = 1;
    for my $role (@roles)
    {
	my($abbr, $name) = split(/\t/, $role);
	# print "Role $i: abbr=$abbr name=$name\n";

	$self->{abbr}->{$abbr} = $name;
	$self->{role_index}->{$name} = $i;
	$self->{roles}->[$i] = $name;
	$self->{role_abbrs}->[$i] = $abbr;
	$i++;
    }
}
    
sub load_subsets
{
    my($self, $subsets) = @_;

    #
    # Column and row subsets.
    #
    my($subsetsC, $subsetsR) = split(/\n\n/, $subsets);


    #
    # Handle column subsets.
    #

    my @subsetsC = split(/\n/, $subsetsC);

    #
    # Determine active subset.
    #

    my $active_subsetC;
    if (@subsetsC > 0)
    {
	$active_subsetC = pop(@subsetsC);
    }
    else
    {
	$active_subsetC = 'All';
    }

    $self->{col_active_subset} = $active_subsetC;

    $self->{col_subsets} = [];
    $self->{col_subset_members} = {};
    
    for my $subset (@subsetsC)
    {
	my($name, @members) = split(/\s+/, $subset);

	push(@{$self->{col_subsets}}, $name);

	#
	# Map role members from name to index if necessary.
	#
	# Is it really necessary? ssa2 code was looking up in %pos for this.
	#
	@members = map {
	    if (my $new = $self->{role_index}->{$_})
	    {
		$new;
	    }
	    else
	    {
		$_;
	    }
	} @members;

	@{$self->{col_subset_members}->{$name}} = @members;
    }

    #
    # Now the row subsets.
    #

    chomp($subsetsR);

    if ($subsetsR =~ /(\S+.*\S+)/)
    {
	$self->{row_subset_active} = $1;
    }
    else
    {
	$self->{row_subset_active} = 'All';
    }
}

sub load_genomes
{
    my($self, $fh) = @_;
    my(%seen);

    $self->{spreadsheet} = [];
    $self->{spreadshhet_inv} = [];
    $self->{genome} = [];
    $self->{genome_index} = {};
    $self->{variant_code} = [];

    my $i = 1;
    while (<$fh>)
    {
	chomp;

	my($genome, $variant_code, @row) = split(/\t/);

	next if $seen{$genome};
	$seen{$genome}++;
	
	my $j = 1;

	$self->{genome}->[$i] = $genome;
	$self->{genome_index}->{$genome} = $i;
	$self->{variant_code}->[$i] = $variant_code;

	for my $entry (@row)
	{
	    my $e2 = [map("fig|$genome.peg.$_", split(/,/, $entry))];
	    $self->{spreadsheet}->[$i]->[$j] = $e2;
	    $self->{spreadsheet_inv}->[$j]->[$i] = $e2;
	    $j++;
	}
	$i++;
	
    }
}

=pod

=head1 get_genomes

=cut
    
sub get_genomes
{
    my($self) = @_;

    my $glist = $self->{genome};

    return @$glist[1..$#$glist];
}

=pod

=head1 get_variant_codes

=cut
    
sub get_variant_codes
{
    my($self) = @_;

    my $glist = $self->{variant_code};

    return @$glist[1..$#$glist];
}

sub get_variant_code_for_genome
{
    my($self, $genome) = @_;

    my $index = $self->{genome_index}->{$genome};
    return $self->{variant_code}->[$index];
}

sub get_roles
{
    my($self) = @_;

    my $rlist = $self->{roles};

    return @$rlist[1..$#$rlist];
}

sub get_row :scalar
{
    my($self, $row) = @_;

    return $self->{spreadsheet}->[$row];
}

sub get_col
{
    my($self, $col) = @_;

    return $self->{spreadsheet_inv}->[$col];
}

sub get_cell
{
    my($self, $row, $col) = @_;

    my $cell = $self->{spreadsheet}->[$row]->[$col];
    return $cell;
}

sub get_genome_index
{
    my($self, $genome) = @_;

    return $self->{genome_index}->{$genome};
}

sub get_genome
{
    my($self, $gidx) = @_;

    return $self->{genome}->[$gidx];
}

sub get_role_index
{
    my($self, $role) = @_;

    return $self->{role_index}->{$role};
}

sub get_role
{
    my($self, $ridx) = @_;

    return $self->{roles}->[$ridx];
}

sub get_role_abbr
{
    my($self, $ridx) = @_;

    return $self->{role_abbrs}->[$ridx];
}

sub get_pegs_from_cell
{
    my($self, $rowstr, $colstr) = @_;
    my($row, $col);

    #
    # If row isn't numeric, look it up in the genomes list.
    #
    
    if ($rowstr !~ /^\d+$/)
    {
	$row = $self->{genome_index}->{$rowstr};
    }
    else
    {
	$row = $rowstr;
    }
	
    if (!$row)
    {
	warn "Cannot find row for $rowstr\n";
	return undef;
    }

    #
    # If col isn't numeric, look it up in the roles and role abbreviations.
    #
    
    if ($colstr !~ /^\d+$/)
    {
	#
	# See if it's an abbr
	#

	my $a = $self->{abbr}->{$colstr};
	$colstr = $a if $a;

	$col = $self->{role_index}->{$colstr};
    }
    else
    {
	$col = $colstr;
    }
	
    if (!$col)
    {
	warn "Cannot find col for $colstr\n";
	return undef;
    }
    my $cell = $self->get_cell($row, $col);

    if ($cell)
    {
	return @$cell;
    }
    else
    {
	return undef;
    }
}

sub dump
{
    my($self) = @_;

    for my $k (keys(%$self))
    {
	next if $k eq "spreadsheet" or $k eq "spreadsheet_inv";
	print "Key \"$k\": ", Dumper($self->{$k});
    }
}
    
#
# Increment the subsystem's version number.
#
sub incr_version {
    my($self) = @_;

    my $dir = $self->{dir};
    my $vfile = "$dir/VERSION";
    my($ver);

    if (open(my $fh,"<$vfile"))
    {
        if (defined($ver = <$fh>) && ($ver =~ /^(\S+)/))
        {
            $ver = $1;
        }
        else
        {
            $ver = 0;
        }
        close($fh);
    }
    else
    {
        $ver = 0;
    }

    $ver++;

    open(my $fh, ">$vfile") || die "could not open $vfile";
    print $fh "$ver\n";
    close($fh);

    chmod(0777, $vfile);

    $self->load_version();
}

sub get_dir_from_name
{
    my($name) = @_;

    my $b = $name;
    $b =~ s/ /_/g;
    my $dir = File::Spec->catfile($FIG_Config::data, 'Subsystems', $b);
    return $dir;
}

#
# Code for dealing with Bill McCune's prolog code for extending subsystems.
#
# The code here is a reconstruction of Bill's "go" script in perl with
# data pulled from the local SEED configuration.
#

sub extend_with_billogix
{
    my($self, $muser) = @_;
    my($isMaster, $user);
    
    my $now = time();

    if ($muser =~ /master:(.*)/)
    {
	$isMaster = 1;
	$user = $1;
    }
    else
    {
	$isMaster = 0;
	$user = $muser;
    }

    #
    # Find the executable.
    #

    my $exe = "$FIG_Config::bin/billogix";

    if (! -x $exe)
    {
	warn "Cannot find billogix exe at $exe\n";
	return;
    }
    
    my $ss_name = $self->{name};
    my $ss_dir = "$self->{dir}/";
    my $assign_dir = "$FIG_Config::data/Assignments/$user/";
    &FIG::verify_dir($assign_dir);

    my $when= strftime("%m-%d-%y:%H:%M:%S", localtime($now));
    my $job_id = "${when}:sss:$ss_name";

    my $seed = &FIG::cgi_url() . "/";
    my $export_part = "ssa.cgi?user=$muser&request=delete_or_export_ssa&export=";

    #
    # Have the prereq stuff, now start up the app.
    #

    $ENV{LOCALSZ} = "80000";
    $ENV{GLOBALSZ} = "80000";
    $ENV{TRAILSZ} = "30000";

    my $arch = &FIG::get_current_arch();

    $ENV{BILLOGIX} = "$FIG_Config::fig_disk/dist/releases/current/$arch/lib/Billogix";

    #
    # Need to ensure pl2wam is in our path
    #

    $ENV{PATH} = "${FIG_Config::ext_bin}:$ENV{PATH}";

    my $app_input = <<EOINP;
['\$BILLOGIX/top'].
loadup.
asserta(url_default_seed('$seed')).
asserta(url_export_part('$export_part')).
asserta(ss_directory('$ss_dir')).
asserta(assign_directory('$assign_dir')).
asserta(job_id('$job_id')).
extend_test3('$ss_name').
EOINP

    print STDERR <<EOF;
Starting app

ss_name = $ss_name
ss_dir = $ss_dir
user = $user
assign_dir = $assign_dir
exe = $exe
libdir = $ENV{BILLOGIX}
path = $ENV{PATH}

App input
$app_input
EOF
# feh, put in a block to reset perlmode indentation.
{
    my($app_read, $app_write, $log);

    open($log, ">$ss_dir/$job_id.log");

    #
    # Start the actual application with stdin and stdout redirected
    # to pipes.
    #
    # We write $app_input to the stdin pipe, and close it.
    # Then loop reading stdout, logging that output.
    #
    my $pid = open2($app_read, $app_write, $exe);

    if (!$pid)
    {
	warn "open2 $exe failed: $!\n";
	print $log "open2 $exe failed: $!\n";
	return;
    }

    print $app_write $app_input;
    close($app_write);

    #
    # Set autoflush on the logfile.
    #

    my $old = select($log);
    $| = 1;
    select(STDERR);
    $| = 1;
    select($old);

    warn "Starting $exe with pid $pid\n";
    print $log "Starting $exe with pid $pid\n";

    while (<$app_read>)
    {
	print STDERR $_;
	print $log $_;
    }

    print STDERR "App done\n";
    print $log "App done\n";

    close($app_read);

    my $ret = waitpid($pid, 0);
    my $stat = $?;
    print STDERR "Return status is $?\n";
    print $log "Return status is $?\n";

    #
    # At this point, the extension is finished.
    # Back up the spreadsheet, and append the rows file to it.
    #

    my $ssaD = $self->{dir};
    &FIG::verify_dir("$ssaD/Backup");
    my $ts = time;
    rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
    copy("$ssaD/spreadsheet","$ssaD/spreadsheet~");
    rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");

    #
    # Append the new rows to the spreadsheet.
    #

    my($ssafh, $rowsfh);
    open($ssafh, ">>$ssaD/spreadsheet") or die "Cannot open $ssaD/spreadsheet for append: $!\n";
    open($rowsfh, "<$ssaD/rows") or die "Cannot open $ssaD/rows for reading: $!\n";
    
    while (<$rowsfh>)
    {
	print $ssafh $_;
    }
    close($ssafh);
    close($rowsfh);

    $self->incr_version();
}
    
}


sub set_current_extend_pid
{
    my($self, $pid) = @_;

    if (open(my $fh, ">$self->{dir}/EXTEND_PID"))
    {
	print $fh "$pid\n";
    }
    else
    {
	warn "Cannot open $self->{dir}/EXTEND_PID: $!\n";
    }
}

sub get_current_extend_pid
{
    my($self) = @_;

    if (open(my $fh, "<$self->{dir}/EXTEND_PID"))
    {
	my $pid = <$fh>;
	close($fh);
	if ($pid)
	{
	    chomp $pid;
	    
	    return $pid;
	}
    }
    return undef;
}
    
package Subsystem::Diagram;

sub new
{
    my($class, $sub, $fig, $name, $dir) = @_;

    if (!-d $dir)
    {
	return undef;
    }

    my $self = {
	fig => $fig,
	subsystem => $sub,
	name => $name,
	dir =>$ dir,
    };
    bless $self, $class;

    $self->load();

    return $self;
}

#
# Parse the diagram into internal data structure.
#

sub load
{
    my($self) = @_;

    $self->load_area();
}

sub load_area
{
    my($self) = @_;
    my $fh;

    if (!open($fh, "<$self->{dir}/area_table"))
    {
	warn "Could not load $self->{dir}/area_table: $!\n";
	return;
    }

    $self->{areas} = [];

    my $area_list = $self->{areas};
    
    while (<$fh>)
    {
	chomp;
	s/#.*$//;
	s/^\s+//;
	s/\s+$//;
	next if $_ eq '';
	my ($area, $tag, $value) = split(/\s+/, $_, 3);
	# print "area=$area tag=$tag value=$value\n";

	push(@$area_list, [$area, $tag, $value]);

	#
	# Do a little checking.
	#

	if ($tag eq "role")
	{
	    my $idx = $self->{subsystem}->get_role_index($value);
	    if (!defined($idx))
	    {
		warn "Role not found for \"$value\" in subsystem $self->{subsystem}->{name}\n";
	    }
	}
    }
    close($fh);
}

sub get_areas
{
    my($self) = @_;

    return @{$self->{areas}};
}

1;



MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3