view release on metacpan or  search on metacpan

cgi-bin/das  view on Meta::CPAN

    $self->_add_types($hash,$_) foreach @subparts;
}

sub guess_type {
    my $self     = shift;
    my $feature  = shift;
    my $track    = $self->track;
    my $type     = ref $feature ? $feature->method : $feature;
    my $source   = $self->datasource;

    return $type unless $source->fallback_setting($track=>'das use so');

    my $glyph    = $source->fallback_setting($track=>'glyph');
    my $hash     = $self->so_hash() or return $type;
    return $hash->{lc $type} || $type;
}

sub so_hash {
    my $self = shift;
    return \%SO_HASH if tied %SO_HASH;

    my $so_file = File::Spec->catfile(File::Spec->tmpdir,'SO.obo');
    my $so_hash = File::Spec->catfile(File::Spec->tmpdir,'SO.db');

    $self->fetch_sofile($so_file) or return unless -e $so_file;

    eval 'use DB_File' unless DB_File->can('new');
    eval 'use Fcntl'   unless Fcntl->can('O_CREAT');

    $self->hash_sofile($so_file,$so_hash)
	or return unless -e $so_hash && 
	(stat($so_hash))[9] >= (stat($so_file))[9];
    tie %SO_HASH,'DB_File',$so_hash,Fcntl->O_RDONLY,0666,$DB_File::DB_HASH or return;    
    return \%SO_HASH;
}

sub fetch_sofile {
    my $self = shift;
    return if $self->{so_fetch}++; # only try once per session

    my $so_file = shift;
    my $so_url  = SO;
    eval "use LWP::Simple; 1" unless LWP::Simple->can('mirror');

    my $result = eval {
	local $SIG{ALRM} = sub {die "timeout"};
	alarm(5);
	my $result = LWP::Simple::mirror($so_url => $so_file);
	alarm 0;
	LWP::Simple::is_success($result);
    };
    return $result;
}

sub hash_sofile {
    my $self = shift;
    my ($so_file,$so_hash) = @_;
    my %hash;
    tie %hash,'DB_File',$so_hash,Fcntl->O_CREAT|Fcntl->O_RDWR,0666,$DB_File::DB_HASH or return;
    open my $f,$so_file or return;
    local $/ = '';  # paragraph mode
    while (<$f>) {
	next unless /\[Term\]/;
	my ($id)     = /^id: +(SO:\d+)/m;
	my ($name)   = /^name: (.+)/m;
	my @synonyms = /^synonym: "(.+)"/mg;
	$hash{lc $_} = $id foreach ($name,@synonyms);
    }
}

sub types {
    my $self = shift;
    return $self->all_types() unless param('ref') or param('segment');

    my $source = $self->datasource;
    my ($category2type,$type2category,$types) = $self->categories;

    my $summary = param('summary');
    my $url     = $self->get_url();
    my @filter  = param('type');
    unless (@filter) {
	@filter = @$types;
    }

    my @segments = $self->get_segments() or return;

    $self->ok_header();

    print <<END;
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE DASTYPES SYSTEM "http://www.biodas.org/dtd/dastypes.dtd">
<DASTYPES>
<GFF version="1.2" summary="yes" href="$url">
END
;

    foreach (@segments) {
	my ($reference,$class,$start,$stop) = @$_;
	next unless $reference;
	my $seq = $self->get_segment_obj($reference,$start,$stop) or next;
	unless ($seq) {  #empty section
	    my $version = $self->seq2version($reference);
	    print qq(<SEGMENT id="$reference" start="$start" stop="$stop" version="$version">\n);
	    print qq(</SEGMENT>\n);
	    next;
	}

	my $s = $seq->start;
	my $e = $seq->stop;

	# use absolute coordinates -- people expect it
	my $name = $seq->seq_id;

	my $version = $self->seq2version($name);
	print qq(<SEGMENT id="$name" start="$s" stop="$e" version="$version">\n);

	my @args = (-enumerate=>1);
	push @args,(-types=>\@filter) if @filter;
	my %histogram = $seq->types(@args);
	foreach (keys %histogram) {
	    my ($method,$source) = split ':';