view release on metacpan or  search on metacpan

Das/Segment.pm  view on Meta::CPAN

    my @config = (
	-bgcolor    => $COLORS[$color++ % @COLORS],
	-label      => 1,
	-key        => $track_key,
	-stylesheet => $stylesheet,
	-glyph      => 'line',
	);


      eval {
	  if (defined($position_to_insert)) {
	      push @new_tracks,($tracks{$type} = 
				$panel->insert_track($position_to_insert++,$feature,@config));
	  } else {
	      push @new_tracks,($tracks{$type} = 
				$panel->add_track($feature,@config));
	  }
      };
      warn $@ if $@;
  }

  # reconfigure bumping, etc
  for my $type (keys %type_count) {
    my $type_count = $type_count{$type};
    my $do_bump    = defined $track_configs{$type}{-bump} ? $track_configs{$type}{-bump}
                                                          : $options == 0 ? $type_count <= $max_bump
							  : $options == 1 ? 0
							  : $options == 2 ? 1
							  : $options == 3 ? 1
							  : $options == 4 ? 2
							  : $options == 5 ? 2
							  : 0;

    my $maxed_out  = $type_count > $max_label;
    my $conf_label = defined $track_configs{$type}{-label} 
                             ? $track_configs{$type}{-label}
                             : 1;

    my $do_label   =   $options == 0 ? !$maxed_out && $conf_label
                     : $options == 3 ? 1
		     : $options == 5 ? 1
		     : 0;
    # warn "type = $type, label = $do_label, do_bump = $do_bump";

    my $track = $tracks{$type};

    my $factory = $track->factory;
    $factory->set_option(connector  => 'none') if !$do_bump;
    $factory->set_option(bump       => $do_bump);
    $factory->set_option(label      => $do_label);
  }
  my $track_count = keys %tracks;
  return wantarray ? ($track_count,$panel,\@new_tracks) : $track_count;
}

sub get_cached_stylesheet {
    my $self    = shift;
    my $tmpdir  = File::Spec->tmpdir;
    my $program = basename($0);
    my $user    = (getpwuid($>))[0];
    my $url     = $self->das->name.'/stylesheet';
    foreach ($program,$user,$url) {
	tr/a-zA-Z0-9_-/_/c;
    }

    my $dir  = File::Spec->catfile($tmpdir,"$program-$user");
    mkpath($dir) or die "$dir: $!" unless -d $dir;
    my $path = File::Spec->catfile($dir,$url);

    my $stylesheet;

    eval {

	# cache for 5 minutes
	my $mtime = (stat($path))[9];
	if ($mtime && ((time() - $mtime)/60) < 5.0) {
	    open my $f,'<',$path or die "$path: $!";
	    my $s;
	    $s .= $_ while <$f>;
	    close $f;
	    my $VAR1;
	    $stylesheet = eval "$s; \$VAR1";
	    warn $@ if $@;
	    utime undef,undef,$path;
	}
	
	else {
	    $stylesheet = $self->das->stylesheet;
	    my $d = Data::Dumper->new([$stylesheet]);
	    $d->Purity(1);
	    open my $f,">",$path or die "$path: $!";
	    print $f $d->Dump;
	    close $f;
	}
    
	return $stylesheet;
    };

    # something went wrong, so revert to non-cached behavior
    return $self->das->stylesheet;
}

1;

__END__

=head1 NAME

Bio::Das::Segment - Serial access to Bio::Das sequence "segments"

=head1 SYNOPSIS

   # SERIALIZED API
   my $das = Bio::Das->new(-server => 'http://www.wormbase.org/db/das',
                           -dsn    => 'elegans',
                           -aggregators => ['primary_transcript','clone']);
   my $segment  = $das->segment('Chr1');
   my @features = $segment->features;
   my $dna      = $segment->dna;