AcePerl
view release on metacpan or search on metacpan
$Error = '';
# Pseudonyms and deprecated methods.
*list = \&fetch;
*Ace::ERR = *Error;
# now completely deprecated and gone
# *find_many = \&fetch_many;
# *models = \&classes;
sub connect {
my $class = shift;
my ($host,$port,$user,$pass,$path,$program,
$objclass,$timeout,$query_timeout,$database,
$server_type,$url,$u,$p,$cache,$other);
# one-argument single "URL" form
if (@_ == 1) {
return $class->connect(-url=>shift);
}
'auto_save' => 0,
};
my $self = bless $contents,ref($class)||$class;
$self->_create_cache($cache) if $cache;
$self->name2db("$self",$self);
return $self;
}
sub reopen {
my $self = shift;
return 1 if $self->ping;
my $class = ref($self->{database});
my $database;
if ($self->{path}) {
$database = $class->connect(-path=>$self->{path},%{$self->other});
} else {
$database = $class->connect($self->{host},$self->{port}, $self->{timeout},
$self->{user},$self->{pass},%{$self->{other}});
}
unless ($database) {
$Ace::Error = "Couldn't open database";
return;
}
$self->{database} = $database;
1;
}
sub class {
my $self = shift;
my $d = $self->{class};
$self->{class} = shift if @_;
$d;
}
sub class_for {
my $self = shift;
my ($class,$id) = @_;
my $selected_class;
if (my $selector = $self->class) {
if (ref $selector eq 'HASH') {
$selected_class = $selector->{$class} || $selector->{'_DEFAULT_'};
}
elsif ($selector->can('class_for')) {
$selected_class = $selector->class_for($class,$id,$self);
}
$selected_class ||= 'Ace::Object';
eval "require $selected_class; 1;" || croak $@
unless $selected_class->can('new');
$selected_class;
}
sub process_url {
my $class = shift;
my $url = shift;
my ($host,$port,$user,$pass,$path,$server_type) = ('','','','','','');
if ($url) { # look for host:port
local $_ = $url;
if (m!^rpcace://([^:]+):(\d+)$!) { # rpcace://localhost:200005
($host,$port) = ($1,$2);
$server_type = 'Ace::RPC';
} elsif (m!^sace://([\w:]+)\@([^:]+):(\d+)$!) { # sace://user@localhost:2005
if ($user =~ /:/) {
($user,$pass) = split /:/,$user;
}
return ($host,$port,$user,$pass,$path,$server_type);
}
# Return the low-level Ace::AceDB object
sub db {
return $_[0]->{'database'};
}
# Fetch a model from the database.
# Since there are limited numbers of models, we cache
# the results internally.
sub model {
my $self = shift;
require Ace::Model;
my $model = shift;
my $break_cycle = shift; # for breaking cycles when following #includes
my $key = join(':',$self,'MODEL',$model);
$self->{'models'}{$model} ||= eval{$self->cache->get($key)};
unless ($self->{models}{$model}) {
$self->{models}{$model} =
Ace::Model->new($self->raw_query("model \"$model\""),$self,$break_cycle);
eval {$self->cache->set($key=>$self->{models}{$model})};
}
return $self->{'models'}{$model};
}
# cached get
# pass "1" for fill to get a full fill
# pass any other true value to get a tag fill
sub get {
my $self = shift;
my ($class,$name,$fill) = @_;
# look in caches first
my $obj = $self->memory_cache_fetch($class=>$name)
|| $self->file_cache_fetch($class=>$name);
return $obj if $obj;
# _acedb_get() does the caching
$obj = $self->_acedb_get($class,$name,$fill) or return;
$obj;
}
sub _acedb_get {
my $self = shift;
my ($class,$name,$filltag) = @_;
return unless $self->count($class,$name) >= 1;
#return $self->{class}->new($class,$name,$self,1) unless $filltag;
return ($self->_list)[0] unless $filltag;
if (defined $filltag && $filltag eq '1') { # full fill
return $self->_fetch();
} else {
return $self->_fetch(undef,undef,$filltag);
}
}
#### CACHE AND CARRY CODE ####
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ":",$self,$class,$name;
return unless defined $MEMORY_CACHE{$key};
carp "memory_cache hit on $class:$name"
if Ace->debug;
return $MEMORY_CACHE{$key};
}
sub memory_cache_store {
my $self = shift;
croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
my $obj = shift;
my $key = join ':',$obj->db,$obj->class,$obj->name;
return if exists $MEMORY_CACHE{$key};
carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
weaken($MEMORY_CACHE{$key} = $obj);
}
sub memory_cache_clear {
my $self = shift;
%MEMORY_CACHE = ();
}
sub memory_cache_delete {
my $package = shift;
my $obj = shift or croak "Usage: memory_cache_delete(\$obj)";
my $key = join ':',$obj->db,$obj->class,$obj->name;
delete $MEMORY_CACHE{$key};
}
# Call as:
# $ace->file_cache_fetch($class=>$id)
sub file_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ':',$class,$name;
my $cache = $self->cache or return;
my $obj = $cache->get($key);
if ($obj && !exists $obj->{'.root'}) { # consistency checks
require Data::Dumper;
warn "CACHE BUG! Discarding inconsistent object $obj\n";
warn Data::Dumper->Dump([$obj],['obj']);
$cache->remove($key);
return;
}
warn "cache ",$obj?'hit':'miss'," on '$key'\n" if Ace->debug;
$self->memory_cache_store($obj) if $obj;
$obj;
}
# call as
# $ace->file_cache_store($obj);
sub file_cache_store {
my $self = shift;
my $obj = shift;
return unless $obj->name;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
warn "caching $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
if ($key eq ':') { # something badly wrong
cluck "NULL OBJECT";
}
$cache->set($key,$obj);
}
sub file_cache_delete {
my $self = shift;
my $obj = shift;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
carp "deleting $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
$cache->remove($key,$obj);
}
#### END: CACHE AND CARRY CODE ####
# Fetch one or a group of objects from the database
sub fetch {
my $self = shift;
my ($class,$pattern,$count,$offset,$query,$filled,$total,$filltag) =
rearrange(['CLASS',['NAME','PATTERN'],'COUNT','OFFSET','QUERY',
['FILL','FILLED'],'TOTAL','FILLTAG'],@_);
if (defined $class
&& defined $pattern
&& $pattern !~ /[\?\*]/
# && !wantarray
) {
my(@h);
if ($filltag) {
@h = $self->_fetch($count,$offset,$filltag);
} else {
@h = $filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
return wantarray ? @h : $h[0];
}
sub cache {
my $self = shift;
my $d = $self->{filecache};
$self->{filecache} = shift if @_;
$d;
}
sub _create_cache {
my $self = shift;
my $params = shift;
$params = {} if $params and !ref $params;
return unless eval {require Cache::SizeAwareFileCache}; # not installed
(my $namespace = "$self") =~ s!/!_!g;
my %cache_params = (
namespace => $namespace,
%DEFAULT_CACHE_PARAMETERS,
%$params,
);
my $cache_obj = Cache::SizeAwareFileCache->new(\%cache_params);
$self->cache($cache_obj);
}
# class method
sub name2db {
shift;
my $name = shift;
return unless defined $name;
my $d = $NAME2DB{$name};
# weaken($NAME2DB{$name} = shift) if @_;
$NAME2DB{$name} = shift if @_;
$d;
}
# make a new object using indicated class and name pattern
sub new {
my $self = shift;
my ($class,$pattern) = rearrange([['CLASS'],['NAME','PATTERN']],@_);
croak "You must provide -class and -pattern arguments"
unless $class && $pattern;
# escape % signs in the string
$pattern = Ace->freeprotect($pattern);
$pattern =~ s/(?<!\\)%/\\%/g;
my $r = $self->raw_query("new $class $pattern");
if (defined($r) and $r=~/write access/im) { # this keeps changing
$Ace::Error = "Write access denied";
}
unless ($r =~ /($class)\s+\"([^\"]+)\"$/im) {
$Ace::Error = $r;
return;
}
$self->fetch($1 => $2);
}
# perform an AQL query
sub aql {
my $self = shift;
my $query = shift;
my $db = $self->db;
my $r = $self->raw_query("aql -j $query");
if ($r =~ /(AQL error.*)/) {
$self->error($1);
return;
}
my @r;
foreach (split "\n",$r) {
next if m!^\0!;
my ($class,$id) = Ace->split($_);
my @objects = map { $self->class_for($class,$id)->new(Ace->split($_),$self,1)} split "\t";
push @r,\@objects;
}
return @r;
}
# Return the contents of a keyset. Pattern matches are allowed, in which case
# the keysets will be merged.
sub keyset {
my $self = shift;
my $pattern = shift;
$self->raw_query (qq{find keyset "$pattern"});
$self->raw_query (qq{follow});
return $self->_list;
}
#########################################################
# These functions are for low-level (non OO) access only.
# This is for low-level access only.
sub show {
my ($self,$class,$pattern,$tag) = @_;
$Ace::Error = '';
return unless $self->count($class,$pattern);
# if we get here, then we've got some data to return.
my @result;
my $ts = $self->{'timestamps'} ? '-T' : '';
$self->{database}->query("show -j $ts $tag");
my $result = $self->read_object;
unless ($result =~ /(\d+) object dumped/m) {
$Ace::Error = 'Unexpected close during show';
return;
}
return grep (!m!^//!,split("\n\n",$result));
}
sub read_object {
my $self = shift;
return unless $self->{database};
my $result;
while ($self->{database}->status == STATUS_PENDING()) {
my $data = $self->{database}->read();
# $data =~ s/\0//g; # get rid of nulls in the buffer
$result .= $data if defined $data;
}
return $result;
}
# do a query, and return the result immediately
sub raw_query {
my ($self,$query,$no_alert,$parse) = @_;
$self->_alert_iterators unless $no_alert;
$self->{database}->query($query, $parse ? ACE_PARSE : () );
return $self->read_object;
}
# return the last error
sub error {
my $class = shift;
$Ace::Error = shift() if defined($_[0]);
$Ace::Error=~s/\0//g; # get rid of nulls
return $Ace::Error;
}
# close the database
sub close {
my $self = shift;
$self->raw_query('save') if $self->auto_save;
foreach (keys %{$self->{iterators}}) {
$self->_unregister_iterator($_);
}
delete $self->{database};
}
sub DESTROY {
my $self = shift;
return if caller() =~ /^Cache\:\:/;
warn "$self->DESTROY at ", join ' ',caller() if Ace->debug;
$self->close;
}
#####################################################################
###################### private routines #############################
sub rearrange {
my($order,@param) = @_;
return unless @param;
my %param;
if (ref $param[0] eq 'HASH') {
%param = %{$param[0]};
} else {
return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');
my $i;
$value = $param{$key};
delete $param{$key};
}
push(@return_array,$value);
}
push (@return_array,\%param) if %param;
return @return_array;
}
# do a query, but don't return the result
sub _query {
my ($self,@query) = @_;
$self->_alert_iterators;
$self->{'database'}->query("@query");
}
# return a portion of the active list
sub _list {
my $self = shift;
my ($count,$offset) = @_;
my (@result);
my $query = 'list -j';
$query .= " -b $offset" if defined $offset;
$query .= " -c $count" if defined $count;
my $result = $self->raw_query($query);
$result =~ s/\0//g; # get rid of &$#&@( nulls
foreach (split("\n",$result)) {
my ($class,$name) = Ace->split($_);
$obj = $self->class_for($class,$name)->new($class,$name,$self,1);
$self->memory_cache_store($obj);
$self->file_cache_store($obj);
}
push @result,$obj;
}
return @result;
}
# return a portion of the active list
sub _fetch {
my $self = shift;
my ($count,$start,$tag) = @_;
my (@result);
$tag = '' unless defined $tag;
my $query = "show -j $tag";
$query .= ' -T' if $self->{timestamps};
$query .= " -b $start" if defined $start;
$query .= " -c $count" if defined $count;
$self->{database}->query($query);
while (my @objects = $self->_fetch_chunk) {
if (my $obj = $self->memory_cache_store($_)) {
%$obj = %$_ unless $obj->filled; # contents copy -- replace partial object with full object
$_ = $obj;
} else {
$self->memory_cache_store($_);
}
}
return wantarray ? @result : $result[0];
}
sub _fetch_chunk {
my $self = shift;
return unless $self->{database}->status == STATUS_PENDING();
my $result = $self->{database}->read();
$result =~ s/\0//g; # get rid of &$#&@!! nulls
my @chunks = split("\n\n",$result);
my @result;
foreach (@chunks) {
next if m!^//!;
next unless /\S/; # occasional empty lines
my ($class,$id) = Ace->split($_); # /^\?([^?]+)\?([^?]+)\?/m;
push(@result,$self->class_for($class,$id)->newFromText($_,$self));
}
return @result;
}
sub _alert_iterators {
my $self = shift;
foreach (keys %{$self->{iterators}}) {
$self->{iterators}{$_}->invalidate if $self->{iterators}{$_};
}
undef $self->{active_list};
}
sub asString {
my $self = shift;
return "tace://$self->{path}" if $self->{'path'};
my $server = $self->db && $self->db->isa('Ace::SocketServer') ? 'sace' : 'rpcace';
return "$server://$self->{host}:$self->{port}" if $self->{'host'};
return ref $self;
}
sub cmp {
my ($self,$arg,$reversed) = @_;
my $cmp;
if (ref($arg) and $arg->isa('Ace')) {
$cmp = $self->asString cmp $arg->asString;
} else {
$cmp = $self->asString cmp $arg;
}
return $reversed ? -$cmp : $cmp;
}
# Count the objects matching pattern without fetching them.
sub count {
my $self = shift;
my ($class,$pattern,$query) = rearrange(['CLASS',
['NAME','PATTERN'],
'QUERY'],@_);
$Ace::Error = '';
# A special case occurs when we have already fetched this
# object and it is already on the active list. In this
# case, we do not need to recount.
$query = '' unless defined $query;
Copyright (c) 1997-1998 Cold Spring Harbor Laboratory
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
# -------------------- AUTOLOADED SUBS ------------------
sub debug {
my $package = shift;
my $d = $DEBUG_LEVEL;
$DEBUG_LEVEL = shift if @_;
$d;
}
# Return true if the database is still connected. This is oddly convoluted
# because there are numerous things that can go wrong, including:
# 1. server has gone away
# 2. server has timed out our connection! (grrrrr)
# 3. communications channel contains unread garbage and is in an inconsistent state
sub ping {
my $self = shift;
local($SIG{PIPE})='IGNORE'; # so we don't get a fatal exception during the check
my $result = $self->raw_query('');
return unless $result; # server has gone away
return if $result=~/broken connection|client time out/; # server has timed us out
return unless $self->{database}->status() == STATUS_WAITING(); #communications oddness
return 1;
}
# Get or set the display style for dates
sub date_style {
my $self = shift;
$self->{'date_style'} = $_[0] if defined $_[0];
return $self->{'date_style'};
}
# Get or set whether we retrieve timestamps
sub timestamps {
my $self = shift;
$self->{'timestamps'} = $_[0] if defined $_[0];
return $self->{'timestamps'};
}
# Add one or more objects to the database
sub put {
my $self = shift;
my @objects = @_;
my $count = 0;
$Ace::Error = '';
foreach my $object (@objects) {
croak "Can't put a non-Ace object into an Ace database"
unless $object->isa('Ace::Object');
croak "Can't put a non-object into a database"
unless $object->isObject;
$object = $object->fetch unless $object->isRoot; # make sure we're putting root object
$data =~ s/\n/; /mg;
my $result = $self->raw_query("parse = $data");
$Ace::Error = $result if $result =~ /sorry|parse error/mi;
return $count if $Ace::Error;
$count++; # bump if succesful
}
return $count;
}
# Parse a single object and return the result as an object
sub parse {
my $self = shift;
my $ace_data = shift;
my @lines = split("\n",$ace_data);
foreach (@lines) { s/;/\\;/; } # protect semicolons
my $query = join("; ",@lines);
my $result = $self->raw_query("parse = $query");
$Ace::Error = $result=~/sorry|parse error/mi ? $result : '';
my @results = $self->_list(1,0);
return $results[0];
}
# Parse a single object as longtext and return the result
# as an object
sub parse_longtext {
my $self = shift;
my ($title,$body) = @_;
my $mm = "parse =
Longtext $title
$body
***LongTextEnd***
" ;
$mm =~ s/\//\\\//g ;
$mm =~ s/\n/\\n/g ;
$mm .= "\n" ;
my $result = $self->raw_query($mm) ;
$Ace::Error = $result=~/sorry|parse error/mi ? $result : '';
my @results = $self->_list(1,0);
return $results[0];
}
# Parse a file and return all the results
sub parse_file {
my $self = shift;
my ($file,$keepgoing) = @_;
local(*ACE);
local($/) = ''; # paragraph mode
my(@objects,$errors);
open(ACE,$file) || croak "$file: $!";
while (<ACE>) {
chomp;
my $obj = $self->parse($_);
unless ($obj) {
}
push(@objects,$obj);
}
close ACE;
$Ace::Error = $errors;
return @objects;
}
# Create a new Ace::Object in the indicated database
# (doesn't actually write into database until you do a commit)
sub new {
my $self = shift;
my ($class,$name) = rearrange([qw/CLASS NAME/],@_);
return if $self->fetch($class,$name);
my $obj = $self->class_for($class,$name)->new($class,$name,$self);
return $obj;
}
# Return the layout, which contains classes that should be displayed
sub layout {
my $self = shift;
my $result = $self->raw_query('layout');
$result=~s{\n(\s*\n|//.*\n|\0)+\Z}{}m; # get rid of extraneous information
$result;
}
# Return a hash of all the classes and the number of objects in each
sub class_count {
my $self = shift;
return $self->raw_query('classes') =~ /^\s+(\S+) (\d+)/gm;
}
# Return a hash of miscellaneous status information from the server
# (to be expanded later)
sub status {
my $self = shift;
my $data = $self->raw_query('status');
study $data;
my %status;
# -Code section
my ($program) = $data=~/Program:\s+(.+)/m;
my ($aceversion) = $data=~/Version:\s+(.+)/m;
my ($build) = $data=~/Build:\s+(.+)/m;
my ($keys) = $data=~/keys:\s+(\d+)/;
my ($memory) = $data=~/blocks:\s+\d+,\s+allocated \(kb\):\s+(\d+)/;
$status{resources} = {
classes => $classes,
keys => $keys,
memory => $memory * 1024,
};
return wantarray ? %status : \%status;
}
sub title {
my $self = shift;
my $status= $self->status;
$status->{database}{title};
}
sub version {
my $self = shift;
my $status= $self->status;
$status->{database}{version};
}
sub auto_save {
my $self = shift;
if ($self->db && $self->db->can('auto_save')) {
$self->db->auto_save;
} else {
$self->{'auto_save'} = $_[0] if defined $_[0];
return $self->{'auto_save'};
}
}
# Perform an ace query and return the result
sub find {
my $self = shift;
my ($query,$count,$offset,$filled,$total) = rearrange(['QUERY','COUNT',
'OFFSET',['FILL','FILLED'],'TOTAL'],@_);
$offset += 0;
$query = "find $query" unless $query=~/^find/i;
my $cnt = $self->count(-query=>$query);
$$total = $cnt if defined $total;
return $cnt unless wantarray;
$filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
#########################################################
# Grep function returns count in a scalar context, list
# of retrieved objects in a list context.
sub grep {
my $self = shift;
my ($pattern,$count,$offset,$filled,$filltag,$total,$long) =
rearrange(['PATTERN','COUNT','OFFSET',['FILL','FILLED'],'FILLTAG','TOTAL','LONG'],@_);
$offset += 0;
my $grep = defined($long) && $long ? 'LongGrep' : 'grep';
my $r = $self->raw_query("$grep $pattern");
my ($cnt) = $r =~ /Found (\d+) objects/m;
$$total = $cnt if defined $total;
return $cnt if !wantarray;
if ($filltag) {
@h = $self->_fetch($count,$offset,$filltag);
} else {
@h = $filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
@h;
}
sub pick {
my ($self,$class,$item) = @_;
$Ace::Error = '';
# assumption of uniqueness of name is violated by some classes!
# return () unless $self->count($class,$item) == 1;
return unless $self->count($class,$item) >= 1;
# if we get here, then we've got some data to return.
# yes, we're repeating code slightly...
my @result;
my $ts = $self->{'timestamps'} ? '-T' : '';
$Ace::Error = 'Unexpected close during pick';
return;
}
@result = grep (!m!^\s*//!,split("\n\n",$result));
return $result[0];
}
# these two only get loaded if the Ace::Freesubs .XS isn't compiled
sub freeprotect {
my $class = shift;
my $text = shift;
$text =~ s/\n/\\n/g;
$text =~ s/\t/\\t/g;
$text =~ s/"/\\"/g;
return qq("$text");
}
sub split {
my $class = shift;
my $text = shift;
$text =~ s/\\n/\n/g;
$text =~ s/\\t/\t/g;
my ($id,$ts);
($class,$id,$ts) = $text=~m/^\?(.+)(?<!\\)\?(.+)(?<!\\)\?([^?]*)$/s;
$class ||= ''; # fix uninitialized variable warnings
$id ||= '';
$class =~ s/\\\?/?/g;
$id =~ s/\\\?/?/g;
return ($class,$id) unless $ts;
return ($class,$id,$ts); # return timestamp
}
# Return a list of all the classes known to the server.
sub classes {
my ($self,$invisible) = @_;
my $query = defined($invisible) && $invisible ?
"query find class !buried"
:
"query find class visible AND !buried";
$self->raw_query($query);
return $self->_list;
}
################## iterators ##################
# Fetch many objects in iterative style
sub fetch_many {
my $self = shift;
my ($class,$pattern,$filled,$query,$chunksize) = rearrange( ['CLASS',
['PATTERN','NAME'],
['FILL','FILLED'],
'QUERY',
'CHUNKSIZE'],@_);
$pattern ||= '*';
$pattern = Ace->freeprotect($pattern);
if (defined $query) {
$query = "query $query" unless $query=~/^query\s/;
} elsif (defined $class) {
$query = qq{query find $class $pattern};
} else {
croak "must call fetch_many() with the -class or -query arguments";
}
my $iterator = Ace::Iterator->new($self,$query,$filled,$chunksize);
return $iterator;
}
sub _register_iterator {
my ($self,$iterator) = @_;
$self->{iterators}{$iterator} = $iterator;
}
sub _unregister_iterator {
my ($self,$iterator) = @_;
$self->_restore_iterator($iterator);
delete $self->{iterators}{$iterator};
}
sub _save_iterator {
my $self = shift;
my $iterator = shift;
return unless $self->{iterators}{$iterator};
$self->{iterator_stack} ||= [];
return 1 if grep { $_ eq $iterator } @{$self->{iterator_stack}};
$self->raw_query("spush",'no_alert');
unshift @{$self->{iterator_stack}},$iterator;
1; # result code -- CHANGE THIS LATER
}
# horrid method that keeps the database's view of
# iterators in synch with our view
sub _restore_iterator {
my $self = shift;
my $iterator = shift;
# no such iterator known, return false
return unless $self->{iterators}{$iterator};
# make other iterators save themselves
$self->_alert_iterators;
# fetch the list of iterators stored on the stack
($result =~ /stack is (now )?empty/ && @$list == 1)
) {
$Ace::Error = 'Unexpected result from spick: $result';
return;
}
splice(@$list,$i,1); # remove from position
return 1;
}
sub datetime {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d %02d:%02d:%02d",$year,$mon+1,$day,$hour,$min,$sec);
}
sub date {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d",$year,$mon+1,$day);
}
Ace/Browser/AceSubs.pm view on Meta::CPAN
use constant SEARCH_BROWSE => 'search'; # a fallback search script
my %VALID; # cache for get_symbolic() lookups
=item AceError($message)
This subroutine will print out an error message and exit the script.
The text of the message is taken from $message.
=cut
sub AceError {
my $msg = shift;
PrintTop(undef,undef,'Error');
print CGI::font({-color=>'red'},$msg);
PrintBottom();
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item AceHeader()
Ace/Browser/AceSubs.pm view on Meta::CPAN
=item AceAddCookie(@cookies)
This subroutine, which must be called b<after> OpenDatabase() and/or
GetAceObject() and b<before> PrintTop(), will add one or more cookies
to the outgoing HTTP headers that are emitted by AceHeader().
Cookies must be CGI::Cookie objects.
=cut
sub AceAddCookie {
push @COOKIES,@_; # add caller's to our globals
}
################## canned header ############
sub AceHeader {
my %searches = map {$_=>1} Configuration()->searches;
my $quovadis = url(-relative=>1);
my $db = get_symbolic();
my $referer = referer();
$referer =~ s!^http://[^/]+!! if defined $referer;
my $home = Configuration()->Home->[0] if Configuration()->Home;
Ace/Browser/AceSubs.pm view on Meta::CPAN
database. If the database cannot be opened, it generates an error
message and exits. This subroutine is not exported by default, but is
called by PrintTop() and Header() internally.
=cut
# Subroutines used by all scripts.
# Will generate an HTTP 'document not found' error if you try to get an
# undefined database name. Check the return code from this function and
# return immediately if not true (actually, not needed because we exit).
sub AceInit {
$HEADER = 0;
$TOP = 0;
@COOKIES = ();
# keeps track of what sections should be open
%OPEN = param('open') ? map {$_ => 1} split(' ',param('open')) : () ;
return 1 if Configuration();
# if we get here, it is a big NOT FOUND error
Ace/Browser/AceSubs.pm view on Meta::CPAN
This subroutine will print out an error message indicating that an
object is present in AceDB, but that the information the user
requested is absent. It will then exit the script. This is
infrequently encountered when following XREFed objects. If the class
and name of the object are not provided as arguments, they are taken
from CGI's param() function.
=cut
sub AceMissing {
my ($class,$name) = @_;
$class ||= param('class');
$name ||= param('name');
PrintTop(undef,undef,$name);
print strong('There is no further information about this object in the database.');
PrintBottom();
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
Ace/Browser/AceSubs.pm view on Meta::CPAN
$report The symbolic name of the current display, or undef
if none.
$objects An array reference containing the Ace objects in
question.
This subroutine is not exported by default.
=cut
sub AceMultipleChoices {
my ($symbol,$report,$objects) = @_;
if ($objects && @$objects == 1) {
my $destination = Object2URL($objects->[0]);
AceHeader(-Refresh => "1; URL=$destination");
print start_html (
'-Title' => 'Redirect',
'-Style' => Style(),
),
h1('Redirect'),
p("Automatically transforming this query into a request for corresponding object",
Ace/Browser/AceSubs.pm view on Meta::CPAN
=item AceNotFound([$class,$name])
This subroutine will print out an error message indicating that the
requested object is not present in AceDB, even as a name. It will then
exit the script. If the class and name of the object are not provided
as arguments, they are taken from CGI's param() function.
=cut
sub AceNotFound {
my $class = shift || param('class');
my $name = shift || param('name');
PrintTop(undef,undef,"$class: $name not found");
print p(font({-color => 'red'},
strong("The $class named \"$name\" is not found in the database.")));
PrintBottom();
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item ($uri,$physical_path) = AcePicRoot($directory)
This function returns the physical and URL paths of a temporary
directory in which the pic script can write pictures. Not exported by
default. Returns a two-element list containing the URL and physical
path.
=cut
sub AcePicRoot {
my $path = shift;
my $umask = umask();
umask 002; # want this writable by group
my ($picroot,$uri);
if ($ENV{MOD_PERL} && Apache->can('request')) { # we have apache, so no reason not to take advantage of it
my $r = Apache->request;
$uri = join('/',Configuration()->Pictures->[0],"/",$path);
my $subr = $r->lookup_uri($uri);
$picroot = $subr->filename if $subr;
} else {
Ace/Browser/AceSubs.pm view on Meta::CPAN
This subroutine is not exported by default. It differs from
DoRedirect() in that it displays a message to the user for two seconds
before it generates the new page. It also allows the display to be set
explicitly, rather than determined automatically by the AceBrowser
system.
=cut
############### redirect to a different report #####################
sub AceRedirect {
my ($report,$object) = @_;
my $url = Configuration()->display($report,'url');
my $args = ref($object) ? "name=$object&class=".$object->class
: "name=$object";
my $destination = ResolveUrl($url => $args);
AceHeader(-Refresh => "1; URL=$destination");
print start_html (
'-Title' => 'Redirect',
Ace/Browser/AceSubs.pm view on Meta::CPAN
=item $configuration = Configuration()
The Configuration() function returns the Ace::Browser::SiteDefs object
for the current session. From this object you can retrieve
information from the configuration file.
=cut
# get the configuration object for this database
sub Configuration {
my $s = get_symbolic()||return;
return Ace::Browser::SiteDefs->getConfig($s);
}
=item $name = DB_Name()
This function returns the symbolic name of the current database, for
example "default".
=cut
Ace/Browser/AceSubs.pm view on Meta::CPAN
Ace::Object indicated by $object and exits the script. It must be
called before PrintTop() or any other HTML-generating code. It
differs from AceRedirect() in that it generates a fast redirect
without alerting the user.
This function is not exported by default.
=cut
# redirect to the URL responsible for an object
sub DoRedirect {
my $obj = shift;
print redirect(Object2URL($obj));
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item $footer = Footer()
This function returns the contents of the footer as a string, but does
not print it out. It is not exported by default.
=cut
# Contents of the HTML footer. It gets printed immediately before the </BODY> tag.
# The one given here generates a link to the "feedback" page, as well as to the
# privacy statement. You may or may not want these features.
sub Footer {
if (my $footer = Configuration()->Footer) {
return $footer;
}
my $webmaster = $ENV{SERVER_ADMIN} || 'webmaster@sanger.ac.uk';
my $obj_name = escape(param('name'));
my $obj_class = escape(param('class')) || ucfirst url(-relative=>1);
my $referer = escape(self_url());
my $name = get_symbolic();
Ace/Browser/AceSubs.pm view on Meta::CPAN
"name" and "class" CGI variables.
If a single object is found, the function returns it as the function
result. If no objects are found, it returns undef. If more than one
object is found, the function invokes AceMultipleChoices() and exits
the script.
=cut
# open database, return object requested by CGI parameters
sub GetAceObject {
my $db = OpenDatabase() || AceError("Couldn't open database."); # exits
my $name = param('name') or return;
my $class = param('class') or return;
my @objs = $db->fetch($class => $name);
if (@objs > 1) {
AceMultipleChoices($name,'',\@objs);
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
return $objs[0];
}
=item $html = Header()
This subroutine returns the boilerplate at the top of the HTML page as
a string, but does not print it out. It is not exported by default.
=cut
sub Header {
my $config = Configuration();
my $dbname = get_symbolic();
return unless my $searches = $config->Searches;
my $banner = $config->Banner;
# next select the correct search script
my @searches = @{$searches};
my $self = url(-relative=>1);
my $modperl = $ENV{MOD_PERL} && Apache->can('request') && eval {Apache->request->dir_config('AceBrowserConf')};
Ace/Browser/AceSubs.pm view on Meta::CPAN
configuration settings.
It is also possible to pass Object2URL an object name and class, in
the case that an AceDB object isn't available.
The return value is a URL.
=cut
# general mapping from a display to a url
sub Object2URL {
my ($object,$extra) = @_;
my ($name,$class);
if (ref($object)) {
($name,$class) = ($object,$object->class);
} else {
($name,$class) = ($object,$extra);
}
my $display = url(-relative=>1);
my ($disp,$parameters) = Configuration()->map_url($display,$name,$class);
return $disp unless $parameters;
Ace/Browser/AceSubs.pm view on Meta::CPAN
my $author = $db->fetch(Author => 'Sulston JE');
print ObjectLink($author,$author->Full_name);
This will print out a link to a page that will display details on the
author page. The text of the link will be the value of the Full_name
tag.
=cut
sub ObjectLink {
my $object = shift;
my $link_text = shift;
my $target = shift;
my $url = Object2URL($object,@_) or return ($link_text || "$object");
my @targ = $target ? (-target=>$target) : ();
return a({-href=>Object2URL($object,@_),-name=>"$object",@targ},($link_text || "$object"));
}
=item $db = OpenDatabase()
Ace/Browser/AceSubs.pm view on Meta::CPAN
file. In modperl environments, this function caches database handles
and reuses them, pinging and reopening them in the case of timeouts.
This function is not exported by default.
=cut
use Carp 'cluck';
################ open a database #################
sub OpenDatabase {
my $name = shift || get_symbolic();
AceInit();
$name =~ s!/$!!;
my $db = $DB{$name};
return $db if $db && $db->ping;
my ($host,$port,$user,$password,
$cache_root,$cache_size,$cache_expires,$auto_purge_interval)
= getDatabasePorts($name);
my @auth = (-user=>$user,-pass=>$password) if $user && $password;
Ace/Browser/AceSubs.pm view on Meta::CPAN
header. If not provided, a generic title "Report for
Object" is generated.
@html_headers Additional HTML headers to pass to the the CGI.pm
start_html.
=cut
# boilerplate for the top of the page
sub PrintTop {
my ($object,$class,$title,@additional_header_stuff) = @_;
return if $TOP++;
$class = $object->class if defined $object && ref($object);
$class ||= param('class') unless defined($title);
AceHeader();
$title ||= defined($object) ? "$class Report for: $object" : $class ? "$class Report" : ''
unless defined($title);
print start_html (
'-Title' => $title,
'-Style' => Style(),
Ace/Browser/AceSubs.pm view on Meta::CPAN
=item PrintBottom()
The PrintBottom() function outputs all the boilerplate at the bottom
of a typical AceBrowser page. If a user-defined footer is present in
the configuration file, that is printed. Otherwise, the method prints
a horizontal rule followed by links to the site home page, the AcePerl
home page, the privacy policy, and the feedback page.
=cut
sub PrintBottom {
print hr,Footer(),end_html();
}
=item $hashref = Style()
This subroutine returns a hashref containing a reference to the
configured stylesheet, in the following format:
{ -src => '/ace/stylesheets/current_stylesheet.css' }
Ace/Browser/AceSubs.pm view on Meta::CPAN
needed) and then tack the parameters onto the end.
A typical call is:
$url = ResolveUrl('/cgi-bin/ace/generic/tree','name=fred;class=Author');
This function is not exported by default.
=cut
sub ResolveUrl {
my ($url,$param) = @_;
my ($main,$query,$frag) = $url =~ /^([^?\#]+)\??([^\#]*)\#?(.*)$/ if defined $url;
$main ||= '';
if (!defined $APACHE_CONF) {
$APACHE_CONF = eval { Apache->request->dir_config('AceBrowserConf') } ? 1 : 0;
}
$main = Configuration()->resolvePath($main) unless $main =~ m!^/!;
if (my $id = get_symbolic()) {
Ace/Browser/AceSubs.pm view on Meta::CPAN
}
$main .= "?$query" if $query; # put the query string back
$main .= "?$param" if $param and !$query;
$main .= ";$param" if $param and $query;
$main .= "#$frag" if $frag;
return $main;
}
# A consistent stylesheet across pages
sub Style {
my $stylesheet = Configuration()->Stylesheet;
return { -src => $stylesheet };
}
=item $boolean = Toggle($section,[$label,$object_count,$add_plural,$add_count])
=item ($link,$bool) = Toggle($section,$label,$object_count,$add_plural,$add_count)
The Toggle() subroutine makes it easy to create HTML sections that
open and close when the user selects a toggle icon (a yellow
Ace/Browser/AceSubs.pm view on Meta::CPAN
my $sequence = GetAceObject();
print "sequence name = ",$sequence,"\n";
print "sequence clone = ",$sequence->Clone,"\n";
my ($link,$open) = Toggle('dna','Sequence DNA');
print $link;
print $sequence->asDNA if $open;
=cut
# Toggle a subsection open and close
sub Toggle {
my ($section,$label,$count,$addplural,$addcount,$max_open) = @_;
$OPEN{$section}++ if defined($max_open) && $count <= $max_open;
my %open = %OPEN;
$label ||= $section;
my $img;
if (exists $open{$section}) {
delete $open{$section};
$img = img({-src=>'/ico/triangle_down.gif',-alt=>'^',
-height=>6,-width=>11,-border=>0}),
Ace/Browser/AceSubs.pm view on Meta::CPAN
=item $html = TypeSelector($name,$class)
This subroutine generates the HTML for the type selector navigation
bar. The links in the bar are dynamically generated based on the
values of $name and $class. This function is called by PrintTop().
It is not exported by default.
=cut
# Choose a set of displayers based on the type.
sub TypeSelector {
my ($name,$class) = @_;
return unless $class;
my ($n,$c) = (escape("$name"),escape($class));
my @rows;
# add the special displays
my @displays = Configuration()->class2displays($class,$name);
my @basic_displays = Configuration()->class2displays('default');
@basic_displays = Ace::Browser::SiteDefs->getConfig(DEFAULT_DATABASE)->class2displays('default')
Ace/Browser/AceSubs.pm view on Meta::CPAN
AceBrowser may need to attach the database name to the URL in order to
identify it.
Example:
my $url = Url('../sequence_dump',"name=$name;long_dump=yes");
print a({-href=>$url},'Dump this sequence');
=cut
sub Url {
my ($display,$parameters) = @_;
my $url = Configuration()->display($display,'url');
return ResolveUrl($url,$parameters);
}
sub Open_table{
print '<table width=660>
<tr>
<td>';
}
sub Close_table{
print '</tr>
</td>
</table>';
}
# return host and port for symbolic database name
sub getDatabasePorts {
my $name = shift;
my $config = Ace::Browser::SiteDefs->getConfig($name);
return ($config->Host,$config->Port,
$config->Username,$config->Password,
$config->Cacheroot,$config->Cachesize,$config->Cacheexpires,$config->Cachepurge,
) if $config;
# If we get here, then try getservbynam()
# I think this is a bit of legacy code.
my @s = getservbyname($name,'tcp');
return unless @s;
return unless $s[2]>1024; # don't allow connections to reserved ports
return ('localhost',$s[2]);
}
sub get_symbolic {
if (exists $ENV{MOD_PERL} && Apache->can('request')) { # the easy way
if (my $r = Apache->request) {
if (my $conf = $r->dir_config('AceBrowserConf')) {
my ($name) = $conf =~ m!([^/]+)\.(?:pm|conf)$!;
return $name if $name;
}
}
}
Ace/Browser/SearchSubs.pm view on Meta::CPAN
use constant LEFT_ICON => 'cylarrw.gif';
use constant RIGHT_ICON => 'cyrarrw.gif';
=item $offset = AceSearchOffset()
When the user is paging back and forth among a multi-page list of
results, this function returns the index of the first item to display.
=cut
sub AceSearchOffset {
my $offset = param('offset') || 0;
$offset += param('scroll') if param('scroll');
$offset;
}
=item AceSearchTable([{hash}],$title,@contents)
Given a title and the HTML contents, this formats the search into a
table and gives it the background and foreground colors used elsewhere
for searches. The formatted search is then printed.
The HTML contents are usually a fill-out form. For convenience, you
can provide the contents in multiple parts (lines or elements) and
they will be concatenated together.
If the first argument is a hashref, then its contents will be passed
to start_form() to override the form arguments.
=cut
sub AceSearchTable {
my %attributes = %{shift()} if ref($_[0]) eq 'HASH';
my ($title,@body) = @_;
print
start_form(-action=>url(-absolute=>1,-path_info=>1).'#results',%attributes),
a({-name=>'search'},''),
table({-border=>0,-width=>'100%'},
TR({-valign=>'MIDDLE'},
td({-class=>'searchbody'},@body))),
end_form;
}
Ace/Browser/SearchSubs.pm view on Meta::CPAN
my $count;
my @objs = $db->fetch(-query=> $query,
-count => MAXOBJECTS,
-offset => $offset,
-total => \$count
);
AceResultsTable(\@objs,$count,$offset,'Here are the results');
=cut
sub AceResultsTable {
my ($objects,$count,$offset,$title) = @_;
Delete('scroll');
param(-name=>'offset',-value=>$offset);
my @cheaders = map { $offset + ROWS * $_ } (0..(@$objects-1)/ROWS) if @$objects;
my @rheaders = (1..min(ROWS,$count));
$title ||= 'Search Results';
print
a({-name=>'results'},''),
Ace/Browser/SearchSubs.pm view on Meta::CPAN
my $need_navbar = $offset > 0 || $count >= MAXOBJECTS;
my @buttons = make_navigation_bar($offset,$count) if $need_navbar;
print table({-width=>'50%',-align=>'CENTER'},Tr(@buttons)) if $need_navbar;
print table({-width=>'100%'},tableize(ROWS,COLS,\@rheaders,\@cheaders,@$objects));
print end_td,end_Tr,end_table,p();
}
# ------ ugly internal routines for scrolling along the search results list -----
sub make_navigation_bar {
my($offset,$count) = @_;
my (@buttons);
my ($page,$pages) = (1+int($offset/MAXOBJECTS),1+int($count/MAXOBJECTS));
my $c = Configuration();
my $icons = $c->Icons || '/ico';
my $spacer = "$icons/". SPACER_ICON;
my $left = "$icons/". LEFT_ICON;
my $right = "$icons/". RIGHT_ICON;
my $url = url(-absolute=>1,-query=>1);
# my $url = self_url();
Ace/Browser/SearchSubs.pm view on Meta::CPAN
$offset + MAXOBJECTS <= $count
? a({-href=>$url
. '&scroll=+' . MAXOBJECTS},
img({-src=>$right,-alt=>'NEXT >',-border=>0}))
: img({-src=>$spacer,-alt=>''})
)
);
@buttons;
}
sub min { return $_[0] < $_[1] ? $_[0] : $_[1] }
#line 295
sub tableize {
my($rows,$columns,$rheaders,$cheaders,@elements) = @_;
my($result);
my($row,$column);
$result .= TR($rheaders ? th(' ') : (),th({-align=>'LEFT'},$cheaders))
if $cheaders and @$cheaders > 1;
for ($row=0;$row<$rows;$row++) {
next unless defined($elements[$row]);
$result .= "<TR>";
$result .= qq(<TH ALIGN=LEFT CLASS="search">$rheaders->[$row]</TH>) if $rheaders;
for ($column=0;$column<$columns;$column++) {
Ace/Browser/SiteDefs.pm view on Meta::CPAN
use Carp;
use vars qw($AUTOLOAD);
# get location of configuration file
use Ace::Browser::LocalSiteDefs '$SITE_DEFS';
my %CONFIG;
my %CACHETIME;
my %CACHED;
sub getConfig {
my $package = shift;
my $name = shift;
croak "Usage: getConfig(\$database_name)" unless defined $name;
$package = ref $package if ref $package;
my $file = "${name}.pm";
# make search relative to SiteDefs.pm file
my $path = $package->get_config || $package->resolveConf($file);
return unless -r $path;
return $CONFIG{$name} if exists $CONFIG{$name} and $CACHETIME{$name} >= (stat($path))[9];
return unless $CONFIG{$name} = $package->_load($path);
$CONFIG{$name}->{'name'} ||= $name; # remember name
$CACHETIME{$name} = (stat($path))[9];
return $CONFIG{$name};
}
sub modtime {
my $package = shift;
my $name = shift;
if (!$name && ref($package)) {
$name = $package->Name;
}
return $CACHETIME{$name};
}
sub AUTOLOAD {
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
my $self = shift;
croak "Unknown field \"$func_name\"" unless $func_name =~ /^[A-Z]/;
return $self->{$func_name} = $_[0] if defined $_[0];
return $self->{$func_name} if defined $self->{$func_name};
# didn't find it, so get default
return if (my $dflt = $pack->getConfig('default')) == $self;
return $dflt->{$func_name};
}
sub DESTROY { }
sub map_url {
my $self = shift;
my ($display,$name,$class) = @_;
$class ||= $name->class if ref($name) and $name->can('class');
my (@result,$url);
if (my $code = $self->Url_mapper) {
if (@result = $code->($display,$name,$class)) {
return @result;
}
Ace/Browser/SiteDefs.pm view on Meta::CPAN
push @displays,$self->displays('default') unless @displays;
my $n = CGI::escape($name);
my $c = CGI::escape($class);
return ($displays[0],"name=$n;class=$c") if $displays[0];
return unless @result = $self->getConfig('default')->Url_mapper->($display,$name,$class);
return unless $url = $self->display($result[0],'url');
return ($url,$result[1]);
}
sub searches {
my $self = shift;
return unless my $s = $self->Searches;
return @{$s} unless defined $_[0];
return $self->Search_titles->{$_[0]};
}
# displays() => list of display names
# displays($name) => hash reference for display
# displays($name=>$field) => displays at {field}
sub display {
my $self = shift;
return unless my $d = $self->Displays;
return keys %{$d} unless defined $_[0];
return unless exists $d->{$_[0]};
return $d->{$_[0]} unless defined $_[1];
return $d->{$_[0]}{$_[1]};
}
sub displays {
my $self = shift;
return unless my $d = $self->Classes;
return keys %$d unless @_;
my ($class,$name) = @_;
my $type = ucfirst(lc($class));
return unless exists $d->{$type};
my $value = $d->{$type};
if (ref $value eq 'CODE') { # oh, wow, a subroutine
my @v = $value->($type,$name); # invoke to get list of displays
return wantarray ? @v : \@v;
} else {
return wantarray ? @{$value} : $value;
}
}
sub class2displays {
my $self = shift;
my ($class,$name) = @_;
# No class specified. Return name of all defined classes.
return $self->displays unless defined $class;
# A class is specified. Map it into the list of display records.
my @displays = map {$self->display($_)} $self->displays($class,$name);
return @displays;
}
sub _load {
my $package = shift;
my $file = shift;
no strict 'vars';
no strict 'refs';
$file =~ m!([/a-zA-Z0-9._-]+)!;
my $safe = $1;
(my $ns = $safe) =~ s/\W/_/g;
my $namespace = __PACKAGE__ . '::Config::' . $ns;
Ace/Browser/SiteDefs.pm view on Meta::CPAN
# special case: get the search scripts as both an array and as a hash
if (my @searches = @{"$namespace\:\:SEARCHES"}) {
$data{Searches} = [ @searches[map {2*$_} (0..@searches/2-1)] ];
%{$data{Search_titles}} = @searches;
}
# return this thing as a blessed object
return bless \%data,$package;
}
sub resolvePath {
my $self = shift;
my $file = shift;
my $root = $self->Root || '/cgi-bin';
return "$root/$file";
}
sub resolveConf {
my $pack = shift;
my $file = shift;
unless ($SITE_DEFS) {
(my $rpath = __PACKAGE__) =~ s{::}{/}g;
my $path = $INC{"${rpath}.pm"}
|| warn "Unexpected error: can't locate acebrowser SiteDefs.pm file";
$path =~ s![^/]*$!!; # trim to directory
$SITE_DEFS = $path;
}
return "$SITE_DEFS/$file";
}
sub get_config {
my $pack = shift;
return unless exists $ENV{MOD_PERL};
my $r = Apache->request;
return $r->dir_config('AceBrowserConf');
}
sub Name {
Ace::Browser::AceSubs->get_symbolic();
}
1;
Ace/Browser/TreeSubs.pm view on Meta::CPAN
# less than or equal to this number
use constant MAXEXPAND => 4;
# A hack to allow access to external images.
# We use the name of the database as a URL to an external image.
# The URL will look like this:
# /ace_images/external/database_name/foo.gif
# You must arrange for the URL to return the correct image, either with
# a CGI script, a symbolic link, or a redirection directive.
sub AceImageHackURL {
my $image_name = shift;
# correct some bad image file names in the database
$image_name .= '.jpeg' unless $image_name =~ /\.(gif|jpg|jpeg|png|tiff|ps)$/;
my $picture_path = Configuration->Pictures->[0];
return join('/',$picture_path,Configuration->Name,'external',escape("$image_name"));
}
1;
Ace/Graphics/Fk.pm view on Meta::CPAN
# usage:
# Ace::Graphics::Fk->new(
# -start => 1,
# -end => 100,
# -name => 'fred feature',
# -info => $additional_stuff_to_store,
# -strand => +1);
#
# Alternatively, use -segments => [ [start,stop],[start,stop]...]
# to create a multisegmented feature.
sub new {
my $class= shift;
my %arg = @_;
my $self = bless {},$class;
$arg{-strand} ||= 0;
$self->{strand} = $arg{-strand} >= 0 ? +1 : -1;
$self->{name} = $arg{-name};
$self->{info} = $arg{-info};
Ace/Graphics/Fk.pm view on Meta::CPAN
$self->{segments} = [ sort {$a->start <=> $b->start } @segments ];
} else {
$self->{start} = $arg{-start};
$self->{end} = $arg{-end} || $arg{-stop};
}
$self;
}
sub segments {
my $self = shift;
my $s = $self->{segments} or return;
@$s;
}
sub strand { shift->{strand} }
sub name { shift->{name} }
sub start {
my $self = shift;
if (my @segments = $self->segments) {
return $segments[0]->start;
}
return $self->{start};
}
sub end {
my $self = shift;
if (my @segments = $self->segments) {
return $segments[-1]->end;
}
return $self->{end};
}
sub length {
my $self = shift;
return $self->end - $self->start + 1;
}
sub introns {
my $self = shift;
return;
}
sub source_tag { 'dummy' }
sub target { }
sub info {
my $self = shift;
return $self->{info} || $self->name;
}
1;
__END__
=head1 NAME
Ace/Graphics/Glyph.pm view on Meta::CPAN
package Ace::Graphics::Glyph;
use strict;
use GD;
# simple glyph class
# args: -feature => $feature_object
# args: -factory => $factory_object
sub new {
my $class = shift;
my %arg = @_;
my $feature = $arg{-feature};
my ($start,$end) = ($feature->start,$feature->end);
($start,$end) = ($end,$start) if $start > $end;
return bless {
@_,
top => 0,
left => 0,
right => 0,
start => $start,
end => $end
},$class;
}
# delegates
# any of these can be overridden safely
sub factory { shift->{-factory} }
sub feature { shift->{-feature} }
sub fgcolor { shift->factory->fgcolor }
sub bgcolor { shift->factory->bgcolor }
sub fontcolor { shift->factory->fontcolor }
sub fillcolor { shift->factory->fillcolor }
sub scale { shift->factory->scale }
sub width { shift->factory->width }
sub font { shift->factory->font }
sub option { shift->factory->option(shift) }
sub color {
my $self = shift;
my $factory = $self->factory;
my $color = $factory->option(shift) or return $self->fgcolor;
$factory->translate($color);
}
sub start { shift->{start} }
sub end { shift->{end} }
sub offset { shift->factory->offset }
sub length { shift->factory->length }
# this is a very important routine that dictates the
# height of the bounding box. We start with the height
# dictated by the factory, and then adjust if needed
sub height {
my $self = shift;
$self->{cache_height} = $self->calculate_height unless exists $self->{cache_height};
return $self->{cache_height};
}
sub calculate_height {
my $self = shift;
my $val = $self->factory->height;
$val += $self->labelheight if $self->option('label');
$val;
}
# change our offset
sub move {
my $self = shift;
my ($dx,$dy) = @_;
$self->{left} += $dx;
$self->{top} += $dy;
}
# positions, in pixel coordinates
sub top { shift->{top} }
sub bottom { my $s = shift; $s->top + $s->height }
sub left {
my $self = shift;
$self->{cache_left} = $self->calculate_left unless exists $self->{cache_left};
return $self->{left} + $self->{cache_left};
}
sub right {
my $self = shift;
$self->{cache_right} = $self->calculate_right unless exists $self->{cache_right};
return $self->{left} + $self->{cache_right};
}
sub calculate_left {
my $self = shift;
my $val = $self->{left} + $self->map_pt($self->{start} - 1);
$val > 0 ? $val : 0;
}
sub calculate_right {
my $self = shift;
my $val = $self->{left} + $self->map_pt($self->{end} - 1);
$val = 0 if $val < 0;
$val = $self->width if $val > $self->width;
if ($self->option('label') && (my $label = $self->label)) {
my $left = $self->left;
my $label_width = $self->font->width * CORE::length $label;
my $label_end = $left + $label_width;
$val = $label_end if $label_end > $val;
}
$val;
}
sub map_pt {
my $self = shift;
my $point = shift;
$point -= $self->offset;
my $val = $self->{left} + $self->scale * $point;
my $right = $self->{left} + $self->width;
$val = -1 if $val < 0;
$val = $self->width if $right && $val > $right;
return int $val;
}
sub labelheight {
my $self = shift;
return $self->{labelheight} ||= $self->font->height;
}
sub label {
my $f = (my $self = shift)->feature;
if (ref (my $code = $self->option('label')) eq 'CODE') {
return $code->($f);
}
my $info = eval {$f->info};
return $info if $info;
return $f->seqname if $f->can('seqname');
return $f->primary_tag;
}
# return array containing the left,top,right,bottom
sub box {
my $self = shift;
return ($self->left,$self->top,$self->right,$self->bottom);
}
# these are the sequence boundaries, exclusive of labels and doodads
sub calculate_boundaries {
my $self = shift;
my ($left,$top) = @_;
my $x1 = $left + $self->map_pt($self->{start} - 1);
$x1 = 0 if $x1 < 0;
my $x2 = $left + $self->map_pt($self->{end} - 1);
$x2 = 0 if $x2 < 0;
my $y1 = $top + $self->{top};
$y1 += $self->labelheight if $self->option('label');
my $y2 = $y1 + $self->factory->height;
$x2 = $x1 if $x2-$x1 < 1;
$y2 = $y1 if $y2-$y1 < 1;
return ($x1,$y1,$x2,$y2);
}
sub filled_box {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2,$color) = @_;
my $fc = defined($color) ? $color : $self->fillcolor;
my $linewidth = $self->option('linewidth') || 1;
$gd->filledRectangle($x1,$y1,$x2,$y2,$fc);
$gd->rectangle($x1,$y1,$x2,$y2,$self->fgcolor);
Ace/Graphics/Glyph.pm view on Meta::CPAN
# if the left end is off the end, then cover over
# the leftmost line
my ($width) = $gd->getBounds;
$gd->line($x1,$y1,$x1,$y2,$fc)
if $x1 < 0;
$gd->line($x2,$y1,$x2,$y2,$fc)
if $x2 > $width;
}
sub filled_oval {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = @_;
my $cx = ($x1+$x2)/2;
my $cy = ($y1+$y2)/2;
my $linewidth = $self->option('linewidth') || 1;
if ($linewidth > 1) {
my $pen = $self->make_pen($linewidth);
# draw a box
Ace/Graphics/Glyph.pm view on Meta::CPAN
$gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,gdBrushed);
} else {
$gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$self->fgcolor);
}
# and fill it
$gd->fill($cx,$cy,$self->fillcolor);
}
# directional arrow
sub filled_arrow {
my $self = shift;
my $gd = shift;
my $orientation = shift;
my ($x1,$y1,$x2,$y2) = @_;
my ($width) = $gd->getBounds;
my $indent = ($y2-$y1);
if ($x2 - $x1 < $indent) {
$indent = ($x2-$x1)/2;
Ace/Graphics/Glyph.pm view on Meta::CPAN
$gd->line($x1,$c,$x1+$indent+1,$y1,$fg);
$gd->line($x1+$indent+1,$y1,$x2,$y1,$fg);
$gd->line($x2,$y1,$x2,$y2,$fg);
$gd->line($x2,$y2,$x1+$indent+1,$y2,$fg);
$gd->line($x1+$indent+1,$y2,$x1,$c,$fg);
$gd->line($x1,$c-$h,$x1,$c+$h+1,$fg);
$gd->fillToBorder($x2-1,$c,$fg,$fc);
}
}
sub fill {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = @_;
if ( ($x2-$x1) >= 2 && ($y2-$y1) >= 2 ) {
$gd->fill($x1+1,$y1+1,$self->fillcolor);
}
}
# draw the thing onto a canvas
# this definitely gets overridden
sub draw {
my $self = shift;
my $gd = shift;
my ($left,$top) = @_;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top);
# for nice thin lines
$x2 = $x1 if $x2-$x1 < 1;
if ($self->option('strand_arrow')) {
my $orientation = $self->feature->strand;
$self->filled_arrow($gd,$orientation,$x1,$y1,$x2,$y2);
} else {
$self->filled_box($gd,$x1,$y1,$x2,$y2);
}
# add a label if requested
$self->draw_label($gd,@_) if $self->option('label');
}
sub draw_label {
my $self = shift;
my ($gd,$left,$top) = @_;
my $label = $self->label or return;
$gd->string($self->font,$left + $self->left,$top + $self->top,$label,$self->fontcolor);
}
1;
=head1 NAME
Ace/Graphics/Glyph.pm view on Meta::CPAN
Then override the methods you need to. Typically, just the draw()
method will need to be overridden. However, if you need additional
room in the glyph, you may override calculate_height(),
calculate_left() and calculate_right(). Do not directly override
height(), left() and right(), as their purpose is to cache the values
returned by their calculating cousins in order to avoid time-consuming
recalculation.
A simple draw() method looks like this:
sub draw {
my $self = shift;
$self->SUPER::draw(@_);
my $gd = shift;
# and draw a cross through the box
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
$gd->line($x1,$y1,$x2,$y2,$fg);
$gd->line($x1,$y2,$x2,$y1,$fg);
}
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
package Ace::Graphics::Glyph::anchored_arrow;
# package to use for drawing an arrow
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub calculate_height {
my $self = shift;
my $val = $self->SUPER::calculate_height;
$val += $self->font->height if $self->option('tick');
$val;
}
# override draw method
sub draw {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $a2 = ($y2-$y1)/2;
my $center = $y1+$a2;
$gd->line($x1,$center,$x2,$center,$fg);
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
$x2-- if $self->feature->end == $self->offset + $self->length;
$gd->line($x2,$center-$a2,$x2,$center+$a2,$fg); # tick/base
}
$self->draw_ticks($gd,@_) if $self->option('tick');
# add a label if requested
$self->draw_label($gd,@_) if $self->option('label');
}
sub draw_label {
my $self = shift;
my ($gd,$left,$top) = @_;
my $label = $self->label or return;
my $start = $self->left + ($self->right - $self->left - length($label) * $self->font->width)/2;
$gd->string($self->font,$left + $start,$top + $self->top,$label,$self->fontcolor);
}
sub draw_ticks {
my $self = shift;
my ($gd,$left,$top) = @_;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top);
my $a2 = ($y2-$y1)/2;
my $center = $y1+$a2;
my $scale = $self->scale;
my $fg = $self->fgcolor;
Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN
package Ace::Graphics::Glyph::arrow;
# package to use for drawing an arrow
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub bottom {
my $self = shift;
my $val = $self->SUPER::bottom(@_);
$val += $self->font->height if $self->option('tick');
$val += $self->labelheight if $self->option('label');
$val;
}
# override draw method
sub draw {
my $self = shift;
my $parallel = $self->option('parallel');
$parallel = 1 unless defined $parallel;
$self->draw_parallel(@_) if $parallel;
$self->draw_perpendicular(@_) unless $parallel;
}
sub draw_perpendicular {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $ne = $self->option('northeast');
my $sw = $self->option('southwest');
$ne = $sw = 1 unless defined($ne) || defined($sw);
# draw a perpendicular arrow at position indicated by $x1
my $fg = $self->fgcolor;
Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN
$gd->line($x+$a2,$y2-$a2,$x,$y2,$fg);
}
}
# add a label if requested
if ($self->option('label')) {
$self->draw_label($gd,@_); # this draws the label aligned to the left
}
}
sub draw_parallel {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $a2 = $self->SUPER::height/2;
my $center = $y1+$a2;
my $ne = $self->option('northeast');
my $sw = $self->option('southwest');
Ace/Graphics/Glyph/crossbox.pm view on Meta::CPAN
package Ace::Graphics::Glyph::crossbox;
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub draw {
my $self = shift;
$self->SUPER::draw(@_);
my $gd = shift;
# and draw a cross through the box
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
$gd->line($x1,$y1,$x2,$y2,$fg);
$gd->line($x1,$y2,$x2,$y1,$fg);
}
Ace/Graphics/Glyph/dot.pm view on Meta::CPAN
package Ace::Graphics::Glyph::dot;
# DAS-compatible package to use for drawing a ring or filled circle
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub draw {
my $self = shift;
# $self->SUPER::draw(@_);
my $gd = shift;
my $fg = $self->fgcolor;
# now draw a circle
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $xmid = (($x1+$x2)/2); my $width = abs($x2-$x1);
my $ymid = (($y1+$y2)/2); my $height = abs($y2-$y1);
Ace/Graphics/Glyph/ex.pm view on Meta::CPAN
package Ace::Graphics::Glyph::ex;
# DAS-compatible package to use for drawing an "X"
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub draw {
my $self = shift;
my $gd = shift;
my $fg = $self->fgcolor;
# now draw a cross
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
if ($self->option('point')){
my $p = $self->option('point');
Ace/Graphics/Glyph/graded_segments.pm view on Meta::CPAN
# (has the segment() method) and that has a score associated
# with each segment
use strict;
use vars '@ISA';
use GD;
use Ace::Graphics::Glyph::segments;
@ISA = 'Ace::Graphics::Glyph::segments';
# override draw method
sub draw {
my $self = shift;
# bail out if this isn't the right kind of feature
# handle both das-style and Bio::SeqFeatureI style,
# which use different names for subparts.
my @segments;
my $f = $self->feature;
if ($f->can('segments')) {
@segments = $f->segments;
Ace/Graphics/Glyph/group.pm view on Meta::CPAN
use strict;
use vars '@ISA';
use GD;
use Carp 'croak';
@ISA = 'Ace::Graphics::Glyph';
# override new() to accept an array ref for -feature
# the ref is not a set of features, but a set of other glyphs!
sub new {
my $class = shift;
my %arg = @_;
my $parts = $arg{-feature};
croak('Usage: Ace::Graphics::Glyph::group->new(-features=>$glypharrayref,-factory=>$factory)')
unless ref $parts eq 'ARRAY';
# sort parts horizontally
my @sorted = sort { $a->left <=> $b->left } @$parts;
my $leftmost = $sorted[0];
my $rightmost = (sort { $a->right <=> $b->right } @$parts)[-1];
Ace/Graphics/Glyph/group.pm view on Meta::CPAN
members => \@sorted,
},$class;
@sorted = $self->bump;
$self->{height} = $sorted[-1]->bottom - $sorted[0]->top;
return $self;
}
sub members {
my $self = shift;
my $m = $self->{members} or return;
return @$m;
}
sub move {
my $self = shift;
$self->SUPER::move(@_);
$_->move(@_) foreach $self->members;
}
sub left { shift->{leftmost}->left }
sub right { shift->{rightmost}->right }
sub height {
my $self = shift;
$self->{height};
}
# this is replication of code in Track.pm;
# should have done a formal container/contained relationship
# in order to accomodate groups
sub bump {
my $self = shift;
my @glyphs = $self->members;
my %occupied;
for my $g (sort { $a->left <=> $b->left} @glyphs) {
my $pos = 0;
for my $y (sort {$a <=> $b} keys %occupied) {
my $previous = $occupied{$y};
last if $previous->right + 2 < $g->left; # no collision at this position
$pos += $previous->height + 2; # collision, so bump
}
$occupied{$pos} = $g; # remember where we are
$g->move(0,$pos);
}
return sort { $a->top <=> $b->top } @glyphs;
}
# override draw method - draw individual subparts
sub draw {
my $self = shift;
my $gd = shift;
my ($left,$top) = @_;
# bail out if this isn't the right kind of feature
my @parts = $self->members;
# three pixels of black, three pixels of transparent
my $black = 1;
Ace/Graphics/Glyph/line.pm view on Meta::CPAN
package Ace::Graphics::Glyph::line;
# an arrow without the arrowheads
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub bottom {
my $self = shift;
my $val = $self->SUPER::bottom(@_);
$val += $self->font->height if $self->option('tick');
$val += $self->labelheight if $self->option('label');
$val;
}
sub draw {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $a2 = $self->SUPER::height/2;
my $center = $y1+$a2;
$gd->line($x1,$center,$x2,$center,$fg);
# add a label if requested
Ace/Graphics/Glyph/primers.pm view on Meta::CPAN
# package to use for drawing something that looks like
# primer pairs.
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
use constant HEIGHT => 4;
# we do not need the default amount of room
sub calculate_height {
my $self = shift;
return $self->option('label') ? HEIGHT + $self->labelheight + 2 : HEIGHT;
}
# override draw method
sub draw {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $a2 = HEIGHT/2;
my $center = $y1 + $a2;
# just draw us as a solid line -- very simple
if ($x2-$x1 < HEIGHT*2) {
Ace/Graphics/Glyph/segments.pm view on Meta::CPAN
use strict;
use vars '@ISA';
use GD;
@ISA = 'Ace::Graphics::Glyph';
use constant GRAY => 'lightgrey';
my %BRUSHES;
# override right to allow for label
sub calculate_right {
my $self = shift;
my $left = $self->left;
my $val = $self->SUPER::calculate_right(@_);
if ($self->option('label') && (my $description = $self->description)) {
my $description_width = $self->font->width * length $self->description;
$val = $left + $description_width if $left + $description_width > $val;
}
$val;
}
# override draw method
sub draw {
my $self = shift;
# bail out if this isn't the right kind of feature
# handle both das-style and Bio::SeqFeatureI style,
# which use different names for subparts.
my @segments;
my $f = $self->feature;
if ($f->can('merged_segments')) {
@segments = $f->merged_segments;
Ace/Graphics/Glyph/segments.pm view on Meta::CPAN
# each skip becomes a simple line
for my $i (@skips) {
next unless $i->[1] - $i->[0] >= 1;
$gd->line($i->[0],$center,$i->[1],$center,$gray);
}
# draw label
$self->draw_label($gd,@_) if $self->option('label');
}
sub oriented_box {
my $self = shift;
my $gd = shift;
my $orientation = shift;
my ($x1,$y1,$x2,$y2) = @_;
$self->filled_box($gd,@_);
return unless $x2 - $x1 >= 4;
$BRUSHES{$orientation} ||= $self->make_brush($orientation);
my $top = int(1.5 + $y1 + ($y2 - $y1 - ($BRUSHES{$orientation}->getBounds)[1])/2);
$gd->setBrush($BRUSHES{$orientation});
$gd->setStyle(0,0,0,1);
$gd->line($x1+2,$top,$x2-2,$top,gdStyledBrushed);
}
sub make_brush {
my $self = shift;
my $orientation = shift;
my $brush = GD::Image->new(3,3);
my $bgcolor = $brush->colorAllocate(255,255,255); #white
$brush->transparent($bgcolor);
my $fgcolor = $brush->colorAllocate($self->factory->panel->rgb($self->fgcolor));
if ($orientation > 0) {
$brush->setPixel(0,0,$fgcolor);
$brush->setPixel(1,1,$fgcolor);
$brush->setPixel(0,2,$fgcolor);
} else {
$brush->setPixel(1,0,$fgcolor);
$brush->setPixel(0,1,$fgcolor);
$brush->setPixel(1,2,$fgcolor);
}
$brush;
}
sub description {
my $self = shift;
$self->feature->info;
}
1;
__END__
=head1 NAME
Ace/Graphics/Glyph/toomany.pm view on Meta::CPAN
package Ace::Graphics::Glyph::toomany;
# DAS-compatible package to use for drawing a box
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
# draw the thing onto a canvas
# this definitely gets overridden
sub draw {
my $self = shift;
my $gd = shift;
my ($left,$top) = @_;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top);
$self->filled_oval($gd,$x1,$y1,$x2,$y2);
# add a label if requested
$self->draw_label($gd,@_) if $self->option('label');
}
sub label {
return "too many to display";
}
1;
__END__
=head1 NAME
Ace::Graphics::Glyph::toomany - The "too many to show" glyph
Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
use constant IMPLIED_INTRON_COLOR => 'gray';
use constant ARROW => 4;
# override the left and right methods in order to
# provide extra room for arrows at the end
sub calculate_left {
my $self = shift;
my $val = $self->SUPER::calculate_left(@_);
$val -= ARROW if $self->feature->strand < 0 && $val >= 4;
$val;
}
sub calculate_right {
my $self = shift;
my $left = $self->left;
my $val = $self->SUPER::calculate_right(@_);
$val = $left + ARROW if $left + ARROW > $val;
if ($self->option('label') && (my $description = $self->description)) {
my $description_width = $self->font->width * length $description;
$val = $left + $description_width if $left + $description_width > $val;
}
$val;
}
# override the bottom method in order to provide extra room for
# the label
sub calculate_height {
my $self = shift;
my $val = $self->SUPER::calculate_height(@_);
$val += $self->labelheight if $self->option('label') && $self->description;
$val;
}
# override filled_box method
sub filled_box {
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2,$color) = @_;
my $linewidth = $self->option('linewidth') || 1;
$color ||= $self->fillcolor;
$gd->filledRectangle($x1,$y1,$x2,$y2,$color);
$gd->rectangle($x1,$y1,$x2,$y2,$self->fgcolor);
# if the left end is off the end, then cover over
# the leftmost line
my ($width) = $gd->getBounds;
$gd->line($x1,$y1,$x1,$y2,$color)
if $x1 < 0;
$gd->line($x2,$y1,$x2,$y2,$color)
if $x2 > $width;
}
# override draw method
sub draw {
my $self = shift;
# bail out if this isn't the right kind of feature
return $self->SUPER::draw(@_) unless $self->feature->can('segments');
# get parameters
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my ($left,$top) = @_;
Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN
$self->draw_label($gd,@_);
# draw description
if (my $d = $self->description) {
$gd->string($self->font,$x1,$y2,$d,$fontcolor);
}
}
}
sub description {
my $self = shift;
my $t = $self->feature->info;
return unless ref $t;
my $id = $t->Brief_identification;
my $comment = $t->Locus;
$comment .= $comment ? " ($id)" : $id if $id;
$comment;
}
Ace/Graphics/Glyph/triangle.pm view on Meta::CPAN
package Ace::Graphics::Glyph::triangle;
# DAS-compatible package to use for drawing a triangle
use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';
sub draw {
my $self = shift;
my $gd = shift;
my $fg = $self->fgcolor;
my $orient = $self->option('orient') || 'S';
# find the center and vertices
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $xmid = ($x1+$x2)/2;
my $ymid = ($y1+$y2)/2;
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
package Ace::Graphics::GlyphFactory;
# parameters for creating sequence glyphs of various sorts
# you *do* like glyphs, don't you?
use strict;
use Carp qw(carp croak confess);
use Ace::Graphics::Glyph;
use GD;
sub DESTROY { }
sub new {
my $class = shift;
my $type = shift;
my @options = @_;
# normalize options
my %options;
while (my($key,$value) = splice (@options,0,2)) {
$key =~ s/^-//;
$options{lc $key} = $value;
}
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
confess("the requested glyph class, ``$type'' is not available: $@")
unless (eval "require $glyphclass");
return bless {
glyphclass => $glyphclass,
scale => 1, # 1 pixel per kb
options => \%options,
},$class;
}
sub clone {
my $self = shift;
my %val = %$self;
$val{options} = {%{$self->{options}}};
return bless \%val,ref($self);
}
# set the scale for glyphs we create
sub scale {
my $self = shift;
my $g = $self->{scale};
$self->{scale} = shift if @_;
$g;
}
sub width {
my $self = shift;
my $g = $self->{width};
$self->{width} = shift if @_;
$g;
}
# font to draw with
sub font {
my $self = shift;
$self->option('font',@_);
}
# set the height for glyphs we create
sub height {
my $self = shift;
$self->option('height',@_);
}
sub options {
my $self = shift;
my $g = $self->{options};
$self->{options} = shift if @_;
$g;
}
sub panel {
my $self = shift;
my $g = $self->{panel};
$self->{panel} = shift if @_;
$g;
}
sub option {
my $self = shift;
my $option_name = shift;
my $o = $self->{options} or return;
my $d = $o->{$option_name};
$o->{$option_name} = shift if @_;
$d;
}
# set the foreground and background colors
# expressed as GD color indices
sub _fgcolor {
my $self = shift;
my $c = $self->option('color',@_) || $self->option('fgcolor',@_) || $self->option('outlinecolor',@_);
$self->translate($c);
}
sub fgcolor {
my $self = shift;
my $linewidth = $self->option('linewidth');
return $self->_fgcolor unless defined($linewidth) && $linewidth > 1;
$self->panel->set_pen($linewidth,$self->_fgcolor);
return gdBrushed;
}
sub fontcolor {
my $self = shift;
my $c = $self->option('fontcolor',@_);
$self->translate($c);
# return $self->_fgcolor;
}
sub bgcolor {
my $self = shift;
my $c = $self->option('bgcolor',@_);
$self->translate($c);
}
sub fillcolor {
my $self = shift;
my $c = $self->option('fillcolor',@_) || $self->option('color',@_);
$self->translate($c);
}
sub length { shift->option('length',@_) }
sub offset { shift->option('offset',@_) }
sub translate { my $self = shift; $self->panel->translate(@_) || $self->fgcolor; }
sub rgb { shift->panel->rgb(@_) }
# create a new glyph from configuration
sub glyph {
my $self = shift;
my $feature = shift;
return $self->{glyphclass}->new(-feature => $feature,
-factory => $self);
}
1;
__END__
=head1 NAME
Ace/Graphics/Panel.pm view on Meta::CPAN
use constant KEYPADTOP => 5; # extra padding before the key starts
use constant KEYCOLOR => 'cornsilk';
*push_track = \&add_track;
# package global
my %COLORS;
# Create a new panel of a given width and height, and add lists of features
# one by one
sub new {
my $class = shift;
my %options = @_;
$class->read_colors() unless %COLORS;
my $length = $options{-length} || 0;
my $offset = $options{-offset} || 0;
my $spacing = $options{-spacing} || 5;
my $keycolor = $options{-keycolor} || KEYCOLOR;
my $keyspacing = $options{-keyspacing} || KEYSPACING;
Ace/Graphics/Panel.pm view on Meta::CPAN
pad_right => $options{-pad_right}||0,
length => $length,
offset => $offset,
height => 0, # AUTO
spacing => $spacing,
keycolor => $keycolor,
keyspacing => $keyspacing,
},$class;
}
sub width {
my $self = shift;
my $d = $self->{width};
$self->{width} = shift if @_;
$d + $self->pad_left + $self->pad_right;
}
sub spacing {
my $self = shift;
my $d = $self->{spacing};
$self->{spacing} = shift if @_;
$d;
}
sub length {
my $self = shift;
my $d = $self->{length};
if (@_) {
my $l = shift;
$l = $l->length if ref($l) && $l->can('length');
$self->{length} = $l;
}
$d;
}
sub pad_top {
my $self = shift;
my $d = $self->{pad_top};
$self->{pad_top} = shift if @_;
$d || 0;
}
sub pad_bottom {
my $self = shift;
my $d = $self->{pad_bottom};
$self->{pad_bottom} = shift if @_;
$d || 0;
}
sub pad_left {
my $self = shift;
my $d = $self->{pad_left};
$self->{pad_left} = shift if @_;
$d || 0;
}
sub pad_right {
my $self = shift;
my $d = $self->{pad_right};
$self->{pad_right} = shift if @_;
$d || 0;
}
sub add_track {
my $self = shift;
# due to indecision, we accept features
# and/or glyph types in the first two arguments
my ($features,$glyph_name) = ([],'generic');
while ( $_[0] !~ /^-/) {
my $arg = shift;
$features = $arg and next if ref($arg);
$glyph_name = $arg and next unless ref($arg);
}
$self->_add_track($glyph_name,$features,+1,@_);
}
sub unshift_track {
my $self = shift;
# due to indecision, we accept features
# and/or glyph types in the first two arguments
my ($features,$glyph_name) = ([],'generic');
while ( (my $arg = shift) !~ /^-/) {
$features = $arg and next if ref($arg);
$glyph_name = $arg and next unless ref($arg);
}
$self->_add_track($glyph_name,$features,-1,@_);
}
sub _add_track {
my $self = shift;
my ($glyph_type,$features,$direction,@options) = @_;
unshift @options,'-offset' => $self->{offset} if defined $self->{offset};
unshift @options,'-length' => $self->{length} if defined $self->{length};
$features = [$features] unless ref $features eq 'ARRAY';
my $track = Ace::Graphics::Track->new($glyph_type,$features,@options);
$track->set_scale(abs($self->length),$self->{width});
$track->panel($self);
if ($direction >= 0) {
push @{$self->{tracks}},$track;
} else {
unshift @{$self->{tracks}},$track;
}
return $track;
}
sub height {
my $self = shift;
my $spacing = $self->spacing;
my $key_height = $self->format_key;
my $height = 0;
$height += $_->height + $spacing foreach @{$self->{tracks}};
$height + $key_height + $self->pad_top + $self->pad_bottom;
}
sub gd {
my $self = shift;
return $self->{gd} if $self->{gd};
my $width = $self->width;
my $height = $self->height;
my $gd = GD::Image->new($width,$height);
my %translation_table;
for my $name ('white','black',keys %COLORS) {
my $idx = $gd->colorAllocate(@{$COLORS{$name}});
Ace/Graphics/Panel.pm view on Meta::CPAN
for my $track (@{$self->{tracks}}) {
$track->draw($gd,$pl,$offset+$pt);
$offset += $track->height + $self->spacing;
}
$self->draw_key($gd,$pl,$offset);
return $self->{gd} = $gd;
}
sub draw_key {
my $self = shift;
my ($gd,$left,$top) = @_;
my $key_glyphs = $self->{key_glyphs} or return;
my $color = $self->translate($self->{keycolor});
$gd->filledRectangle($left,$top,$self->width,$self->height,$color);
$gd->string(KEYLABELFONT,$left,KEYPADTOP+$top,"KEY:",1);
$top += KEYLABELFONT->height + KEYPADTOP;
$_->draw($gd,$left,$top) foreach @$key_glyphs;
}
# Format the key section, and return its height
sub format_key {
my $self = shift;
return $self->{key_height} if defined $self->{key_height};
my ($height,$width) = (0,0);
my %tracks;
my @glyphs;
# determine how many glyphs become part of the key
# and their max size
Ace/Graphics/Panel.pm view on Meta::CPAN
$i++;
}
}
$self->{key_glyphs} = \@glyphs; # remember our key glyphs
# remember our key height
return $self->{key_height} = ($height+$spacing) * $rows + KEYLABELFONT->height +KEYPADTOP;
}
# reverse of translate(); given index, return rgb triplet
sub rgb {
my $self = shift;
my $idx = shift;
my $gd = $self->{gd} or return;
return $gd->rgb($idx);
}
sub translate {
my $self = shift;
if (@_ == 3) { # rgb triplet
my $gd = $self->gd or return 1;
return $gd->colorClosest(@_);
}
# otherwise...
my $color = shift;
if ($color =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) {
my $gd = $self->gd or return 1;
my ($r,$g,$b) = (hex($1),hex($2),hex($3));
return $gd->colorClosest($r,$g,$b);
} else {
my $table = $self->{translations} or return $self->fgcolor;
return $table->{$color} || 1;
}
}
sub set_pen {
my $self = shift;
my ($linewidth,$color) = @_;
return $self->{pens}{$linewidth} if $self->{pens}{$linewidth};
my $pen = $self->{pens}{$linewidth} = GD::Image->new($linewidth,$linewidth);
my @rgb = $self->rgb($color);
my $bg = $pen->colorAllocate(255,255,255);
my $fg = $pen->colorAllocate(@rgb);
$pen->fill(0,0,$fg);
$self->{gd}->setBrush($pen);
}
sub png {
my $gd = shift->gd;
$gd->png;
}
sub boxes {
my $self = shift;
my @boxes;
my $offset = 0;
my $pl = $self->pad_left;
my $pt = $self->pad_top;
for my $track (@{$self->{tracks}}) {
my $boxes = $track->boxes($pl,$offset+$pt);
push @boxes,@$boxes;
$offset += $track->height + $self->spacing;
}
return wantarray ? @boxes : \@boxes;
}
sub read_colors {
my $class = shift;
while (<DATA>) {
chomp;
last if /^__END__/;
my ($name,$r,$g,$b) = split /\s+/;
$COLORS{$name} = [hex $r,hex $g,hex $b];
}
}
sub color_names {
my $class = shift;
$class->read_colors unless %COLORS;
return wantarray ? keys %COLORS : [keys %COLORS];
}
1;
__DATA__
white FF FF FF
Ace/Graphics/Track.pm view on Meta::CPAN
# Features are of uniform style and are controlled by descendents of
# the Ace::Graphics::Glyph class (eek!).
use Ace::Graphics::GlyphFactory;
use Ace::Graphics::Fk;
use GD; # maybe
use Carp 'croak';
use vars '$AUTOLOAD';
use strict;
sub AUTOLOAD {
my $self = shift;
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
$self->factory->$func_name(@_);
}
sub DESTROY { }
# Pass a list of Ace::Sequence::Feature objects, and a glyph name
sub new {
my $class = shift;
my ($glyph_name,$features,@options) = @_;
$glyph_name ||= 'generic';
$features ||= [];
my $glyph_factory = $class->make_factory($glyph_name,@options);
my $self = bless {
features => [], # list of Ace::Sequence::Feature objects
factory => $glyph_factory, # the glyph class associated with this track
glyphs => undef, # list of glyphs
},$class;
$self->add_feature($_) foreach @$features;
$self;
}
# control bump direction:
# +1 => bump downward
# -1 => bump upward
# 0 => no bump
sub bump {
my $self = shift;
$self->factory->option('bump',@_);
}
# add a feature (or array ref of features) to the list
sub add_feature {
my $self = shift;
my $feature = shift;
if (ref($feature) eq 'ARRAY') {
my $name = ++$self->{group_name};
$self->{group_ids}{$name} = $feature;
} else {
push @{$self->{features}},$feature;
}
}
# link a set of features together so that they bump as a group
sub add_group {
my $self = shift;
my $features = shift;
ref($features) eq 'ARRAY' or croak("Usage: Ace::Graphics::Track->add_group(\$arrayref)");
$self->add_feature($features);
}
# delegate lineheight to the glyph
sub lineheight {
shift->{factory}->height(@_);
}
# the scale is horizontal, measured in pixels/bp
sub scale {
my $self = shift;
my $g = $self->{scale};
$self->{scale} = shift if @_;
$g;
}
sub width {
my $self = shift;
my $g = $self->{width};
$self->{width} = shift if @_;
$g;
}
# set scale by a segment
sub scale_to_segment {
my $self = shift;
my ($segment,$desired_width) = @_;
$self->set_scale(abs($segment->length),$desired_width);
}
sub set_scale {
my $self = shift;
my ($bp,$desired_width) = @_;
$desired_width ||= 512;
$self->scale($desired_width/$bp);
$self->width($desired_width);
}
# return the glyph class
sub factory {
my $self = shift;
my $g = $self->{factory};
$self->{factory} = shift if @_;
$g;
}
# return boxes for each of the glyphs
# will be an array of four-element [$feature,l,t,r,b] arrays
sub boxes {
my $self = shift;
my ($left,$top) = @_;
$top += 0; $left += 0;
my @result;
my $glyphs = $self->layout;
for my $g (@$glyphs) {
my ($l,$t,$r,$b) = $g->box;
push @result,[$g->feature,$left+$l,$top+$t,$left+$r,$top+$b];
}
return wantarray ? @result : \@result;
}
# synthesize a key glyph
sub keyglyph {
my $self = shift;
my $scale = 1/$self->scale; # base pairs/pixel
# two segments, at pixels 0->50, 60->80
my $offset = $self->offset;
my $feature = Ace::Graphics::Fk->new(-segments=>[ [ 0*$scale +$offset,50*$scale+$offset],
[60*$scale+$offset, 80*$scale+$offset]
],
-name => $self->option('key'),
-strand => '+1');
my $factory = $self->factory->clone;
$factory->scale($self->scale);
$factory->width($self->width);
$factory->option(label=>1); # turn on labels
return $factory->glyph($feature);
}
# draw glyphs onto a GD object at the indicated position
sub draw {
my $self = shift;
my ($gd,$left,$top) = @_;
$top += 0; $left += 0;
my $glyphs = $self->layout;
# draw background
my $bgcolor = $self->factory->bgcolor;
# $gd->filledRectangle($left,$top,$left+$self->width,$top+$self->height,$bgcolor);
if (my $label = $self->factory->option('track_label')) {
Ace/Graphics/Track.pm view on Meta::CPAN
$gd->string($font,$x,$y,$label,$self->factory->fontcolor);
}
$_->draw($gd,$left,$top) foreach @$glyphs;
if ($self->factory->option('connectgroups')) {
$_->draw($gd,$left,$top) foreach @{$self->{groups}};
}
}
# lay out -- this uses the infamous bump algorithm
sub layout {
my $self = shift;
my $force = shift || 0;
return $self->{glyphs} if $self->{glyphs} && !$force;
my $f = $self->{features};
my $factory = $self->factory;
$factory->scale($self->scale); # set the horizontal scale
$factory->width($self->width);
# create singleton glyphs
Ace/Graphics/Track.pm view on Meta::CPAN
# If -1 bumping was allowed, then normalize so that the top glyph is at zero
my ($topmost) = sort {$a->top <=> $b->top} @glyphs;
my $offset = 0 - $topmost->top;
$_->move(0,$offset) foreach @glyphs;
$self->{groups} = \@groups;
return $self->{glyphs} = \@glyphs;
}
# bumper - glyphs already sorted left to right
sub _bump {
my $self = shift;
my $glyphs = shift;
my $bump_direction = $self->bump; # +1 means bump down, -1 means bump up
my @occupied;
my $rightmost = -2;
for my $g (sort { $a->left <=> $b->left} @$glyphs) {
my $pos = 0;
while (1) {
Ace/Graphics/Track.pm view on Meta::CPAN
}
}
$g->move(0,$pos);
@occupied = sort { $b->right <=> $a->right } ($g,@occupied);
$rightmost = $g->right if $g->right > $rightmost;
}
}
# return list of glyphs -- only after they are laid out
sub glyphs { shift->{glyphs} }
# height is determined by the layout, and cannot be externally controlled
sub height {
my $self = shift;
return $self->{cache_height} if defined $self->{cache_height};
$self->layout;
my $glyphs = $self->{glyphs} or croak "Can't lay out";
return 0 unless @$glyphs;
my ($topmost) = sort { $a->top <=> $b->top } @$glyphs;
my ($bottommost) = sort { $b->bottom <=> $a->bottom } @$glyphs;
return $self->{cache_height} = $bottommost->bottom - $topmost->top;
}
sub make_factory {
my ($class,$type,@options) = @_;
Ace::Graphics::GlyphFactory->new($type,@options);
}
1;
__END__
=head1 NAME
Ace/Iterator.pm view on Meta::CPAN
package Ace::Iterator;
use strict;
use vars '$VERSION';
use Carp;
use Ace 1.50 qw(rearrange);
$VERSION = '1.51';
sub new {
my $pack = shift;
my ($db,$query,$filled,$chunksize) = rearrange([qw/DB QUERY FILLED CHUNKSIZE/],@_);
my $self = {
'db' => $db,
'query' => $query,
'valid' => undef,
'cached_answers' => [],
'filled' => ($filled || 0),
'chunksize' => ($chunksize || 40),
'current' => 0
};
bless $self,$pack;
$db->_register_iterator($self) if $db && ref($db);
$self;
}
sub next {
my $self = shift;
croak "Attempt to use an expired iterator" unless $self->{db};
$self->_fill_cache() unless @{$self->{'cached_answers'}};
my $cache = $self->{cached_answers};
my $result = shift @{$cache};
$self->{'current'}++;
unless ($result) {
$self->{db}->_unregister_iterator;
delete $self->{db};
}
return $result;
}
sub invalidate {
my $self = shift;
return unless $self->_active;
$self->save_context;
$self->_active(0);
}
sub save_context {
my $self = shift;
return unless my $db = $self->{db};
return unless $self->_active;
$self->{saved_ok} = $db->_save_iterator($self);
}
# Fill up cache for iterator
sub _fill_cache {
my $self = shift;
return unless my $db = $self->{db};
$self->restore_context() if !$self->{active};
my @objects = $self->{filled} ? $db->_fetch($self->{'chunksize'},$self->{'current'}) :
$db->_list($self->{'chunksize'},$self->{'current'});
$self->{cached_answers} = \@objects;
$self->_active(1);
}
# prevent reentry
sub _active {
my $self = shift;
my $val = $self->{active};
$self->{active} = shift if @_;
return $val;
}
sub restore_context {
my $self = shift;
return unless my $db = $self->{db};
$db->raw_query($self->{query})
unless $self->{saved_ok} and $db->_restore_iterator($self);
undef $self->{saved_ok}; # no longer there!
}
1;
__END__
Ace/Local.pm view on Meta::CPAN
use constant DEFAULT_DB=>'/usr/local/acedb';
# Changed readsize to be 4k rather than 5k. Most flavours of UNIX
# have a page size of 4kb or a multiple thereof. It improves
# efficiency to read an integer number of pages
# -- tim.cutts@incyte.com 08 Sep 1999
use constant READSIZE => 1024 * 4; # read 4k units
# this seems gratuitous, but don't delete it just yet
# $SIG{'CHLD'} = sub { wait(); } ;
sub connect {
my $class = shift;
my ($path,$program,$host,$port,$nosync) = rearrange(['PATH','PROGRAM','HOST','PORT','NOSYNC'],@_);
my $args;
# some pretty insane heuristics to handle BOTH tace and aceclient
die "Specify either -path or -host and -port" if ($program && ($host || $port));
die "-path is not relevant for aceclient, use -host and/or -port"
if defined($program) && $program=~/aceclient/ && defined($path);
die "-host and -port are not relevant for tace, use -path"
if defined($program) && $program=~/tace/ and (defined $port || defined $host);
Ace/Local.pm view on Meta::CPAN
return bless {
'read' => $rdr,
'write' => $wtr,
'prompt' => $prompt,
'pid' => $pid,
'auto_save' => 1,
'status' => $nosync ? STATUS_PENDING : STATUS_WAITING, # initial stuff to read
},$class;
}
sub debug {
my $self = shift;
my $d = $self->{debug};
$self->{debug} = shift if @_;
$d;
}
sub DESTROY {
my $self = shift;
return unless kill 0,$self->{'pid'};
if ($self->auto_save) {
# save work for the user...
$self->query('save');
$self->synch;
}
$self->query('quit');
# just for paranoid reasons. shouldn't be necessary
close $self->{'write'} if $self->{'write'};
close $self->{'read'} if $self->{'read'};
waitpid($self->{pid},0) if $self->{'pid'};
}
sub encore {
my $self = shift;
return $self->status == STATUS_PENDING;
}
sub auto_save {
my $self = shift;
$self->{'auto_save'} = $_[0] if defined $_[0];
return $self->{'auto_save'};
}
sub status {
return $_[0]->{'status'};
}
sub error {
my $self = shift;
return $self->{'error'};
}
sub query {
my $self = shift;
my $query = shift;
warn "query($query)\n" if $self->debug;
if ($self->debug) {
my $msg = $query || '';
warn "\tquery($msg)";
}
return undef if $self->{'status'} == STATUS_ERROR;
do $self->read() until $self->{'status'} != STATUS_PENDING;
my $wtr = $self->{'write'};
print $wtr "$query\n";
$self->{'status'} = STATUS_PENDING;
}
sub low_read { # hack to accomodate "uninitialized database" warning from tace
my $self = shift;
my $rdr = $self->{'read'};
return undef unless $self->{'status'} == STATUS_PENDING;
my $rin = '';
my $data = '';
vec($rin,fileno($rdr),1)=1;
unless (select($rin,undef,undef,1)) {
$self->{'status'} = STATUS_WAITING;
return undef;
}
sysread($rdr,$data,READSIZE);
return $data;
}
sub read {
my $self = shift;
return undef unless $self->{'status'} == STATUS_PENDING;
my $rdr = $self->{'read'};
my $len = defined $self->{'buffer'} ? length($self->{'buffer'}) : 0;
my $plen = length($self->{'prompt'});
my ($result, $bytes, $pos, $searchfrom);
while (1) {
# Read the data directly onto the end of the buffer
Ace/Local.pm view on Meta::CPAN
}
$len += $bytes;
}
# never get here
}
# just throw away everything
sub synch {
my $self = shift;
$self->read() while $self->status == STATUS_PENDING;
}
# expand ~foo syntax
sub _expand_twiddles {
my $path = shift;
my ($to_expand,$homedir);
return $path unless $path =~ m!^~([^/]*)!;
if ($to_expand = $1) {
$homedir = (getpwnam($to_expand))[7];
} else {
$homedir = (getpwuid($<))[7];
}
return $path unless $homedir;
Ace/Model.pm view on Meta::CPAN
'""' => 'asString',
fallback => 'TRUE';
$VERSION = '1.51';
my $TAG = '\b\w+\b';
my $KEYWORD = q[^(XREF|UNIQUE|ANY|FREE|REPEAT|Int|Text|Float|DateType)$];
my $METAWORD = q[^(XREF|UNIQUE|ANY|FREE|REPEAT|Int|Text|Float|DateType)$];
# construct a new Ace::Model
sub new {
my $class = shift;
my ($data,$db,$break_cycle) = @_;
$break_cycle ||= {};
$data=~s!\s+//.*$!!gm; # remove all comments
$data=~s!\0!!g;
my ($name) = $data =~ /\A[\?\#](\w+)/;
my $self = bless {
name => $name,
raw => $data,
Ace/Model.pm view on Meta::CPAN
if (!$break_cycle->{$name} && $db && (my @hashes = grep {$_ ne $name} $data =~ /\#(\S+)/g)) {
$break_cycle->{$name}++;
my %seen;
my @submodels = map {$db->model($_,$break_cycle)} grep {!$seen{$_}++} @hashes;
$self->{submodels} = \@submodels;
}
return $self;
}
sub name {
return shift()->{name};
}
# return all the tags in the model as a hashref.
# in a list context returns the tags as a long list result
sub tags {
my $self = shift;
$self->{tags} ||= { map {lc($_)=>1}
grep {!/^[\#\?]/o}
grep {!/$KEYWORD/o}
$self->{raw}=~m/(\S+)/g,
map {$_->tags} @{$self->{submodels}}
};
return wantarray ? keys %{$self->{tags}} : $self->{tags};
}
# return the path to a particular tag
sub path {
my $self = shift;
my $tag = lc shift;
$self->parse;
return unless exists $self->{path}{$tag};
return @{$self->{path}{$tag}};
}
# parse out the paths to each of the tags
sub parse {
my $self = shift;
return if exists $self->{path};
my @lines = grep { !m[^\s*//] } $self->_untabulate;
# accumulate a list of all the paths
my (@paths,@path,@path_stack);
my $current_position = 0;
LINE:
for my $line (@lines) {
Ace/Model.pm view on Meta::CPAN
}
push @paths,[@path] if @path;
# at this point, @paths contains a list of paths to each terminal tag
foreach (@paths) {
my $tag = pop @{$_};
$self->{path}{lc($tag)} = $_;
}
}
sub _untabulate {
my $self = shift;
my @lines = split "\n",$self->{raw};
return expand(@lines);
}
# return true if the tag is a valid one
sub valid_tag {
my $self = shift;
my $tag = lc shift;
return $self->tags->{$tag};
}
# just return the model as a string
sub asString {
return shift()->{'raw'};
}
1;
__END__
=head1 NAME
Ace::Model - Get information about AceDB models
Ace/Object.pm view on Meta::CPAN
$DEFAULT_WIDTH=25; # column width for pretty-printing
$VERSION = '1.66';
# Pseudonyms and deprecated methods.
*isClass = \&isObject;
*pick = \&fetch;
*get = \&search;
*add = \&add_row;
sub AUTOLOAD {
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
my $self = $_[0];
# This section works with Autoloader
my $presumed_tag = $func_name =~ /^[A-Z]/ && $self->isObject; # initial_cap
if ($presumed_tag) {
croak "Invalid object tag \"$func_name\""
if $self->db && $self->model && !$self->model->valid_tag($func_name);
Ace/Object.pm view on Meta::CPAN
# otherwise return the thing itself
return $obj;
} elsif ($func_name =~ /^[A-Z]/ && $self->isTag) { # follow tag
return $self->search($func_name);
} else {
$AutoLoader::AUTOLOAD = __PACKAGE__ . "::$func_name";
goto &AutoLoader::AUTOLOAD;
}
}
sub DESTROY {
my $self = shift;
return unless defined $self->{class}; # avoid working with temp objects from a search()
return if caller() =~ /^(Cache\:\:|DB)/; # prevent recursion in FileCache code
my $db = $self->db or return;
return if $self->{'.nocache'};
return unless $self->isRoot;
if ($self->_dirty) {
warn "Destroy for ",overload::StrVal($self)," ",$self->class,':',$self->name if Ace->debug;
Ace/Object.pm view on Meta::CPAN
# remove our in-memory cache
# shouldn't be necessary with weakref
# $db->memory_cache_delete($self);
}
###################### object constructor #################
# IMPORTANT: The _clone subroutine will copy all instance variables that
# do NOT begin with a dot (.). If you do not want an instance variable
# shared with cloned copies, proceed them with a dot!!!
#
sub new {
my $pack = shift;
my($class,$name,$db,$isRoot) = rearrange([qw/CLASS NAME/,[qw/DATABASE DB/],'ROOT'],@_);
$pack = ref($pack) if ref($pack);
my $self = bless { 'name' => $name,
'class' => $class
},$pack;
$self->db($db) if $self->isObject;
$self->{'.root'}++ if defined $isRoot && $isRoot;
# $self->_dirty(1) if $isRoot;
return $self
}
######### construct object from serialized input, not usually called directly ########
sub newFromText {
my ($pack,$text,$db) = @_;
$pack = ref($pack) if ref($pack);
my @array;
foreach (split("\n",$text)) {
next unless $_;
# this is a hack to fix some txt fields with unescaped tabs
# unfortunately it breaks other things
s/\?txt\?([^?]*?)\t([^?]*?)\?/?txt?$1\\t$2?/g;
push(@array,[split("\t")]);
}
my $obj = $pack->_fromRaw(\@array,0,0,$#array,$db);
$obj->_dirty(1);
$obj;
}
################### name of the object #################
sub name {
my $self = shift;
$self->{'name'} = shift if defined($_[0]);
my $name = $self->_ace_format($self->{'class'},$self->{'name'});
$name;
}
################### class of the object #################
sub class {
my $self = shift;
defined($_[0])
? $self->{'class'} = shift
: $self->{'class'};
}
################### name and class together #################
sub id {
my $self = shift;
return "$self->{class}:$self->{name}";
}
############## return true if two objects are equivalent ##################
# to be equivalent, they must have identical names, classes and databases #
# We handle comparisons between objects and numbers ourselves, and let #
# Perl handle comparisons between objects and strings #
sub eq {
my ($a,$b,$rev) = @_;
unless (UNIVERSAL::isa($b,'Ace::Object')) {
$a = $a->name + 0; # convert to numeric
return $a == $b; # do a numeric comparison
}
return 1 if ($a->name eq $b->name)
&& ($a->class eq $b->class)
&& ($a->db eq $b->db);
return;
}
sub ne {
return !&eq;
}
############ returns true if this is a top-level object #######
sub isRoot {
return exists shift()->{'.root'};
}
################### handle to ace database #################
sub db {
my $self = shift;
if (@_) {
my $db = shift;
$self->{db} = "$db"; # store string representation, not object
}
Ace->name2db($self->{db});
}
### Return a portion of the tree at the indicated tag path ###
#### In a list context returns the column. In an array context ###
#### returns a pointer to the subtree ####
#### Usually returns what is pointed to by the tag. Will return
#### the parent object if you pass a true value as the second argument
sub at {
my $self = shift;
my($tag,$pos,$return_parent) = rearrange(['TAG','POS','PARENT'],@_);
return $self->right unless $tag;
$tag = lc $tag;
# Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999
if (!defined($pos) and $tag=~/(.*?)\[(\d+)\]$/) {
$pos = $2;
$tag = $1;
Ace/Object.pm view on Meta::CPAN
($o,$above,$left) = $o->_at($tag);
return unless defined($o);
}
return $above || $left if $return_parent;
return defined $pos ? $o->right($pos) : $o unless wantarray;
return $o->col($pos);
}
### Flatten out part of the tree into an array ####
### along the row. Will not follow object references. ###
sub row {
my $self = shift;
my $pos = shift;
my @r;
my $o = defined $pos ? $self->right($pos) : $self;
while (defined($o)) {
push(@r,$o);
$o = $o->right;
}
return @r;
}
### Flatten out part of the tree into an array ####
### along the column. Will not follow object references. ###
sub col {
my $self = shift;
my $pos = shift;
$pos = 1 unless defined $pos;
croak "Position must be positive" unless $pos >= 0;
return ($self) unless $pos > 0;
my @r;
# This is for tag[1] semantics
if ($pos == 1) {
Ace/Object.pm view on Meta::CPAN
for (my $o=$self->right; defined($o); $o=$o->down) {
next unless defined(my $right = $o->right($pos-2));
push (@r,$right->col);
}
}
return @r;
}
#### Search for a tag, and return the column ####
#### Uses a breadth-first search (cols then rows) ####
sub search {
my $self = shift;
my $tag = shift unless $_[0]=~/^-/;
my ($subtag,$pos,$filled) = rearrange(['SUBTAG','POS',['FILL','FILLED']],@_);
my $lctag = lc $tag;
# With caching, the old way of following ends up cloning the object
# -- which we don't want. So more-or-less emulate the earlier
# behavior with an explicit get and fetch
# return $self->follow(-tag=>$tag,-filled=>$filled) if $filled;
if ($filled) {
Ace/Object.pm view on Meta::CPAN
return defined $pos ? $t->right($pos) : $t unless wantarray;
# We do something verrrry interesting in an array context.
# If no position is defined, we return the column to the right.
# If a position is defined, we return everything $POS tags
# to the right (so-called tag[2] system).
return $t->col($pos);
}
# utility routine used in partial tree caching
sub _attach_subtree {
my $self = shift;
my ($tag,$subobject) = @_;
my $lctag = lc($tag);
my $obj;
if (lc($subobject->right) eq $lctag) { # new version of aceserver as of 11/30/98
$obj = $subobject->right;
} else { # old version of aceserver
$obj = $self->new('tag',$tag,$self->db);
$obj->{'.right'} = $subobject->right;
}
$self->{'.PATHS'}->{$lctag} = $obj;
}
sub _dirty {
my $self = shift;
$self->{'.dirty'} = shift if @_ && $self->isRoot;
$self->{'.dirty'};
}
#### return true if tree is populated, without populating it #####
sub filled {
my $self = shift;
return exists($self->{'.right'}) || exists($self->{'.raw'});
}
#### return true if you can follow the object in the database (i.e. a class ###
sub isPickable {
return shift->isObject;
}
#### Return a string representation of the object subject to Ace escaping rules ###
sub escape {
my $self = shift;
my $name = $self->name;
my $needs_escaping = $name=~/[^\w.-]/ || $self->isClass;
return $name unless $needs_escaping;
$name=~s/\"/\\"/g; #escape quotes"
return qq/"$name"/;
}
############### object on the right of the tree #############
sub right {
my ($self,$pos) = @_;
$self->_fill;
$self->_parse;
return $self->{'.right'} unless defined $pos;
croak "Position must be positive" unless $pos >= 0;
my $node = $self;
while ($pos--) {
defined($node = $node->right) || return;
}
$node;
}
################# object below on the tree #################
sub down {
my ($self,$pos) = @_;
$self->_parse;
return $self->{'.down'} unless defined $pos;
my $node = $self;
while ($pos--) {
defined($node = $node->down) || return;
}
$node;
}
#############################################
# fetch current node from the database #
sub fetch {
my ($self,$tag) = @_;
return $self->search($tag) if defined $tag;
my $thing_to_pick = ($self->isTag and defined($self->right)) ? $self->right : $self;
return $thing_to_pick unless $thing_to_pick->isObject;
my $obj = $self->db->get($thing_to_pick->class,$thing_to_pick->name) if $self->db;
return $obj;
}
#############################################
# follow a tag into the database, returning a
# list of followed objects.
sub follow {
my $self = shift;
my ($tag,$filled) = rearrange(['TAG','FILLED'],@_);
return unless $self->db;
return $self->fetch() unless $tag;
my $class = $self->class;
my $name = Ace->freeprotect($self->name);
my @options;
if ($filled) {
@options = $filled =~ /^[a-zA-Z]/ ? ('filltag' => $filled) : ('filled'=>1);
}
return $self->db->fetch(-query=>"find $class $name ; follow $tag",@options);
}
# returns true if the object has a Model, i.e, can be followed into
# the database.
sub isObject {
my $self = shift;
return _isObject($self->class);
1;
}
# returns true if the object is a tag.
sub isTag {
my $self = shift;
return 1 if $self->class eq 'tag';
return;
}
# return the most recent error message
sub error {
$Ace::Error=~s/\0//g; # get rid of nulls
return $Ace::Error;
}
### Returns the object's model (as an Ace::Model object)
sub model {
my $self = shift;
return unless $self->db && $self->isObject;
return $self->db->model($self->class);
}
### Return the class in which to bless all objects retrieved from
# database. Might want to override in other classes
sub factory {
return __PACKAGE__;
}
#####################################################################
#####################################################################
############### mostly private functions from here down #############
#####################################################################
#####################################################################
# simple clone
sub clone {
my $self = shift;
return bless {%$self},ref $self;
}
# selective clone
sub _clone {
my $self = shift;
my $pack = ref($self);
my @public_keys = grep {substr($_,0,1) ne '.'} keys %$self;
my %newobj;
@newobj{@public_keys} = @{$self}{@public_keys};
# Turn into a toplevel object
$newobj{'.root'}++;
return bless \%newobj,$pack;
}
sub _fill {
my $self = shift;
return if $self->filled;
return unless $self->db && $self->isObject;
my $data = $self->db->pick($self->class,$self->name);
return unless $data;
# temporary object, don't cache it.
my $new = $self->newFromText($data,$self->db);
%{$self}=%{$new};
$new->{'.nocache'}++; # this line prevents the thing from being cached
$self->_dirty(1);
}
sub _parse {
my $self = shift;
return unless my $raw = $self->{'.raw'};
my $ts = $self->db->timestamps;
my $col = $self->{'.col'};
my $current_obj = $self;
my $current_row = $self->{'.start_row'};
my $db = $self->db;
my $changed;
for (my $r=$current_row+1; $r<=$self->{'.end_row'}; $r++) {
Ace/Object.pm view on Meta::CPAN
$current_obj->comment($obj_right) if $obj_right->isComment;
$t = $obj_right;
last unless defined($obj_right = $self->_fromRaw($raw,$row++,$col+1,$self->{'.end_row'},$db));
}
}
$current_obj->{'.right'} = $obj_right;
$self->_dirty(1) if $changed;
delete @{$self}{qw[.raw .start_row .end_row .col]};
}
sub _fromRaw {
my $pack = shift;
# this breaks inheritance...
# $pack = $pack->factory();
my ($raw,$start_row,$col,$end_row,$db) = @_;
$db = "$db" if ref $db;
return unless defined $raw->[$start_row][$col];
# HACK! Some LongText entries may begin with newlines. This is within the Acedb spec.
Ace/Object.pm view on Meta::CPAN
my ($class,$name,$ts) = Ace->split($temp);
my $self = $pack->new($class,$name,$db,!($start_row || $col));
@{$self}{qw(.raw .start_row .end_row .col db)} = ($raw,$start_row,$end_row,$col,$db);
$self->{'.timestamp'} = $ts if defined $ts;
return $self;
}
# Return partial ace subtree at indicated tag
sub _at {
my ($self,$tag) = @_;
my $pos=0;
# Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999
if ($tag=~/(.*?)\[(\d+)\]$/) {
$pos=$2;
$tag=$1;
}
my $p;
Ace/Object.pm view on Meta::CPAN
return ($o->right($pos),$p,$self) if (lc($o) eq lc($tag));
$p = $o;
$o = $o->down;
}
return;
}
# Used to munge special data types. Right now dates are the
# only examples.
sub _ace_format {
my $self = shift;
my ($class,$name) = @_;
return undef unless defined $class && defined $name;
return $class eq 'date' ? $self->_to_ace_date($name) : $name;
}
# It's an object unless it is one of these things
sub _isObject {
return unless defined $_[0];
$_[0] !~ /^(float|int|date|tag|txt|peptide|dna|scalar|[Tt]ext|comment)$/;
}
# utility routine used to split a tag path into individual components
# allows components to contain dots.
sub _split_tags {
my $self = shift;
my $tag = shift;
$tag =~ s/\\\./$;/g; # protect backslashed dots
return map { (my $x=$_)=~s/$;/./g; $x } split(/\./,$tag);
}
1;
__END__
Ace/Object.pm view on Meta::CPAN
before it is incorporated into the table, for example by turning it
into an HREF link. The callback takes a single argument containing
the object, and must return a string-valued result. It may also
return a list as its result, in which case the first member of the
list is the string representation of the object, and the second
member is a boolean indicating whether to prune the table at this
level. For example, you can prune large repetitive lists.
Here's a complete example:
sub process_cell {
my $obj = shift;
return "$obj" unless $obj->isObject || $obj->isTag;
my @col = $obj->col;
my $cnt = scalar(@col);
return ("$obj -- $cnt members",1); # prune
if $cnt > 10 # if subtree to big
# tags are bold
return "<B>$obj</B>" if $obj->isTag;
Ace/Object.pm view on Meta::CPAN
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
# AUTOLOADED METHODS GO HERE
### Return the pretty-printed HTML table representation ###
### may pass a code reference to add additional formatting to cells ###
sub asHTML {
my $self = shift;
my ($modify_code) = rearrange(['MODIFY'],@_);
return unless defined($self->right);
my $string = "<TABLE BORDER>\n<TR ALIGN=LEFT VALIGN=TOP><TH>$self</TH>";
$modify_code = \&_default_makeHTML unless $modify_code;
$self->right->_asHTML(\$string,1,2,$modify_code);
$string .= "</TR>\n</TABLE>\n";
return $string;
}
### Get the FASTA-format DNA/Peptide representation for this object ###
### (if appropriate) ###
sub asDNA {
return shift()->_special_dump('dna');
}
sub asPeptide {
return shift()->_special_dump('peptide');
}
sub _special_dump {
my $self = shift;
my $dump_format = shift;
return unless $self->db->count($self->class,$self->name);
my $result = $self->db->raw_query($dump_format);
$result =~ s!^//.*!!ms;
$result;
}
#### As tab-delimited table ####
sub asTable {
my $self = shift;
my $string = "$self\t";
my $right = $self->right;
$right->_asTable(\$string,1,2) if defined($right);
return $string . "\n";
}
#### In "ace" format ####
sub asAce {
my $self = shift;
my $string = $self->isRoot ? join(' ',$self->class,':',$self->escape) . "\n" : '';
$self->right->_asAce(\$string,0,[]);
return "$string\n\n";
}
### Pretty-printed version ###
sub asString {
my $self = shift;
my $MAXWIDTH = shift || $DEFAULT_WIDTH;
my $tabs = $self->asTable;
return "$self" unless $tabs;
my(@lines) = split("\n",$tabs);
my($result,@max);
foreach (@lines) {
my(@fields) = split("\t");
for (my $i=0;$i<@fields;$i++) {
$max[$i] = length($fields[$i]) if
Ace/Object.pm view on Meta::CPAN
formline ($format1,@data);
formline ($format2,@data);
}
return ($result = $^A,$^A='')[0];
}
# run a series of GIF commands and return the Gif and the semi-parsed
# "boxes" structure. Commands is typically a series of mouseclicks
# ($gif,$boxes) = $aceObject->asGif(-clicks=>[[$x1,$y1],[$x2,$y2]...],
# -dimensions=>[$x,$y]);
sub asGif {
my $self = shift;
my ($clicks,$dimensions,$display,$view,$coords,$getcoords) = rearrange(['CLICKS',
['DIMENSIONS','DIM'],
'DISPLAY',
'VIEW',
'COORDS',
'GETCOORDS',
],@_);
$display = "-D $display" if $display;
$view = "-view $view" if $view;
Ace/Object.pm view on Meta::CPAN
my $box = {'coordinates'=>[$left,$top,$right,$bottom],
'class'=>$class,
'name' =>$name,
'comment'=>$comments};
push (@b,$box);
}
return ($gif,\@b);
}
############## timestamp and comment information ############
sub timestamp {
my $self = shift;
return $self->{'.timestamp'} = $_[0] if defined $_[0];
if ($self->db && !$self->{'.timestamp'}) {
$self->_fill;
$self->_parse;
}
return $self->{'.timestamp'} if $self->{'.timestamp'};
return unless defined $self->right;
return $self->{'.timestamp'} = $self->right->timestamp;
}
sub comment {
my $self = shift;
return $self->{'.comment'} = $_[0] if defined $_[0];
if ($self->db && !$self->{'.comment'}) {
$self->_fill;
$self->_parse;
}
return $self->{'.comment'};
}
### Return list of all the tags in the object ###
sub tags {
my $self = shift;
my $current = $self->right;
my @tags;
while (defined($current)) {
push(@tags,$current);
$current = $current->down;
}
return @tags;
}
################# kill an object ################
# Removes the object from the database immediately.
sub kill {
my $self = shift;
return unless my $db = $self->db;
return 1 unless $db->count($self->class,$self->name);
my $result = $db->raw_query("kill");
if (defined($result) and $result=~/write access/im) { # this keeps changing
$Ace::Error = "Write access denied";
return;
}
# uncache cached values and clear the object out
# as best we can
delete @{$self}{qw[.PATHS .right .raw .down]};
1;
}
# sub isTimestamp {
# my $self = shift;
# return 1 if $self->class eq 'UserSession';
# return;
# }
sub isComment {
my $self = shift;
return 1 if $self->class eq 'Comment';
return;
}
################# add a new row #############
# Only changes local copy until you perform commit() #
# returns true if this is a valid thing to do #
sub add_row {
my $self = shift;
my($tag,@newvalue) = rearrange([['TAG','PATH'],'VALUE'],@_);
# flatten array refs into array
my @values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } @newvalue;
# make sure that this entry doesn't already exist
unless ($tag =~ /\./) {
my $model = $self->model;
my @intermediate_tags = $model->path($tag);
Ace/Object.pm view on Meta::CPAN
}
push(@{$self->{'.update'}},join(' ',map { Ace->freeprotect($_) } (@tags,@values)));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(1);
1;
}
# Use this method to add an entire subobject to the right of the tag.
# The tree may come from another database.
sub add_tree {
my $self = shift;
my($tag,$value,@rest) = rearrange([['TAG','PATH'],['VALUE','TREE']],@_);
croak "Value must be an Ace::Object" unless ref($value) && $value->isa('Ace::Object');
unless ($tag =~ /\./) {
my $model = $self->model;
my @intermediate_tags = $model->path($tag);
$tag = join '.',@intermediate_tags,$tag;
}
Ace/Object.pm view on Meta::CPAN
}
push(@{$self->{'.update'}},map { join(' ',@tags,$_) } split("\n",$value->asAce));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(1);
1;
}
################# delete a portion of the tree #############
# Only changes local copy until you perform commit() #
# returns true if this is a valid thing to do.
sub delete {
my $self = shift;
my($tag,$oldvalue,@rest) = rearrange([['TAG','PATH'],['VALUE','OLDVALUE','OLD']],@_);
# flatten array refs into array
my @values;
@values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } ($oldvalue,@rest)
if defined($oldvalue);
unless ($tag =~ /\./) {
my $model = $self->model;
Ace/Object.pm view on Meta::CPAN
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(0);
$self->db->file_cache_delete($self);
1;
}
################# delete a portion of the tree #############
# Only changes local copy until you perform commit() #
# returns true if this is a valid thing to do #
sub replace {
my $self = shift;
my($tag,$oldvalue,$newvalue,@rest) = rearrange([['TAG','PATH'],
['OLDVALUE','OLD'],
['NEWVALUE','NEW']],@_);
$self->delete($tag,$oldvalue);
$self->add($tag,$newvalue,@rest);
delete $self->{'.PATHS'}; # uncache cached values
1;
}
# commit changes from local copy to database copy
sub commit {
my $self = shift;
return unless my $db = $self->db;
my ($retval,@cmd);
my $name = $self->{'name'};
return unless defined $name;
$name =~ s/([^a-zA-Z0-9_-])/\\$1/g;
return 1 unless exists $self->{'.update'} && $self->{'.update'};
Ace/Object.pm view on Meta::CPAN
return if $Ace::Error;
undef $self->{'.update'};
# this will force a fresh retrieval of the object
# and synchronize our in-memory copy with the db
delete $self->{'.right'};
delete $self->{'.PATHS'};
return 1;
}
# undo changes
sub rollback {
my $self = shift;
undef $self->{'.update'};
# this will force object to be reloaded from database
# next time it is needed.
delete $self->{'.right'};
delete $self->{'.PATHS'};
1;
}
sub debug {
my $self = shift;
Ace->debug(@_);
}
### Get or set the date style (actually calls through to the database object) ###
sub date_style {
my $self = shift;
return unless $self->db;
return $self->db->date_style(@_);
}
sub _asHTML {
my($self,$out,$position,$level,$morph_code) = @_;
do {
$$out .= "<TR ALIGN=LEFT VALIGN=TOP>" unless $position;
$$out .= "<TD></TD>" x ($level-$position-1);
my ($cell,$prune,$did_it_myself) = $morph_code->($self);
$$out .= $did_it_myself ? $cell : "<TD>$cell</TD>";
if ($self->comment) {
my ($cell,$p,$d) = $morph_code->($self->comment);
$$out .= $d ? $cell : "<TD>$cell</TD>";
$$out .= "</TR>\n" . "<TD></TD>" x $level unless $self->down && !defined($self->right);
Ace/Object.pm view on Meta::CPAN
$level = $self->right->_asHTML($out,$level,$level+1,$morph_code) if defined($self->right) && !$prune;
$$out .= "</TR>\n" if defined($self = $self->down);
$position = 0;
} while defined $self;
return --$level;
}
# This function is overly long because it is optimized to prevent parsing
# parts of the tree that haven't previously been parsed.
sub _asTable {
my($self,$out,$position,$level) = @_;
do {
if ($self->{'.raw'}) { # we still have raw data, so we can optimize
my ($a,$start,$end) = @{$self}{ qw(.col .start_row .end_row) };
my @to_append = map { join("\t",@{$_}[$a..$#{$_}]) } @{$self->{'.raw'}}[$start..$end];
my $new_row;
foreach (@to_append) {
# hack alert
s/(\?.*?[^\\]\?.*?[^\\]\?)\S*/$self->_ace_format(Ace->split($1))/eg;
if ($new_row++) {
Ace/Object.pm view on Meta::CPAN
$$out .= "\n" if defined($self = $self->down);
$position = 0;
} while defined $self;
return --$level;
}
# This is the default code that will be called during construction of
# the HTML table. It returns a two-member list consisting of the modified
# entry and (optionally) a true value if we are to prune here. The returned string
# will be placed inside a <TD></TD> tag. There's nothing you can do about that.
sub _default_makeHTML {
my $self = shift;
my ($string,$prune) = ("$self",0);
return ($string,$prune) unless $self->isObject || $self->isTag;
if ($self->isTag) {
$string = "<B>$self</B>";
} elsif ($self->isComment) {
$string = "<I>$self</I>";
} else {
$string = qq{<FONT COLOR="blue">$self</FONT>} ;
}
return ($string,$prune);
}
# Insert a new tag or value.
# Local only. Will not affect the database.
# Returns the inserted tag, or the preexisting
# tag, if already there.
sub _insert {
my ($self,$tag) = @_;
my $p = $self->{'.right'};
return $self->{'.right'} = $self->new('tag',$tag)
unless $p;
while ($p) {
return $p if "$p" eq $tag;
last unless $p->{'.down'};
$p = $p->{'.down'};
}
# if we get here, then we didn't find it, so
# insert at the bottom
return $p->{'.down'} = $self->new('tag',$tag);
}
# This is unsatisfactory because it duplicates much of the code
# of asTable.
sub _asAce {
my($self,$out,$level,$tags) = @_;
# ugly optimization for speed
if ($self->{'.raw'}){
my ($a,$start,$end) = @{$self}{qw(.col .start_row .end_row)};
my (@last);
foreach (@{$self->{'.raw'}}[$start..$end]){
my $j=1;
$$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags);
my (@to_modify) = @{$_}[$a..$#{$_}];
Ace/Object.pm view on Meta::CPAN
push(@$tags,$self->escape);
$self->right->_asAce($out,$level+1,$tags);
pop(@$tags);
}
if ($self->down) {
$$out .= "\n";
$self->down->_asAce($out,0,$tags);
}
}
sub _to_ace_date {
my $self = shift;
my $string = shift;
return $string unless lc($self->date_style) eq 'ace';
%MO = (Jan=>1,Feb=>2,Mar=>3,
Apr=>4,May=>5,Jun=>6,
Jul=>7,Aug=>8,Sep=>9,
Oct=>10,Nov=>11,Dec=>12) unless %MO;
my ($day,$mo,$yr) = split(" ",$string);
return "$yr-$MO{$mo}-$day";
}
### Return an XML syntax representation ###
### Consider this feature experimental ###
sub asXML {
my $self = shift;
return unless defined($self->right);
my ($do_content,$do_class,$do_value,$do_timestamps) = rearrange([qw(CONTENT CLASS VALUE TIMESTAMPS)],@_);
$do_content = 0 unless defined $do_content;
$do_class = 1 unless defined $do_class;
$do_value = 1 unless defined $do_value;
$do_timestamps = 1 unless (defined $do_timestamps && !$do_timestamps) || !$self->db->timestamps;
my %options = (content => $do_content,
class => $do_class,
value => $do_value,
timestamps => $do_timestamps);
my $name = $self->escapeXML($self->name);
my $class = $self->class;
my $string = '';
$self->_asXML(\$string,0,0,'',0,\%options);
return $string;
}
sub _asXML {
my($self,$out,$position,$level,$current_tag,$tag_level,$opts) = @_;
do {
my $name = $self->escapeXML($self->name);
my $class = $self->class;
my ($tagname,$attributes,$content) = ('','',''); # prevent uninitialized variable warnings
my $tab = " " x ($level-$position); # four spaces
$current_tag ||= $class;
$content = $name if $opts->{content};
Ace/Object.pm view on Meta::CPAN
$level = $self->right->_asXML($out,$position,$level+1,$current_tag,$tag_level+1,$opts);
$$out .= qq($tab</$tagname>\n);
}
$self = $self->down;
} while defined $self;
return --$level;
}
sub escapeXML {
my ($self,$string) = @_;
$string =~ s/&/&/g;
$string =~ s/\"/"/g;
$string =~ s/</</g;
$string =~ s/>/>/g;
return $string;
}
sub _xmlNumber {
my $self = shift;
my $tag = shift;
$tag =~ s/^(\d)/
$1 eq '0' ? 'zero'
: $1 eq '1' ? 'one'
: $1 eq '2' ? 'two'
: $1 eq '3' ? 'three'
: $1 eq '4' ? 'four'
: $1 eq '5' ? 'five'
: $1 eq '6' ? 'six'
Ace/Object/Wormbase.pm view on Meta::CPAN
package Ace::Object::Wormbase;
use strict;
use Carp;
use Ace::Object;
# $Id: Wormbase.pm,v 1.3 2003/12/27 15:52:35 todd Exp $
use vars '@ISA';
@ISA = 'Ace::Object';
# override the Locus method for backward compatibility with model shift
sub Locus {
my $self = shift;
return $self->SUPER::Locus(@_) unless $self->class eq 'Sequence';
if (wantarray) {
return ($self->Locus_genomic_seq,$self->Locus_other_seq);
} else {
return $self->Locus_genomic_seq || $self->Locus_other_seq;
}
}
sub Sequence {
my $self = shift;
return $self->SUPER::Sequence(@_) unless $self->class eq 'Locus';
if (wantarray) {
# return ($self->Genomic_sequence,$self->Other_sequence);
return ($self->CDS,$self->Other_sequence);
} else {
# return $self->Genomic_sequence || $self->Other_sequence;
return $self->CDS || $self->Other_sequence;
}
}
Ace/Sequence.pm view on Meta::CPAN
# but can be called like this:
# $seq = Ace::Sequence->new(-db=>$db,-name=>$name);
# or
# $seq = Ace::Sequence->new(-seq => $object,
# -offset => $offset,
# -length => $length,
# -ref => $refseq
# );
# $refseq, if provided, will be used to establish the coordinate
# system. Otherwise the first base pair will be set to 1.
sub new {
my $pack = shift;
my ($seq,$start,$end,$offset,$length,$refseq,$db) =
rearrange([
['SEQ','SEQUENCE','SOURCE'],
'START',
['END','STOP'],
['OFFSET','OFF'],
['LENGTH','LEN'],
'REFSEQ',
['DATABASE','DB'],
Ace/Sequence.pm view on Meta::CPAN
},$pack;
# set the reference sequence
eval { $self->refseq($refseq) } or return if defined $refseq;
# wheww!
return $self;
}
# return the "source" object that the user offset from
sub source {
$_[0]->{obj};
}
# return the parent object
sub parent { $_[0]->{parent} }
# return the length
#sub length { $_[0]->{length} }
sub length {
my $self = shift;
my ($start,$end) = ($self->start,$self->end);
return $end - $start + ($end > $start ? 1 : -1); # for stupid 1-based adjustments
}
sub reversed { return shift->strand < 0; }
sub automerge {
my $self = shift;
my $d = $self->{automerge};
$self->{automerge} = shift if @_;
$d;
}
# return reference sequence
sub refseq {
my $self = shift;
my $prev = $self->{refseq};
if (@_) {
my $refseq = shift;
my $arrayref;
BLOCK: {
last BLOCK unless defined ($refseq);
if (ref($refseq) && ref($refseq) eq 'ARRAY') {
Ace/Sequence.pm view on Meta::CPAN
$arrayref = [$refseq,$r_offset,$r_strand];
}
$self->{refseq} = $arrayref;
}
return unless $prev;
return $self->parent if $self->absolute;
return wantarray ? @{$prev} : $prev->[0];
}
# return strand
sub strand { return $_[0]->{strand} }
# return reference strand
sub r_strand {
my $self = shift;
return "+1" if $self->absolute;
if (my ($ref,$r_offset,$r_strand) = $self->refseq) {
return $r_strand;
} else {
return $self->{strand}
}
}
sub offset { $_[0]->{offset} }
sub p_offset { $_[0]->{p_offset} }
sub smapped { 1; }
sub type { 'Sequence' }
sub subtype { }
sub debug {
my $self = shift;
my $d = $self->{_debug};
$self->{_debug} = shift if @_;
$d;
}
# return the database this sequence is associated with
sub db {
return Ace->name2db($_[0]->{db} ||= $_[0]->source->db);
}
sub start {
my ($self,$abs) = @_;
$abs = $self->absolute unless defined $abs;
return $self->{p_offset} + $self->{offset} + 1 if $abs;
if ($self->refseq) {
my ($ref,$r_offset,$r_strand) = $self->refseq;
return $r_strand < 0 ? 1 + $r_offset - ($self->{p_offset} + $self->{offset})
: 1 + $self->{p_offset} + $self->{offset} - $r_offset;
}
else {
return $self->{offset} +1;
}
}
sub end {
my ($self,$abs) = @_;
my $start = $self->start($abs);
my $f = $self->{length} > 0 ? 1 : -1; # for stupid 1-based adjustments
if ($abs && $self->refseq ne $self->parent) {
my $r_strand = $self->r_strand;
return $start - $self->{length} + $f
if $r_strand < 0 or $self->{strand} < 0 or $self->{length} < 0;
return $start + $self->{length} - $f
}
return $start + $self->{length} - $f if $self->r_strand eq $self->{strand};
return $start - $self->{length} + $f;
}
# turn on absolute coordinates (relative to reference sequence)
sub absolute {
my $self = shift;
my $prev = $self->{absolute};
$self->{absolute} = $_[0] if defined $_[0];
return $prev;
}
# human readable string (for debugging)
sub asString {
my $self = shift;
if ($self->absolute) {
return join '',$self->parent,'/',$self->start,',',$self->end;
} elsif (my $ref = $self->refseq){
my $label = $ref->isa('Ace::Sequence::Feature') ? $ref->info : "$ref";
return join '',$label,'/',$self->start,',',$self->end;
} else {
join '',$self->source,'/',$self->start,',',$self->end;
}
}
sub cmp {
my ($self,$arg,$reversed) = @_;
if (ref($arg) and $arg->isa('Ace::Sequence')) {
my $cmp = $self->parent cmp $arg->parent
|| $self->start <=> $arg->start;
return $reversed ? -$cmp : $cmp;
}
my $name = $self->asString;
return $reversed ? $arg cmp $name : $name cmp $arg;
}
# Return the DNA
sub dna {
my $self = shift;
return $self->{dna} if $self->{dna};
my $raw = $self->_query('seqdna');
$raw=~s/^>.*\n//m;
$raw=~s/^\/\/.*//mg;
$raw=~s/\n//g;
$raw =~ s/\0+\Z//; # blasted nulls!
my $effective_strand = $self->end >= $self->start ? '+1' : '-1';
_complement(\$raw) if $self->r_strand ne $effective_strand;
return $self->{dna} = $raw;
}
# return a gff file
sub gff {
my $self = shift;
my ($abs,$features) = rearrange([['ABS','ABSOLUTE'],'FEATURES'],@_);
$abs = $self->absolute unless defined $abs;
# can provide list of feature names, such as 'similarity', or 'all' to get 'em all
# !THIS IS BROKEN; IT SHOULD LOOK LIKE FEATURE()!
my $opt = $self->_feature_filter($features);
my $gff = $self->_gff($opt);
warn $gff if $self->debug;
$self->transformGFF(\$gff) unless $abs;
return $gff;
}
# return a GFF object using the optional GFF.pm module
sub GFF {
my $self = shift;
my ($filter,$converter) = @_; # anonymous subs
croak "GFF module not installed" unless require GFF;
require GFF::Filehandle;
my @lines = grep !/^\/\//,split "\n",$self->gff(@_);
local *IN;
local ($^W) = 0; # prevent complaint by GFF module
tie *IN,'GFF::Filehandle',\@lines;
my $gff = GFF::GeneFeatureSet->new;
$gff->read(\*IN,$filter,$converter) if $gff;
return $gff;
}
# Get the features table. Can filter by type/subtype this way:
# features('similarity:EST','annotation:assembly_tag')
sub features {
my $self = shift;
my ($filter,$opt) = $self->_make_filter(@_);
# get raw gff file
my $gff = $self->gff(-features=>$opt);
# turn it into a list of features
my @features = $self->_make_features($gff,$filter);
if ($self->automerge) { # automatic merging
Ace/Sequence.pm view on Meta::CPAN
push @features,@f;
}
}
return wantarray ? @features : \@features;
}
# A little bit more complex - assemble a list of "transcripts"
# consisting of Ace::Sequence::Transcript objects. These objects
# contain a list of exons and introns.
sub transcripts {
my $self = shift;
my $curated = shift;
my $ef = $curated ? "exon:curated" : "exon";
my $if = $curated ? "intron:curated" : "intron";
my $sf = $curated ? "Sequence:curated" : "Sequence";
my @features = $self->features($ef,$if,$sf);
return unless @features;
return $self->_make_transcripts(\@features);
}
sub _make_transcripts {
my $self = shift;
my $features = shift;
require Ace::Sequence::Transcript;
my %transcripts;
for my $feature (@$features) {
my $transcript = $feature->info;
next unless $transcript;
if ($feature->type =~ /^(exon|intron|cds)$/) {
Ace/Sequence.pm view on Meta::CPAN
# get rid of transcripts without exons
foreach (keys %transcripts) {
delete $transcripts{$_} unless exists $transcripts{$_}{exon}
}
# map the rest onto Ace::Sequence::Transcript objects
return map {Ace::Sequence::Transcript->new($transcripts{$_})} keys %transcripts;
}
# Reassemble clones from clone left and right ends
sub clones {
my $self = shift;
my @clones = $self->features('Clone_left_end','Clone_right_end','Sequence');
my %clones;
return unless @clones;
return $self->_make_clones(\@clones);
}
sub _make_clones {
my $self = shift;
my $features = shift;
my (%clones,@canonical_clones);
my $start_label = $self->strand < 0 ? 'end' : 'start';
my $end_label = $self->strand < 0 ? 'start' : 'end';
for my $feature (@$features) {
$clones{$feature->info}{$start_label} = $feature->start if $feature->type eq 'Clone_left_end';
$clones{$feature->info}{$end_label} = $feature->start if $feature->type eq 'Clone_right_end';
Ace/Sequence.pm view on Meta::CPAN
my $start = $clones{$clone}{start} || -99_999_999;
my $end = $clones{$clone}{end} || +99_999_999;
my $phony_gff = join "\t",($parent,'Clone','structural',$start,$end,'.','.','.',qq(Clone "$clone"));
push @features,Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$phony_gff);
}
return @features;
}
# Assemble a list of "GappedAlignment" objects. These objects
# contain a list of aligned segments.
sub alignments {
my $self = shift;
my @subtypes = @_;
my @types = map { "similarity:\^$_\$" } @subtypes;
push @types,'similarity' unless @types;
return $self->features(@types);
}
sub segments {
my $self = shift;
return;
}
sub _make_alignments {
my $self = shift;
my $features = shift;
require Ace::Sequence::GappedAlignment;
my %homol;
for my $feature (@$features) {
next unless $feature->type eq 'similarity';
my $target = $feature->info;
my $subtype = $feature->subtype;
push @{$homol{$target,$subtype}},$feature;
}
# map onto Ace::Sequence::GappedAlignment objects
return map {Ace::Sequence::GappedAlignment->new($homol{$_})} keys %homol;
}
# return list of features quickly
sub feature_list {
my $self = shift;
return $self->{'feature_list'} if $self->{'feature_list'};
return unless my $raw = $self->_query('seqfeatures -version 2 -list');
return $self->{'feature_list'} = Ace::Sequence::FeatureList->new($raw);
}
# transform a GFF file into the coordinate system of the sequence
sub transformGFF {
my $self = shift;
my $gff = shift;
my $parent = $self->parent;
my $strand = $self->{strand};
my $source = $self->source;
my ($ref_source,$ref_offset,$ref_strand) = $self->refseq;
$ref_source ||= $source;
$ref_strand ||= $strand;
if ($ref_strand > 0) {
Ace/Sequence.pm view on Meta::CPAN
$$gff =~ s/(?<!\")\s+(-?\d+)\s+(-?\d+)\s+([.\d]+)\s+(\S)/join "\t",'',$o-$2,$o-$1,$3,$plusminus{$4}/eg;
$$gff =~ s/(Target \"[^\"]+\" )(-?\d+) (-?\d+)/$1 $3 $2/g;
$$gff =~ s/^$parent/$source/mg;
$$gff =~ s/\#\#sequence-region\s+\S+\s+(-?\d+)\s+(-?\d+)/"##sequence-region $ref_source " . ($o - $2) . ' ' . ($o - $1) . ' (reversed)'/em;
$$gff =~ s/FMAP_FEATURES\s+"\S+"\s+(-?\d+)\s+(-?\d+)/"FMAP_FEATURES \"$ref_source\" " . ($o - $2) . ' ' . ($o - $1) . ' (reversed)'/em;
}
}
# return a name for the object
sub name {
return shift->source_seq->name;
}
# for compatibility with Ace::Sequence::Feature
sub info {
return shift->source_seq;
}
###################### internal functions #################
# not necessarily object-oriented!!
# return parent, parent offset and strand
sub find_parent {
my $obj = shift;
# first, if we are passed an Ace::Sequence, then we can inherit
# these settings directly
return (@{$obj}{qw(parent p_offset length)},$obj->r_strand)
if $obj->isa('Ace::Sequence');
# otherwise, if we are passed an Ace::Object, then we must
# traverse upwards until we find a suitable parent
return _traverse($obj) if $obj->isa('Ace::Object');
# otherwise, we don't know what to do...
croak "Source sequence not an Ace::Object or an Ace::Sequence";
}
sub _get_parent {
my $obj = shift;
# ** DANGER DANGER WILL ROBINSON! **
# This is an experiment in caching parents to speed lookups. Probably eats memory voraciously.
return $CACHE{$obj} if CACHE && exists $CACHE{$obj};
my $p = $obj->get(S_Parent=>2)|| $obj->get(Source=>1);
return unless $p;
return CACHE ? $CACHE{$obj} = $p->fetch
: $p->fetch;
}
sub _get_children {
my $obj = shift;
my @pieces = $obj->get(S_Child=>2);
return @pieces if @pieces;
return @pieces = $obj->get('Subsequence');
}
# get sequence, offset and strand of topmost container
sub _traverse {
my $obj = shift;
my ($offset,$length);
# invoke seqget to find the top-level container for this sequence
my ($tl,$tl_start,$tl_end) = _get_toplevel($obj);
$tl_start ||= 0;
$tl_end ||= 0;
# make it an object
$tl = ref($obj)->new(-name=>$tl,-class=>'Sequence',-db=>$obj->db);
$offset += $tl_start - 1; # offset to beginning of toplevel
$length ||= abs($tl_end - $tl_start) + 1;
my $strand = $tl_start < $tl_end ? +1 : -1;
return ($tl,$offset,$strand < 0 ? ($length,'-1') : ($length,'+1') ) if $length;
}
sub _get_toplevel {
my $obj = shift;
my $class = $obj->class;
my $name = $obj->name;
my $smap = $obj->db->raw_query("gif smap -from $class:$name");
my ($parent,$pstart,$pstop,$tstart,$tstop,$map_type) =
$smap =~ /^SMAP\s+(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(.+)/;
$parent ||= '';
$parent =~ s/^Sequence://; # remove this in next version of Acedb
return ($parent,$pstart,$pstop);
}
# create subroutine that filters GFF files for certain feature types
sub _make_filter {
my $self = shift;
my $automerge = $self->automerge;
# parse out the filter
my %filter;
foreach (@_) {
my ($type,$filter) = split(':',$_,2);
if ($automerge && lc($type) eq 'transcript') {
@filter{'exon','intron','Sequence','cds'} = ([undef],[undef],[undef],[undef]);
} elsif ($automerge && lc($type) eq 'clone') {
Ace/Sequence.pm view on Meta::CPAN
} else {
push @{$filter{$type}},$filter;
}
}
# create pattern-match sub
my $sub;
my $promiscuous; # indicates that there is a subtype without a type
if (%filter) {
my $s = "sub { my \@d = split(\"\\t\",\$_[0]);\n";
for my $type (keys %filter) {
my $expr;
my $subtypes = $filter{$type};
if ($type ne '') {
for my $st (@$subtypes) {
$expr .= defined $st ? "return 1 if \$d[2]=~/$type/i && \$d[1]=~/$st/i;\n"
: "return 1 if \$d[2]=~/$type/i;\n"
}
} else { # no type, only subtypes
$promiscuous++;
for my $st (@$subtypes) {
next unless defined $st;
$expr .= "return 1 if \$d[1]=~/$st/i;\n";
}
}
$s .= $expr;
}
$s .= "return;\n }";
$sub = eval $s;
croak $@ if $@;
} else {
$sub = sub { 1; }
}
return ($sub,$promiscuous ? [] : [keys %filter]);
}
# turn a GFF file and a filter into a list of Ace::Sequence::Feature objects
sub _make_features {
my $self = shift;
my ($gff,$filter) = @_;
my ($r,$r_offset,$r_strand) = $self->refseq;
my $parent = $self->parent;
my $abs = $self->absolute;
if ($abs) {
$r_offset = 0;
$r = $parent;
$r_strand = '+1';
}
my @features = map {Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$_)}
grep !m@^(?:\#|//)@ && $filter->($_),split("\n",$gff);
}
# low level GFF call, no changing absolute to relative coordinates
sub _gff {
my $self = shift;
my ($opt,$db) = @_;
my $data = $self->_query("seqfeatures -version 2 $opt",$db);
$data =~ s/\0+\Z//;
return $data; #blasted nulls!
}
# shortcut for running a gif query
sub _query {
my $self = shift;
my $command = shift;
my $db = shift || $self->db;
my $parent = $self->parent;
my $start = $self->start(1);
my $end = $self->end(1);
($start,$end) = ($end,$start) if $start > $end; #flippity floppity
my $coord = "-coords $start $end";
Ace/Sequence.pm view on Meta::CPAN
# my $opt = $command =~ /seqfeatures/ ? '-nodna' : '';
my $opt = '-noclip';
my $query = "gif seqget $parent $opt $coord ; $command";
warn $query if $self->debug;
return $db->raw_query("gif seqget $parent $opt $coord ; $command");
}
# utility function -- reverse complement
sub _complement {
my $dna = shift;
$$dna =~ tr/GATCgatc/CTAGctag/;
$$dna = scalar reverse $$dna;
}
sub _feature_filter {
my $self = shift;
my $features = shift;
return '' unless $features;
my $opt = '';
$opt = '+feature ' . join('|',@$features) if ref($features) eq 'ARRAY' && @$features;
$opt = "+feature $features" unless ref $features;
$opt;
}
1;
Ace/Sequence.pm view on Meta::CPAN
# Find all the exons predicted by various versions of "genefinder"
@exons = $seq->features('exon:genefinder.*');
# Iterate through the exons, printing their start, end and DNA
for my $exon (@exons) {
print join "\t",$exon->start,$exon->end,$exon->dna,"\n";
}
# Find the region 1000 kb upstream of the first exon
$sub = Ace::Sequence->new(-seq=>$exons[0],
-offset=>-1000,-length=>1000);
# Find all features in that area
@features = $sub->features;
# Print its DNA
print $sub->dna;
# Create a new Sequence object from the first 500 kb of chromosome 1
$seq = Ace::Sequence->new(-name=>'CHROMOSOME_I',-db=>$db,
Ace/Sequence/Feature.pm view on Meta::CPAN
use vars '@ISA','%REV';
@ISA = 'Ace::Sequence'; # for convenience sake only
%REV = ('+1' => '-1',
'-1' => '+1'); # war is peace, &c.
use overload
'""' => 'asString',
;
# parse a line from a sequence list
sub new {
my $pack = shift;
my ($parent,$ref,$r_offset,$r_strand,$abs,$gff_line,$db) = @_;
my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t",$gff_line;
if (defined($strand)) {
$strand = $strand eq '-' ? '-1' : '+1';
} else {
$strand = 0;
}
# for efficiency/performance, we don't use superclass new() method, but modify directly
Ace/Sequence/Feature.pm view on Meta::CPAN
type => $type,
score => $score,
frame => $frame,
group => $group,
db => $db,
}
},$pack;
return $self;
}
sub smapped { 1; }
# $_[0] is field name, $_[1] is self, $_[2] is optional replacement value
sub _field {
my $self = shift;
my $field = shift;
my $v = $self->{info}{$field};
$self->{info}{$field} = shift if @_;
return if defined $v && $v eq '.';
return $v;
}
sub strand { return $_[0]->{fstrand} }
sub seqname {
my $self = shift;
my $seq = $self->_field('seqname');
$self->db->fetch(Sequence=>$seq);
}
sub method { shift->_field('method',@_) } # ... I prefer "method"
sub subtype { shift->_field('method',@_) } # ... or even "subtype"
sub type { shift->_field('type',@_) } # ... I prefer "type"
sub score { shift->_field('score',@_) } # float indicating some sort of score
sub frame { shift->_field('frame',@_) } # one of 1, 2, 3 or undef
sub info { # returns Ace::Object(s) with info about the feature
my $self = shift;
unless ($self->{group}) {
my $info = $self->{info}{group} || 'Method "'.$self->method.'"';
$info =~ s/(\"[^\"]*);([^\"]*\")/$1$;$2/g;
my @data = split(/\s*;\s*/,$info);
foreach (@data) { s/$;/;/g }
$self->{group} = [map {$self->toAce($_)} @data];
}
return wantarray ? @{$self->{group}} : $self->{group}->[0];
}
# bioperl compatibility
sub primary_tag { shift->type(@_) }
sub source_tag { shift->subtype(@_) }
sub db { # database identifier (from Ace::Sequence::Multi)
my $self = shift;
my $db = $self->_field('db',@_);
return $db || $self->SUPER::db;
}
sub group { $_[0]->info; }
sub target { $_[0]->info; }
sub asString {
my $self = shift;
my $name = $self->SUPER::asString;
my $type = $self->type;
return "$type:$name";
}
# unique ID
sub id {
my $self = shift;
my $source = $self->source->name;
my $start = $self->start;
my $end = $self->end;
return "$source/$start,$end";
}
# map info into a reasonable set of ace objects
sub toAce {
my $self = shift;
my $thing = shift;
my ($tag,@values) = $thing=~/(\"[^\"]+?\"|\S+)/g;
foreach (@values) { # strip the damn quotes
s/^\"(.*)\"$/$1/; # get rid of leading and trailing quotes
}
return $self->tag2ace($tag,@values);
}
# synthesize an artificial Ace object based on the tag
sub tag2ace {
my $self = shift;
my ($tag,@data) = @_;
# Special cases, hardcoded in Ace GFF code...
my $db = $self->db;;
my $class = $db->class;
# for Notes we just return a text, no database associated
return $class->new(Text=>$data[0]) if $tag eq 'Note';
Ace/Sequence/Feature.pm view on Meta::CPAN
# General case:
my $obj = $class->new($tag=>$data[0],$self->db);
return $obj if defined $obj;
# Last resort, return a Text
return $class->new(Text=>$data[0]);
}
sub sub_SeqFeature {
return wantarray ? () : 0;
}
1;
=head1 NAME
Ace::Sequence::Feature - Examine Sequence Feature Tables
=head1 SYNOPSIS
Ace/Sequence/Feature.pm view on Meta::CPAN
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
__END__
# SCRAPS
# the new() code done "right"
# sub new {
# my $pack = shift;
# my ($ref,$r_offset,$r_strand,$gff_line) = @_;
# my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t";
# ($start,$end) = ($end,$start) if $strand < 0;
# my $self = $pack->SUPER::new($source,$start,$end);
# $self->{info} = {
# seqname=> $sourceseq,
# method => $method,
# type => $type,
# score => $score,
( run in 0.488 second using v1.01-cache-2.11-cpan-4d50c553e7e )