AcePerl
view release on metacpan or search on metacpan
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) = @_;
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
) {
return $self->get($class,$pattern,$filled);
}
$offset += 0;
$pattern ||= '*';
$pattern = Ace->freeprotect($pattern);
if (defined $query) {
$query = "query $query" unless $query=~/^query\s/;
} elsif (defined $class) {
$query = qq{find $class $pattern};
} else {
croak "must call fetch() with the -class or -query arguments";
}
my ($cnt) = $r =~ /Found (\d+) objects/m;
$$total = $cnt if defined $total;
# Scalar context and a pattern match operation. Return the
# object count without bothering to fetch the objects
return $cnt if !wantarray and $pattern =~ /(?:[^\\]|^)[*?]/;
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;
foreach (split "\n",$r) {
next if m!^//!;
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) = @_;
# 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($_);
next unless $class and $name;
my $obj = $self->memory_cache_fetch($class,$name);
$obj ||= $self->file_cache_fetch($class,$name);
unless ($obj) {
$obj = $self->class_for($class,$name)->new($class,$name,$self,1);
If not otherwise specified, the following cache parameters are assumed:
Parameter Default Value
--------- -------------
namespace Server URL (e.g. sace://localhost:2005)
cache_root /tmp/FileCache (dependent on system temp directory)
default_expires_in 1 day
auto_purge_interval 12 hours
By default, the cache is not size limited (the "max_size" property is
set to $NO_MAX_SIZE). To adjust the size you may consider calling the
Ace object's cache() method to retrieve the physical cache and then
calling the cache object's limit_size($max_size) method from time to
time. See L<Cache::SizeAwareFileCache> for more details.
=item B<-program>
By default AcePerl will use its internal compiled code calls to
establish a connection to Ace servers, and will launch a I<tace>
subprocess to communicate with local Ace databases. The B<-program>
argument allows you to customize this behavior by forcing AcePerl to
The value of B<-class> can also be an object or a classname that
implements a class_for() method. This method will receive three
arguments containing the AceDB class name, object ID and database
handle. It should return a string indicating the perl class to
create.
=item B<-timeout>
If no response from the server is received within $timeout seconds,
the call will return an undefined value. Internally timeout sets an
alarm and temporarily intercepts the ALRM signal. You should be aware
of this if you use ALRM for your own purposes.
NOTE: this feature is temporarily disabled (as of version 1.40)
because it is generating unpredictable results when used with
Apache/mod_perl.
=item B<-query_timeout>
If any query takes longer than $query_timeout seconds, will return an
undefined value. This value can only be set at connect time, and cannot
be changed once set.
=back
If arguments are omitted, they will default to the following values:
-host localhost
-port 200005;
-path no default
-program tace
-class Ace::Object
Once you have established a connection and have an Ace databaes
handle, several methods can be used to query the ACE database to
retrieve objects. You can then explore the objects, retrieve specific
fields from them, or update them using the I<Ace::Object> methods.
Please see L<Ace::Object>.
=head2 fetch() method
$count = $db->fetch($class,$name_pattern);
$object = $db->fetch($class,$name);
@objects = $db->fetch($class,$name_pattern,[$count,$offset]);
@objects = $db->fetch(-name=>$name_pattern,
-class=>$class
-count=>$count,
-offset=>$offset,
-fill=>$fill,
-filltag=>$tag,
-total=>\$total);
@objects = $db->fetch(-query=>$query);
Ace::fetch() retrieves objects from the database based on their class
and name. You may retrieve a single object by requesting its name, or
a group of objects by fetching a name I<pattern>. A pattern contains
one or more wildcard characters, where "*" stands for zero or more
characters, and "?" stands for any single character.
"filled" or an "unfilled" object. A filled object contains the entire
contents of the object, including all tags and subtags. In the case
of certain Sequence objects, this may be a significant amount of data.
Unfilled objects consist just of the object name. They are filled in
from the database a little bit at a time as tags are requested. By
default, fetch() returns the unfilled object. This is usually a
performance win, but if you know in advance that you will be needing
the full contents of the retrieved object (for example, to display
them in a tree browser) it can be more efficient to fetch them in
filled mode. You do this by calling fetch() with the argument of
B<-fill> set to a true value.
The B<-filltag> argument, if provided, asks the database to fill in
the subtree anchored at the indicated tag. This will improve
performance for frequently-accessed subtrees. For example:
@objects = $db->fetch(-name => 'D123*',
-class => 'Sequence',
-filltag => 'Visible');
This will fetch all Sequences named D123* and fill in their Visible
trees in a single operation.
Other arguments in the named parameter calling form are B<-count>, to
retrieve a certain maximum number of objects, and B<-offset>, to
retrieve objects beginning at the indicated offset into the list. If
you want to limit the number of objects returned, but wish to learn
how many objects might have been retrieved, pass a reference to a
scalar variable in the B<-total> argument. This will return the
object count. This example shows how to fetch 100 Sequence
objects, starting at Sequence number 500:
@some_sequences = $db->fetch('Sequence','*',100,500);
The next example uses the named argument form to fetch 100 Sequence
objects starting at Sequence number 500, and leave the total number of
Sequences in $total:
@some_sequences = $db->fetch(-class => 'Sequence',
-count => 100,
-offset => 500,
-total => \$total);
Notice that if you leave out the B<-name> argument the "*" wildcard is
assumed.
You may also pass an arbitrary Ace query string with the B<-query>
argument. This will supersede any name and class you provide.
Example:
@ready_dnas= $db->fetch(-query=>
$count = $db->aql($aql_query);
@objects = $db->aql($aql_query);
Ace::aql() will perform an AQL query on the database. In a scalar
context it returns the number of rows returned. In an array context
it returns a list of rows. Each row is an anonymous array containing
the columns returned by the query as an Ace::Object.
If an AQL error is encountered, will return undef or an empty list and
set Ace->error to the error message.
Note that this routine is not optimized -- there is no iterator
defined. All results are returned synchronously, leading to large
memory consumption for certain queries.
=head2 put() method
$cnt = $db->put($obj1,$obj2,$obj3);
This method will put the list of objects into the database,
the second argument to this method.
Any parse error messages are accumulated in Ace->error().
=head2 new() method
$object = $db->new($class => $name);
This method creates a new object in the database of type $class and
name $name. If successful, it returns the newly-created object.
Otherwise it returns undef and sets $db->error().
$name may contain sprintf()-style patterns. If one of the patterns is
%d (or a variant), Acedb uses a class-specific unique numbering to return
a unique name. For example:
$paper = $db->new(Paper => 'wgb%06d');
The object is created in the database atomically. There is no chance to rollback as there is
in Ace::Object's object editing methods.
See also the Ace::Object->add() and replace() methods.
=head2 list() method
@objects = $db->list(class,pattern,[count,offset]);
@objects = $db->list(-class=>$class,
-name=>$name_pattern,
-count=>$count,
-offset=>$offset);
This is a deprecated method. Use fetch() instead.
=head2 count() method
$count = $db->count($class,$pattern);
$count = $db->count(-query=>$query);
This function queries the database for a list of objects matching the
specified class and pattern, and returns the object count. For large
sets of objects this is much more time and memory effective than
fetching the entire list.
The class and name pattern are the same as the list() method above.
You may also provide a B<-query> argument to instead specify an
arbitrary ACE query such as "find Author COUNT Paper > 80". See
find() below.
=head2 find() method
@objects = $db->find($query_string);
@objects = $db->find(-query => $query_string,
-offset=> $offset,
-count => $count
-fill => $fill);
This allows you to pass arbitrary Ace query strings to the server and
retrieve all objects that are returned as a result. For example, this
code fragment retrieves all papers written by Jean and Danielle
Thierry-Mieg.
@papers = $db->find('author IS "Thierry-Mieg *" ; >Paper');
You can find the full query syntax reference guide plus multiple
examples at http://probe.nalusda.gov:8000/acedocs/index.html#query.
In the named parameter calling form, B<-count>, B<-offset>, and
B<-fill> have the same meanings as in B<fetch()>.
=head2 fetch_many() method
$obj = $db->fetch_many($class,$pattern);
$obj = $db->fetch_many(-class=>$class,
-name =>$pattern,
-fill =>$filled,
-chunksize=>$chunksize);
$obj = $db->fetch_many(-query=>$query);
If you expect to retrieve many objects, you can fetch an iterator
across the data set. This is friendly both in terms of network
bandwidth and memory consumption. It is simple to use:
$i = $db->fetch_many(Sequence,'*'); # all sequences!!!!
while ($obj = $i->next) {
print $obj->asTable;
}
The iterator will return undef when it has finished iterating, and
cannot be used again. You can have multiple iterators open at once
and they will operate independently of each other.
database. It may return fewer objects per transaction, particularly
if the objects are large.
You may provide raw Ace query string with the B<-query> argument. If
present the B<-name> and B<-class> arguments will be ignored.
=head2 find_many() method
This is an alias for fetch_many(). It is now deprecated.
=head2 keyset() method
@objects = $db->keyset($keyset_name);
This method returns all objects in a named keyset. Wildcard
characters are accepted, in which case all keysets that match the
pattern will be retrieved and merged into a single list of unique
objects.
=head2 grep() method
@objects = $db->grep($grep_string);
$count = $db->grep($grep_string);
@objects = $db->grep(-pattern => $grep_string,
-offset=> $offset,
-count => $count,
-fill => $fill,
-filltag => $filltag,
-total => \$total,
-long => 1,
);
This performs a "grep" on the database, returning all object names or
text that contain the indicated grep pattern. In a scalar context
this call will return the number of matching objects. In an array
context, the list of matching objects are retrieved. There is also a
named-parameter form of the call, which allows you to specify the
number of objects to retrieve, the offset from the beginning of the
list to retrieve from, whether the retrieved objects should be filled
initially. You can use B<-total> to discover the total number of
objects that match, while only retrieving a portion of the list.
By default, grep uses a fast search that only examines class names and
lexiques. By providing a true value to the B<-long> parameter, you
can search inside LongText and other places that are not usually
touched on, at the expense of much more CPU time.
Due to "not listable" objects that may match during grep, the list of
$style = $db->date_style('ace');
$style = $db->date_style('java');
For historical reasons, AceDB can display dates using either of two
different formats. The first format, which I call "ace" style, puts
the year first, as in "1997-10-01". The second format, which I call
"java" style, puts the day first, as in "01 Oct 1997 00:00:00" (this
is also the style recommended for Internet dates). The default is to
use the latter notation.
B<date_style()> can be used to set or retrieve the current style.
Called with no arguments, it returns the current style, which will be
one of "ace" or "java." Called with an argument, it will set the
style to one or the other.
=head2 timestamps() method
$timestamps_on = $db->timestamps();
$db->timestamps(1);
Whenever a data object is updated, AceDB records the time and date of
the update, and the user ID it was running under. Ordinarily, the
retrieval of timestamp information is suppressed to conserve memory
and bandwidth. To turn on timestamps, call the B<timestamps()> method
with a true value. You can retrieve the current value of the setting
by calling the method with no arguments.
Note that activating timestamps disables some of the speed
optimizations in AcePerl. Thus they should only be activated if you
really need the information.
=head2 auto_save()
Sets or queries the I<auto_save> variable. If true, the "save"
command will be issued automatically before the connection to the
Examples:
$db->auto_save(1);
$flag = $db->auto_save;
=head2 error() method
Ace->error;
This returns the last error message. Like UNIX errno, this variable
is not reset between calls, so its contents are only valid after a
method call has returned a result value indicating a failure.
For your convenience, you can call error() in any of several ways:
print Ace->error();
print $db->error(); # $db is an Ace database handle
print $obj->error(); # $object is an Ace::Object
There's also a global named $Ace::Error that you are free to use.
ACEDB requires. date() will truncate the time portion.
If not provided, $time defaults to localtime().
=head1 OTHER METHODS
=head2 debug()
$debug_level = Ace->debug([$new_level])
This class method gets or sets the debug level. Higher integers
increase verbosity. 0 or undef turns off debug messages.
=head2 name2db()
$db = Ace->name2db($name [,$database])
This class method associates a database URL with an Ace database
object. This is used internally by the Ace::Object class in order to
discover what database they "belong" to.
=head2 cache()
Get or set the Cache::SizeAwareFileCache object, if one has been
created.
=head2 memory_cache_fetch()
$obj = $db->memory_cache_fetch($class,$name)
Given an object class and name return a copy of the object from the
in-memory cache. The object will only be cached if a copy of the
object already exists in memory space. This is ordinarily called
internally.
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 = @_;
$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;
: $self->raw_query("spick $i",'no_alert');
if ($result =~ /Keyword spick does not match/) {
# _restore_iterator will now only work for a single iterator (non-reentrantly)
$self->{no_spick}++;
$self->raw_query('spop','no_alert') foreach @$list; # empty database stack
$self->{iterator_stack} = []; # and local copy
return;
}
unless (($result =~ /The stack now holds (\d+) keyset/ && ($1 == (@$list-1) ))
or
($result =~ /stack is (now )?empty/ && @$list == 1)
) {
$Ace::Error = 'Unexpected result from spick: $result';
return;
}
splice(@$list,$i,1); # remove from position
return 1;
}
Ace/Browser/AceSubs.pm view on Meta::CPAN
use CGI qw(:standard);
use CGI::Cookie;
my $obj = GetAceObject() || AceNotFound();
PrintTop($obj);
print $obj->asHTML;
PrintBottom();
=head1 DESCRIPTION
Ace::Browser::AceSubs exports a set of routines that are useful for
creating search pages and displays for AceBrowser CGI pages. See
http://stein.cshl.org/AcePerl/AceBrowser.
The following subroutines are exported by default:
AceError
AceMissing
AceNotFound
Configuration
DoRedirect
Ace/Browser/AceSubs.pm view on Meta::CPAN
Header
ResolveUrl
Style
Toggle
TypeSelector
To load the default subroutines load the module with:
use Ace::Browser::AceSubs;
To bring in a set of optionally routines, load the module with:
use Ace::Browser::AceSubs qw(AceInit AceRedirect);
To bring in all the default subroutines, plus some of the optional
ones:
use Ace::Browser::AceSubs qw(:DEFAULT AceInit AceRedirect);
There are two main types of AceBrowser scripts:
Ace/Browser/AceSubs.pm view on Meta::CPAN
if ($obj->CDS) {
my $protein = $obj->Corresponding_protein;
AceRedirect('protein',$protein);
}
AceRedirect must be called b<before> PrintTop() or AceHeader(). It
invokes exit(), so it will not return.
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');
Ace/Browser/AceSubs.pm view on Meta::CPAN
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();
# set up the feedback link
my $feedback_link = Configuration()->Feedback_recipients &&
$obj_name &&
(url(-relative=>1) ne 'feedback') ?
a({-href=>ResolveUrl("misc/feedback/$name","name=$obj_name;class=$obj_class;referer=$referer")},
"Click here to send data or comments to the maintainers")
: '';
# set up the privacy statement link
my $privacy_link = ( Configuration()->Print_privacy_statement &&
url(-relative=>1) ne PRIVACY())
?
a({ -href=>ResolveUrl(PRIVACY."/$name") },'Privacy Statement')
: '';
my ($home,$label) = @{Configuration()->Home};
my $hlink = $home ? a({-href=>$home},$label) : '';
# Either generate a pointer to ACeDB home page, or the copyright statement.
Ace/Browser/AceSubs.pm view on Meta::CPAN
)
);
}
=item $url = Object2URL($object)
=item $url = Object2URL($name,$class)
In its single-argument form, this function takes an AceDB Object and
returns an AceBrowser URL. The URL chosen is determined by the
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 {
Ace/Browser/AceSubs.pm view on Meta::CPAN
PrintTop(). You may add locally-defined stylesheet elements to the
hash before calling start_html(). See the pic script for an example
of how this is done this.
This function is not exported by default.
=cut
=item $url = ResolveUrl($url,$param)
Given a URL and a set of parameters, this function does the necessary
magic to add the symbolic database name to the end of the URL (if
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
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');
Ace/Browser/AceSubs.pm view on Meta::CPAN
: font({-color=>'red'},$label);
}
push (@rows,td({-align=>'CENTER',-class=>'small'},$cell));
}
return table({-width=>'100%',-border=>0,-class=>'searchtitle'},
TR({-valign=>'bottom'},@rows));
}
=item $url = Url($display,$params)
Given a symbolic display name, such as "tree" and a set of parameters,
this function looks up its URL and then calls ResolveUrl() to create a
single Url.
When hard-coding relative URLs into AceBrowser scripts, it is
important to pass them through Url(). The reason for this is that
AceBrowser may need to attach the database name to the URL in order to
identify it.
Example:
Ace/Browser/SearchSubs.pm view on Meta::CPAN
use Ace::Browser::SearchSubs;
use CGI qw(:standard);
my $form = p(start_form,
textfield(-name=>'query'),
end_form);
AceSearchTable('Search for stuff',$form);
...
my $query = param('query');
my $offset = AceSearchOffset;
my ($objects,$count) = do_search($query,$offset);
AceResultsTable($objects,$count,$offset,'Here are results');
=head1 DESCRIPTION
Ace::Browser::SearchSubs exports a set of constants and subroutines
that are useful for creating AceBrowser search scripts.
=head2 CONSTANTS
This package exports the following constants:
MAXOBJECTS The maximum number of objects that can be displayed
per page.
SEARCH_ICON An icon to use for search links. This is deprecated.
Ace/Browser/SearchSubs.pm view on Meta::CPAN
use CGI qw(:standard *table *Tr *td);
require Exporter;
@ISA = qw(Exporter);
$VERSION = '1.30';
######################### This is the list of exported subroutines #######################
@EXPORT = qw(
MAXOBJECTS
SEARCH_ICON
AceSearchTable AceResultsTable AceSearchOffset
DisplayInstructions
);
# ----- constants used by the pattern search script ------
use constant ROWS => 10; # how many rows to allocate for search results
use constant COLS => 5; # " " columns " " " "
use constant MAXOBJECTS => ROWS * COLS; # total objects per screen
use constant ICONS => '/ico';
use constant SEARCH_ICON => '/ico/search.gif';
use constant SPACER_ICON => 'spacer.gif';
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
Ace/Browser/SearchSubs.pm view on Meta::CPAN
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;
}
=item AceResultsTable($objects,$count,$offset,$title)
This subroutine formats the results of a search into a pageable list
and prints out the resulting HTML. The following arguments are required:
$objects An array reference containing the objects to place in the
table.
$count The total number of objects.
$offset The offset into the array, as returned by AceSearchOffset()
$title A title for the table.
The array reference should contain no more than MAXOBJECTS objects.
The AceDB query should be arranged in such a way that this is the
case. A typical idiom is the following:
my $offset = AceSearchOffset();
my $query = param('query');
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'},''),
start_table({-border=>0,-cellspacing=>2,-cellpadding=>2,-width=>'100%',-align=>'CENTER',-class=>'resultsbody'}),
TR(th({-class=>'resultstitle'},$title));
unless (@$objects) {
print end_table,p();
return;
}
print start_Tr,start_td;
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();
push(@buttons,td({-align=>'RIGHT',-valign=>'MIDDLE'},
$offset > 0
? a({-href=>$url
. '&scroll=-' . MAXOBJECTS},
img({-src=>$left,-alt=>'< PREVIOUS',-border=>0}))
: img({-src=>$spacer,-alt=>''})
)
);
my $p = 1;
while ($pages/$p > 25) { $p++; }
my (@v,%v);
Ace/Browser/SearchSubs.pm view on Meta::CPAN
foreach (param()) {
push(@hidden,hidden(-name=>$_,-value=>[param($_)]));
}
push(@buttons,
td({-valign=>'MIDDLE',-align=>'CENTER'},
start_form({-name=>'form1'}),
submit(-name=>'Go',-label=>'Go to'),
'page',
popup_menu(-name=>'scroll',-Values=>\@v,-labels=>\%v,
-default=>($page-1)*MAXOBJECTS-$offset,
-override=>1,
-onChange=>'document.form1.submit()'),
"of $pages",
@hidden,
end_form()
)
);
push(@buttons,td({-align=>'LEFT',-valign=>'MIDDLE'},
$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] }
Ace/Graphics/Glyph.pm view on Meta::CPAN
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 }
Ace/Graphics/Glyph.pm view on Meta::CPAN
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;
Ace/Graphics/Glyph.pm view on Meta::CPAN
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
$gd->setBrush($pen);
$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
Ace/Graphics/Glyph.pm view on Meta::CPAN
=over 4
=item $glyph = Ace::Graphics::Glyph->new(-feature=>$feature,-factory=>$factory)
Given a sequence feature, creates an Ace::Graphics::Glyph object to
display it. The -feature argument points to the
Ace::Sequence::Feature object to display. -factory indicates an
Ace::Graphics::GlyphFactory object from which the glyph will fetch all
its run-time configuration information.
A standard set of options are recognized. See L<OPTIONS>.
=back
=head2 OBJECT METHODS
Once a glyph is created, it responds to a large number of methods. In
this section, these methods are grouped into related categories.
Retrieving glyph context:
=over 4
=item $factory = $glyph->factory
Get the Ace::Graphics::GlyphFactory associated with this object. This
cannot be changed once it is set.
=item $feature = $glyph->feature
Get the sequence feature associated with this object. This cannot be
changed once it is set.
=back
Retrieving glyph options:
=over 4
=item $fgcolor = $glyph->fgcolor
=item $bgcolor = $glyph->bgcolor
Ace/Graphics/Glyph.pm view on Meta::CPAN
=over 4
=item $start = $glyph->start
=item $end = $glyph->end
These methods return the start and end of the glyph in base pair
units.
=item $offset = $glyph->offset
Returns the offset of the segment (the base pair at the far left of
the image).
=item $length = $glyph->length
Returns the length of the sequence segment.
=back
Retrieving formatting information:
Ace/Graphics/Glyph.pm view on Meta::CPAN
=item $glyph->calculate_left
Calculate the left side of the glyph.
=item $glyph->calculate_right
Calculate the right side of the glyph.
=item $glyph->draw($gd,$left,$top)
Optionally offset the glyph by the indicated amount and draw it onto
the GD::Image object.
=item $glyph->draw_label($gd,$left,$top)
Draw the label for the glyph onto the provided GD::Image object,
optionally offsetting by the amounts indicated in $left and $right.
=back
These methods are useful utility routines:
=over 4
=item $pixels = $glyph->map_pt($bases);
Map the indicated base position, given in base pair units, into
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
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);
if ($self->feature->start < $self->offset) { # off left end
if ($x2 > $a2) {
$gd->line($x1,$center,$x1+$a2,$center-$a2,$fg); # arrowhead
$gd->line($x1,$center,$x1+$a2,$center+$a2,$fg);
}
} else {
$gd->line($x1,$center-$a2,$x1,$center+$a2,$fg); # tick/base
}
if ($self->feature->end > $self->offset + $self->length) {# off right end
if ($x1 < $x2-$a2-1) {
$gd->line($x2,$center,$x2-$a2,$center+$a2,$fg); # arrowhead
$gd->line($x2,$center,$x2-$a2,$center-$a2,$fg);
}
} else {
# problems occur right at the very end because of GD confusion
$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 {
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
Option Description Default
-tick draw a scale 0
-rel_coords use relative coordinates false
for scale
The argument for b<-tick> is an integer between 0 and 2 and has the same
interpretation as the b<-tick> option in Ace::Graphics::Glyph::arrow.
If b<-rel_coords> is set to a true value, then the scale drawn on the
glyph will be in relative (1-based) coordinates relative to the beginning
of the glyph.
=head1 BUGS
Please report them.
=head1 SEE ALSO
L<Ace::Sequence>, L<Ace::Sequence::Feature>, L<Ace::Graphics::Panel>,
Ace/Graphics/Glyph/group.pm view on Meta::CPAN
# currently they are always on the same vertical level (no bumping)
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];
Ace/Graphics/Glyph/group.pm view on Meta::CPAN
# 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;
my ($x1,$y1,$x2,$y2) = $parts[0]->calculate_boundaries($left,$top);
my $center1 = ($y2 + $y1)/2;
$gd->setStyle($black,$black,gdTransparent,gdTransparent,);
for (my $i=0;$i<@parts-1;$i++) {
my ($x1,$y1,$x2,$y2) = $parts[$i]->calculate_boundaries($left,$top);
my ($x3,$y3,$x4,$y4) = $parts[$i+1]->calculate_boundaries($left,$top);
next unless ($x3 - $x1) >= 3;
$gd->line($x2+1,($y1+$y2)/2,$x3-1,($y3+$y4)/2,gdStyled);
}
}
1;
Ace/Graphics/Glyph/group.pm view on Meta::CPAN
Ace::Graphics::Glyph::group - The group glyph
=head1 SYNOPSIS
none
=head1 DESCRIPTION
This is an internal glyph type, used by Ace::Graphics::Track for
moving sets of glyphs around as a group. This glyph is created
automatically when processing a set of features passed to
Ace::Graphics::Panel->new as an array ref.
=head2 OPTIONS
In addition to the common options, the following glyph-specific
options are recognized:
Option Description Default
------ ----------- -------
Ace/Graphics/Glyph/segments.pm view on Meta::CPAN
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;
}
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
},$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;
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
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;
}
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
$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);
}
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
=head1 SYNOPSIS
use Ace::Graphics::GlyphFactory;
my $factory = Ace::Graphics::GlyphFactory($glyph_name,@options);
=head1 DESCRIPTION
The Ace::Graphics::GlyphFactory class is used internally by
Ace::Graphics::Track and Ace::Graphics::Glyph to hold the options
pertaining to a set of related glyphs and creating them on demand.
This class is not ordinarily useful to the end-developer.
=head1 METHODS
This section describes the class and object methods for
Ace::Graphics::GlyphFactory.
=head2 CONSTRUCTORS
There is only one constructor, the new() method. It is ordinarily
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
=head2 OBJECT METHODS
Once a track is created, the following methods can be invoked:
=over 4
=item $glyph = $factory->glyph($feature)
Given a sequence feature, creates an Ace::Graphics::Glyph object to
display it. The various attributes of the glyph are set from the
options provided at factory creation time.
=item $option = $factory->option($option_name [,$new_option])
Given an option name, returns its value. If a second argument is
provided, sets the option to the new value and returns its previous
one.
=item $index = $factory->fgcolor
Returns the desired foreground color for the glyphs in the form of an
GD::Image color index. This may be the one of the special colors
gdBrushed and gdStyled. This is only useful while the enclosing
Ace::Graphics::Panel object is rendering the object. In other
contexts it returns undef.
=item $scale = $factory->scale([$scale])
Get or set the scale, in pixels/bp, for the glyph. This is
ordinarily set by the Ace::Graphics::Track object just prior to
rendering, and called by each glyphs' map_pt() method when performing
the rendering.
=item $color = $factory->bgcolor([$color])
Get or set the background color for the glyphs.
=item $color = $factory->fillcolor([$color])
Get or set the fill color for the glyphs.
=item $font = $factory->font([$font])
Get or set the font to use for rendering the glyph.
=item $color = $factory->fontcolor
Get the color for the font (to set it, use fgcolor()). This is subtly
different from fgcolor() itself, because it will never return a styled
color, such as gdBrushed.
=item $panel = $factory->panel([$panel])
Get or set the panel that contains the GD::Image object used by this
factory.
=item $index = $factory->translate($color)
=item @rgb = $factory->rgb($index)
These are convenience procedures that are passed through to the
enclosing Panel object and have the same effect as the like-named
methods in that class. See L<Ace::Graphics::Panel>.
Ace/Graphics/Panel.pm view on Meta::CPAN
# 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;
$length ||= $options{-segment}->length if $options{-segment};
$offset ||= $options{-segment}->start-1 if $options{-segment};
return bless {
tracks => [],
width => $options{-width} || 600,
pad_top => $options{-pad_top}||0,
pad_bottom => $options{-pad_bottom}||0,
pad_left => $options{-pad_left}||0,
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};
Ace/Graphics/Panel.pm view on Meta::CPAN
$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;
}
Ace/Graphics/Panel.pm view on Meta::CPAN
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}});
$translation_table{$name} = $idx;
}
$self->{translations} = \%translation_table;
$self->{gd} = $gd;
my $offset = 0;
my $pl = $self->pad_left;
my $pt = $self->pad_top;
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);
Ace/Graphics/Panel.pm view on Meta::CPAN
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+/;
Ace/Graphics/Panel.pm view on Meta::CPAN
=head1 DESCRIPTION
The Ace::Graphics::Panel class provides drawing and formatting
services for Ace::Sequence::Feature objects or Das::Segment::Feature
objects.
Typically you will begin by creating a new Ace::Graphics::Panel
object, passing it the width of the visual display and the length of
the segment.
You will then call add_track() one or more times to add sets of
related features to the picture. When you have added all the features
you desire, you may call png() to convert the image into a PNG-format
image, or boxes() to return coordinate information that can be used to
create an imagemap.
Note that this modules depends on GD.
=head1 METHODS
This section describes the class and object methods for
Ace/Graphics/Panel.pm view on Meta::CPAN
=head2 CONSTRUCTORS
There is only one constructor, the new() method.
=over 4
=item $panel = Ace::Graphics::Panel->new(@options)
The new() method creates a new panel object. The options are
a set of tag/value pairs as follows:
Option Value Default
------ ----- -------
-length Length of sequence segment, in bp 0
-segment An Ace::Sequence or Das::Segment none
object, used to derive length if
not provided
-offset Base pair to place at extreme left $segment->start
of image.
-width Desired width of image, in pixels 600
-spacing Spacing between tracks, in pixels 5
-pad_top Additional whitespace between top 0
of image and contents, in pixels
-pad_bottom Additional whitespace between top 0
Ace/Graphics/Panel.pm view on Meta::CPAN
box A filled rectangle, nondirectional.
ellipse A filled ellipse, nondirectional.
arrow An arrow; can be unidirectional or bidirectional.
It is also capable of displaying a scale with
major and minor tickmarks, and can be oriented
horizontally or vertically.
segments A set of filled rectangles connected by solid lines.
Used for interrupted features, such as gapped
alignments.
transcript Similar to segments, but the connecting line is
a "hat" shape, and the direction of transcription
is indicated by a small arrow.
transcript2 Similar to transcript, but the arrow that indicates
the direction of transcription is the last exon
itself.
Ace/Graphics/Panel.pm view on Meta::CPAN
group A group of related features connected by a dashed line.
This is used internally by the Track class and should
not be called explicitly.
If the glyph name is omitted from add_track(), the "box" glyph will be
used by default.
The @options array is a list of name/value pairs that control the
attributes of the track. The options are in turn passed to the
glyphs. Each glyph has its own specialized subset of options, but
some are shared by all glyphs:
Option Description Default
------ ----------- -------
-glyph Glyph to use none
-fgcolor Foreground color black
-outlinecolor black
Ace/Graphics/Panel.pm view on Meta::CPAN
-height => 10,
-label => 1);
=item $track = unshift_track($glyph,$features,@options)
unshift_track() works like add_track(), except that the new track is
added to the top of the image rather than the bottom.
B<Adding groups of features:> It is not uncommon to add a group of
features which are logically connected, such as the 5' and 3' ends of
EST reads. To group features into sets that remain on the same
horizontal position and bump together, pass the sets as an anonymous
array. To connect the groups by a dashed line, pass the
-connect_groups argument with a true value. For example:
$panel->add_track(segments => [[$abc_5,$abc_3],
[$xxx_5,$xxx_3],
[$yyy_5,$yyy_3]],
-connect_groups => 1);
=item $gd = $panel->gd
Ace/Graphics/Panel.pm view on Meta::CPAN
bottomright corners of the glyph, including any space allocated for
labels.
=back
=head2 ACCESSORS
The following accessor methods provide access to various attributes of
the panel object. Called with no arguments, they each return the
current value of the attribute. Called with a single argument, they
set the attribute and return its previous value.
Note that in most cases you must change attributes prior to invoking
gd(), png() or boxes(). These three methods all invoke an internal
layout() method which places the tracks and the glyphs within them,
and then caches the result.
Accessor Name Description
------------- -----------
width() Get/set width of panel
spacing() Get/set spacing between tracks
length() Get/set length of segment (bp)
pad_top() Get/set top padding
pad_left() Get/set left padding
pad_bottom() Get/set bottom padding
pad_right() Get/set right padding
=head2 INTERNAL METHODS
The following methods are used internally, but may be useful for those
implementing new glyph types.
=over 4
=item @names = Ace::Graphics::Panel->color_names
Ace/Graphics/Panel.pm view on Meta::CPAN
glyph's draw() routine, after the panel has allocated a GD::Image and
is populating it.
=item $index = $panel->translate($color)
Given a color, returns the GD::Image index. The color may be
symbolic, such as "turquoise", or a #RRGGBB triple, as in #F0E0A8.
This method is only useful within a glyph's draw() routine, after the
panel has allocated a GD::Image and is populating it.
=item $panel->set_pen($width,$color)
Changes the width and color of the GD drawing pen to the values
indicated. This is called automatically by the GlyphFactory fgcolor()
method.
=back
=head1 BUGS
Please report them.
Ace/Graphics/Track.pm view on Meta::CPAN
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(@_);
Ace/Graphics/Track.pm view on Meta::CPAN
$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;
Ace/Graphics/Track.pm view on Meta::CPAN
}
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);
}
Ace/Graphics/Track.pm view on Meta::CPAN
}
# 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
my @singletons = map { $factory->glyph($_) } @$f;
# create linked groups of glyphs
my @groups;
if (my $groups = $self->{group_ids}) {
my $groupfactory = Ace::Graphics::GlyphFactory->new('group');
for my $g (values %$groups) {
Ace/Graphics/Track.pm view on Meta::CPAN
return $self->{glyphs} = [] unless @singletons || @groups;
# run the bumper on the groups
$self->_bump([@singletons,@groups]) if $self->bump;
# merge the singletons and groups and sort them horizontally
my @glyphs = sort {$a->left <=> $b->left } @singletons,map {$_->members} @groups;
# 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
Ace/Graphics/Track.pm view on Meta::CPAN
$track->add_feature($_);
}
my $boxes = $panel->boxes;
print $panel->png;
=head1 DESCRIPTION
The Ace::Graphics::Track class is used by Ace::Graphics::Panel to lay
out a set of sequence features using a uniform glyph type. You will
ordinarily work with panels rather than directly with tracks.
=head1 METHODS
This section describes the class and object methods for
Ace::Graphics::Panel.
=head2 CONSTRUCTORS
There is only one constructor, the new() method. It is ordinarily
Ace/Graphics/Track.pm view on Meta::CPAN
Once a track is created, the following methods can be invoked.
=over 4
=item $track->add_feature($feature)
This adds a new feature to the track. The feature can either be a
single object that implements the Bio::SeqFeatureI interface (such as
an Ace::Sequence::Feature or Das::Segment::Feature), or can be an
anonymous array containing a set of related features. In the latter
case, the track will attempt to keep the features in the same
horizontal band and will not allow any other features to overlap.
=item $track->add_group($group)
This behaves the same as add_feature(), but requires that its argument
be an array reference containing a list of grouped features.
=item $track->draw($gd,$left,$top)
Render the track on a previously-created GD::Image object. The $left
and $top arguments indicate the position at which to start rendering.
=item $boxes = $track->boxes($left,$top)
=item @boxes = $track->boxes($left,$top)
Return an array of array references indicating glyph coordinates for
each of the render features. $left and $top indicate the offset for
the track on the image plane. In a scalar context, this method
returns an array reference of glyph coordinates. In a list context,
it returns the list itself.
See Ace::Graphics::Panel->boxes() for the format of the result.
=back
=head2 ACCESSORS
The following accessor methods provide access to various attributes of
the track object. Called with no arguments, they each return the
current value of the attribute. Called with a single argument, they
set the attribute and return its previous value.
Note that in most cases you must change attributes before the track's
layout() method is called.
Accessor Name Description
------------- -----------
scale() Get/set the track scale, measured in pixels/bp
lineheight() Get/set the height of each glyph, pixels
width() Get/set the width of the track
bump() Get/set the bump direction
=head2 INTERNAL METHODS
The following methods are used internally, but may be useful for those
implementing new glyph types.
=over 4
=item $glyphs = $track->layout
Ace/Graphics/Track.pm view on Meta::CPAN
Invokes layout() and returns the height of the track.
=item $glyphs = $track->glyphs
Returns the glyph cache. Returns undef before layout() and a
reference to an array of glyphs after layout().
=item $factory = $track->make_factory(@options)
Given a set of options (argument/value pairs), returns a
Ace::Graphics::GlyphFactory for use in creating the glyphs with the
desired settings.
=back
=head1 BUGS
Please report them.
=head1 SEE ALSO
L<Ace::Sequence>,L<Ace::Sequence::Feature>,L<Ace::Graphics::Panel>,
Ace/Local.pm view on Meta::CPAN
Used when invoking I<gifaceclient>. Indicates the host to connect to.
=item B<-port>
Used when invoking I<gifaceclient>. Indicates the port to connect to.
=item B<-nosync>
Ordinarily Ace::Local synchronizes with the tace/giface prompt,
throwing out all warnings and copyright messages. If this is set,
Ace::Local will not do so. In this case you must call the low_read()
method until it returns undef in order to synchronize.
=back
=head2 query()
$status = $accessor->query('query string');
Send the query string to the server and return a true value if
Ace/Object.pm view on Meta::CPAN
# $Id: Object.pm,v 1.60 2005/04/13 14:26:08 lstein Exp $
use overload
'""' => 'name',
'==' => 'eq',
'!=' => 'ne',
'fallback' => 'TRUE';
use vars qw($AUTOLOAD $DEFAULT_WIDTH %MO $VERSION);
use Ace 1.50 qw(:DEFAULT rearrange);
# if set to 1, will conflate tags in XML output
use constant XML_COLLAPSE_TAGS => 1;
use constant XML_SUPPRESS_CONTENT=>1;
use constant XML_SUPPRESS_CLASS=>1;
use constant XML_SUPPRESS_VALUE=>0;
use constant XML_SUPPRESS_TIMESTAMPS=>0;
require AutoLoader;
$DEFAULT_WIDTH=25; # column width for pretty-printing
$VERSION = '1.66';
Ace/Object.pm view on Meta::CPAN
return $self->search($func_name,@_) if wantarray;
my ($obj) = @_ ? $self->search($func_name,@_) : $self->search($func_name,1);
# these nasty heuristics simulate aql semantics.
# undefined return
return unless defined $obj;
# don't dereference object if '@' symbol specified
return $obj if $no_dereference;
# don't dereference if an offset was explicitly specified
return $obj if defined($_[0]) && $_[0] =~ /\d+/;
# otherwise dereference if the current thing is an object or we are at a tag
# and the thing to the right is an object.
return $obj->fetch if $obj->isObject && !$obj->isRoot; # always dereference objects
# otherwise return the thing itself
return $obj;
} elsif ($func_name =~ /^[A-Z]/ && $self->isTag) { # follow tag
return $self->search($func_name);
Ace/Object.pm view on Meta::CPAN
Or you might prefer to use the tag[2] syntax here:
my($left,$right) = $clone->get('Map',1)->at('Ends[2]');
Although not frequently used, there is a form of get() which allows
you to stack subtags:
$locus = $object->get('Positive'=>'Positive_locus');
Only on subtag is allowed. You can follow this by a position if wish
to offset from the subtag.
$locus = $object->get('Positive'=>'Positive_locus',1);
=head2 search() method
This is a deprecated synonym for get().
=head2 Autogenerated Access Methods
$scalar = $object->Name_of_tag;
Ace/Object.pm view on Meta::CPAN
$lab_address = $object->Laboratory(-filled=>'Address');
** NOTE: In a scalar context, if the node to the right of the tag is
** an object, the method will perform an implicit dereference of the
** object. For example, in the case of:
$lab = $author->Laboratory;
**NOTE: The object returned is the dereferenced Laboratory object, not
a node in the Author object. You can control this by giving the
autogenerated method a numeric offset, such as Laboratory(0) or
Laboratory(1). For backwards compatibility, Laboratory('@') is
equivalent to Laboratory(1).
The semantics of the autogenerated methods have changed subtly between
version 1.57 (the last stable release) and version 1.62. In earlier
versions, calling an autogenerated method in a scalar context returned
the subtree rooted at the tag. In the current version, an implicit
right() and dereference is performed.
Ace/Object.pm view on Meta::CPAN
that contains just the class and object names. Use with care!
In the case of failure, which commonly happens when the database is
not open for writing, this method will return undef. A description of
the problem can be found by calling the error() method.
=head2 date_style() method
$object->date_style('ace');
This is a convenience method that can be used to set the date format
for all objects returned by the database. It is exactly equivalent to
$object->db->date_style('ace');
Note that the text representation of the date will change for all
objects returned from this database, not just the current one.
=head2 isRoot() method
print "Top level object" if $object->isRoot;
Ace/Object.pm view on Meta::CPAN
$name =~ s/([^a-zA-Z0-9_-])/\\$1/g;
return 1 unless exists $self->{'.update'} && $self->{'.update'};
$Ace::Error = '';
my $result = '';
# bad design alert: the following breaks encapsulation
if ($db->db->can('write')) { # new way for socket server
my $cmd = join "\n","$self->{'class'} : $name",@{$self->{'.update'}};
warn $cmd if $self->debug;
$result = $db->raw_query($cmd,0,'parse'); # sets Ace::Error for us
} else { # old way for RPC server and local
my $cmd = join('; ',"$self->{'class'} : $name",
@{$self->{'.update'}});
warn $cmd if $self->debug;
$result = $db->raw_query("parse = $cmd");
}
if (defined($result) and $result=~/write( or admin)? access/im) { # this keeps changing
$Ace::Error = "Write access denied";
} elsif (defined($result) and $result =~ /sorry|parse error/mi) {
Ace/Object.pm view on Meta::CPAN
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;
Ace/Sequence.pm view on Meta::CPAN
*source_seq = \&source;
*source_tag = \&subtype;
*primary_tag = \&type;
my %plusminus = ( '+' => '-',
'-' => '+',
'.' => '.');
# internal keys
# parent => reference Sequence in "+" strand
# p_offset => our start in the parent
# length => our length
# strand => our strand (+ or -)
# refseq => reference Sequence for coordinate system
# object constructor
# usually called like this:
# $seq = Ace::Sequence->new($object);
# 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'],
],@_);
# Object must have a parent sequence and/or a reference
# sequence. In some cases, the parent sequence will be the
# object itself. The reference sequence is used to set up
# the frame of reference for the coordinate system.
# fetch the sequence object if we don't have it already
croak "Please provide either a Sequence object or a database and name"
unless ref($seq) || ($seq && $db);
# convert start into offset
$offset = $start - 1 if defined($start) and !defined($offset);
# convert stop/end into length
$length = ($end > $start) ? $end - $offset : $end - $offset - 2
if defined($end) && !defined($length);
# if just a string is passed, try to fetch a Sequence object
my $obj = ref($seq) ? $seq : $db->fetch('Sequence'=>$seq);
unless ($obj) {
Ace->error("No Sequence named $obj found in database");
return;
}
# get parent coordinates and length of this sequence
# the parent is an Ace Sequence object in the "+" strand
my ($parent,$p_offset,$p_length,$strand) = find_parent($obj);
return unless $parent;
# handle negative strands
my $r_strand = $strand;
my $r_offset = $p_offset;
$offset ||= 0;
$offset *= -1 if $strand < 0;
# handle feature objects
$offset += $obj->offset if $obj->can('smapped');
# get source
my $source = $obj->can('smapped') ? $obj->source : $obj;
# store the object into our instance variables
my $self = bless {
obj => $source,
offset => $offset,
length => $length || $p_length,
parent => $parent,
p_offset => $p_offset,
refseq => [$source,$r_offset,$r_strand],
strand => $strand,
absolute => 0,
automerge => 1,
},$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 {
Ace/Sequence.pm view on Meta::CPAN
if (ref($refseq) && ref($refseq) eq 'ARRAY') {
$arrayref = $refseq;
last BLOCK;
}
if (ref($refseq) && ($refseq->can('smapped'))) {
croak "Reference sequence has no common ancestor with sequence"
unless $self->parent eq $refseq->parent;
my ($a,$b,$c) = @{$refseq->{refseq}};
# $b += $refseq->offset;
$b += $refseq->offset;
$arrayref = [$refseq,$b,$refseq->strand];
last BLOCK;
}
# look up reference sequence in database if we aren't given
# database object already
$refseq = $self->db->fetch('Sequence' => $refseq)
unless $refseq->isa('Ace::Object');
croak "Invalid reference sequence" unless $refseq;
# find position of ref sequence in parent strand
my ($r_parent,$r_offset,$r_length,$r_strand) = find_parent($refseq);
croak "Reference sequence has no common ancestor with sequence"
unless $r_parent eq $self->{parent};
# set to array reference containing this information
$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;
Ace/Sequence.pm view on Meta::CPAN
push (@canonical_clones,$info->Clone) if $info->Clone;
}
}
}
foreach (@canonical_clones) {
$clones{$_} ||= {};
}
my @features;
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';
}
# BAD HACK ALERT. WE DON'T KNOW WHERE THE LEFT END OF THE CLONE IS SO WE USE
# THE MAGIC NUMBER -99_999_999 to mean "off left end" and
# +99_999_999 to mean "off right end"
for my $clone (keys %clones) {
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;
Ace/Sequence.pm view on Meta::CPAN
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) {
my $o = defined($ref_offset) ? $ref_offset : ($self->p_offset + $self->offset);
# find anything that looks like a numeric field and subtract offset from it
$$gff =~ s/(?<!\")\s+(-?\d+)\s+(-?\d+)/"\t" . ($1 - $o) . "\t" . ($2 - $o)/eg;
$$gff =~ s/^$parent/$source/mg;
$$gff =~ s/\#\#sequence-region\s+\S+/##sequence-region $ref_source/m;
$$gff =~ s/FMAP_FEATURES\s+"\S+"/FMAP_FEATURES "$ref_source"/m;
return;
} else { # strand eq '-'
my $o = defined($ref_offset) ? (2 + $ref_offset) : (2 + $self->p_offset - $self->offset);
$$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
Ace/Sequence.pm view on Meta::CPAN
}
# 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";
}
Ace/Sequence.pm view on Meta::CPAN
: $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+(.+)/;
Ace/Sequence.pm view on Meta::CPAN
$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//;
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,
-offset=>0,-length=>500_000);
# Get the GFF dump as a text string
$gff = $seq->gff;
# Limit dump to Predicted_genes
$gff_genes = $seq->gff(-features=>'Predicted_gene');
# Return a GFF object (using optional GFF.pm module from Sanger)
$gff_obj = $seq->GFF;
=head1 DESCRIPTION
I<Ace::Sequence>, and its allied classes L<Ace::Sequence::Feature> and
L<Ace::Sequence::FeatureList>, provide a convenient interface to the
ACeDB Sequence classes and the GFF sequence feature file format.
Using this class, you can define a region of the genome by using a
landmark (sequenced clone, link, superlink, predicted gene), an offset
from that landmark, and a distance. Offsets and distances can be
positive or negative. This will return an I<Ace::Sequence> object.
Once a region is defined, you may retrieve its DNA sequence, or query
the database for any features that may be contained within this
region. Features can be returned as objects (using the
I<Ace::Sequence::Feature> class), as GFF text-only dumps, or in the
form of the GFF class defined by the Sanger Centre's GFF.pm module.
This class builds on top of L<Ace> and L<Ace::Object>. Please see
their manual pages before consulting this one.
=head1 Creating New Ace::Sequence Objects, the new() Method
$seq = Ace::Sequence->new($object);
$seq = Ace::Sequence->new(-source => $object,
-offset => $offset,
-length => $length,
-refseq => $reference_sequence);
$seq = Ace::Sequence->new(-name => $name,
-db => $db,
-offset => $offset,
-length => $length,
-refseq => $reference_sequence);
In order to create an I<Ace::Sequence> you will need an active I<Ace>
database accessor. Sequence regions are defined using a "source"
sequence, an offset, and a length. Optionally, you may also provide a
"reference sequence" to establish the coordinate system for all
inquiries. Sequences may be generated from existing I<Ace::Object>
sequence objects, from other I<Ace::Sequence> and
I<Ace::Sequence::Feature> objects, or from a sequence name and a
database handle.
The class method named new() is the interface to these facilities. In
its simplest, one-argument form, you provide new() with a
previously-created I<Ace::Object> that points to Sequence or
sequence-like object (the meaning of "sequence-like" is explained in
Ace/Sequence.pm view on Meta::CPAN
recognized:
=over 4
=item -source
The sequence source. This must be an I<Ace::Object> of the "Sequence"
class, or be a sequence-like object containing the SMap tag (see
below).
=item -offset
An offset from the beginning of the source sequence. The retrieved
I<Ace::Sequence> will begin at this position. The offset can be any
positive or negative integer. Offets are B<0-based>.
=item -length
The length of the sequence to return. Either a positive or negative
integer can be specified. If a negative length is given, the returned
sequence will be complemented relative to the source sequence.
=item -refseq
Ace/Sequence.pm view on Meta::CPAN
In addition to the reference sequence, there are two other sequences
used by I<Ace::Sequence> for internal bookeeping. The "source"
sequence corresponds to the smallest ACeDB sequence object that
completely encloses the selected sequence segment. The "parent"
sequence is the smallest ACeDB sequence object that contains the
"source". The parent is used to derive the length and orientation of
source sequences that are not directly associated with DNA objects.
In many cases, the source sequence will be identical to the sequence
initially passed to the new() method. However, there are exceptions
to this rule. One common exception occurs when the offset and/or
length cross the boundaries of the passed-in sequence. In this case,
the ACeDB database is searched for the smallest sequence that contains
both endpoints of the I<Ace::Sequence> object.
The other common exception occurs in Ace 4.8, where there is support
for "sequence-like" objects that contain the C<SMap> ("Sequence Map")
tag. The C<SMap> tag provides genomic location information for
arbitrary object -- not just those descended from the Sequence class.
This allows ACeDB to perform genome map operations on objects that are
not directly related to sequences, such as genetic loci that have been
Ace/Sequence.pm view on Meta::CPAN
Start of this sequence, relative to the source sequence, using 1-based
indexing.
=head2 end()
$end = $seq->end;
End of this sequence, relative to the source sequence, using 1-based
indexing.
=head2 offset()
$offset = $seq->offset;
Offset of the beginning of this sequence relative to the source
sequence, using 0-based indexing. The offset may be negative if the
beginning of the sequence is to the left of the beginning of the
source sequence.
=head2 length()
$length = $seq->length;
The length of this sequence, in base pairs. The length may be
negative if the sequence's orientation is reversed relative to the
source sequence. Use abslength() to obtain the absolute value of
Ace/Sequence.pm view on Meta::CPAN
=head2 features()
@features = $seq->features;
@features = $seq->features('exon','intron','Predicted_gene');
@features = $seq->features('exon:GeneFinder','Predicted_gene:hand.*');
features() returns an array of I<Sequence::Feature> objects. If
called without arguments, features() returns all features that cross
the sequence region. You may also provide a filter list to select a
set of features by type and subtype. The format of the filter list
is:
type:subtype
Where I<type> is the class of the feature (the "feature" field of the
GFF format), and I<subtype> is a description of how the feature was
derived (the "source" field of the GFF format). Either of these
fields can be absent, and either can be a regular expression. More
advanced filtering is not supported, but is provided by the Sanger
Centre's GFF module.
Ace/Sequence.pm view on Meta::CPAN
Ordinarily the feature entries in the GFF file will be returned in
coordinates relative to the start of the I<Ace::Sequence> object.
Position 1 will be the start of the sequence object, and the "+"
strand will be the sequence object's natural orientation. However if
a true value is provided to B<-abs>, the coordinate system used will
be relative to the start of the source sequence, i.e. the native ACeDB
Sequence object (usually a cosmid sequence or a link).
If a reference sequence was provided when the I<Ace::Sequence> was
created, it will be used by default to set the coordinate system.
Relative coordinates can be reenabled by providing a false value to
B<-abs>.
Ordinarily the coordinate system manipulations automatically "do what
you want" and you will not need to adjust them. See also the abs()
method described below.
=item -features
The B<-features> argument filters the features according to a list of
Ace/Sequence/Feature.pm view on Meta::CPAN
%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
# handling coordinates. See SCRAPS below for what should be in here
$strand = '+1' if $strand < 0 && $r_strand < 0; # two wrongs do make a right
($start,$end) = ($end,$start) if $strand < 0;
my $offset = $start - 1;
my $length = ($end > $start) ? $end - $offset : $end - $offset - 2;
# handle negative strands
$offset ||= 0;
$offset *= -1 if $r_strand < 0 && $strand != $r_strand;
my $self= bless {
obj => $ref,
offset => $offset,
length => $length,
parent => $parent,
p_offset => $r_offset,
refseq => [$ref,$r_offset,$r_strand],
strand => $r_strand,
fstrand => $strand,
absolute => $abs,
info => {
seqname=> $sourceseq,
method => $method,
type => $type,
score => $score,
frame => $frame,
group => $group,
Ace/Sequence/Feature.pm view on Meta::CPAN
# 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);
}
Ace/Sequence/Feature.pm view on Meta::CPAN
Ace::Sequence::Feature - Examine Sequence Feature Tables
=head1 SYNOPSIS
# open database connection and get an Ace::Object sequence
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the homologies (a list of Ace::Sequence::Feature objs)
@homol = $seq->features('Similarity');
# Get information about the first one
$feature = $homol[0];
$type = $feature->type;
$subtype = $feature->subtype;
$start = $feature->start;
Ace/Sequence/Feature.pm view on Meta::CPAN
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,
# frame => $frame,
# group => $group,
Ace/Sequence/FeatureList.pm view on Meta::CPAN
=head1 NAME
Ace::Sequence::FeatureList - Lightweight Access to Features
=head1 SYNOPSIS
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# find out what's there
$list = $seq->feature_list;
# Scalar context: count all the features
$feature_count = $list->types;
# Array context: list all the feature types
@feature_types = $list->types;
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
my $self = shift;
$self->{base}->$func_name(@_);
}
sub new {
my $class = shift;
my $segments = shift;
my @segments = sort {$a->start <=> $b->start} @$segments;
# find the min and max for the alignment
my ($offset,$len);
if ($segments[0]->start < $segments[-1]->start) { # positive direction
$offset = $segments[0]->{offset};
$len = $segments[-1]->end - $segments[0]->start + 1;
} else {
$offset = $segments[-1]->{offset};
$len = $segments[0]->end - $segments[-1]->start + 1;
}
my $base = { %{$segments[0]} };
$base->{offset} = $offset;
$base->{length} = $len;
bless $base,ref($segments[0]);
return bless {
base => $base,
segments => $segments,
},$class;
}
sub smapped { 1; }
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
Ace::Sequence::GappedAlignment - Gapped alignment object
=head1 SYNOPSIS
# open database connection and get an Ace::Sequence object
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the gapped alignments
@alignments = $seq->alignments('EST_GENOME');
# get the aligned segments from the first one
@segs = $alignments[0]->segments;
# get the position of the first aligned segment on the
# source sequence:
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
Return a list of Ace::Sequence::Feature objects corresponding to
similar segments.
=item relative()
$relative = $gene->relative;
$gene->relative(1);
This turns on and off relative coordinates. By default, the exons and
intron features will be returned in the coordinate system used by the
gene. If relative() is set to a true value, then coordinates will be
expressed as relative to the start of the gene. The first exon will
(usually) be 1.
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,L<Ace::Sequence::Homol>,
L<Ace::Sequence::Feature>, L<Ace::Sequence::FeatureList>, L<GFF>
=head1 AUTHOR
Ace/Sequence/Gene.pm view on Meta::CPAN
Ace::Sequence::Gene - Simple "Gene" Object
=head1 SYNOPSIS
# open database connection and get an Ace::Object sequence
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the genes
@genes = $seq->genes;
# get the exons from the first one
@exons = $genes[0]->exons;
# get the introns
@introns = $genes[0]->introns
Ace/Sequence/Gene.pm view on Meta::CPAN
Return a list of Ace::Sequence::Feature objects corresponding to
coding sequence. THIS IS NOT YET IMPLEMENTED.
=item relative()
$relative = $gene->relative;
$gene->relative(1);
This turns on and off relative coordinates. By default, the exons and
intron features will be returned in the coordinate system used by the
gene. If relative() is set to a true value, then coordinates will be
expressed as relative to the start of the gene. The first exon will
(usually) be 1.
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,L<Ace::Sequence::Homol>,
L<Ace::Sequence::Feature>, L<Ace::Sequence::FeatureList>, L<GFF>
=head1 AUTHOR
Ace/Sequence/Multi.pm view on Meta::CPAN
}
# 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 @dbs = ($self->db,$self->secondary);
my %dbs = map { $_->asString => $_ } @dbs;
my ($r,$r_offset,$r_strand) = $self->refseq;
my $abs = $self->absolute;
if ($abs) {
$r_offset = 0;
$r = $self->parent;
$r_strand = '+1';
}
my @features;
foreach (split("\n",$gff)) {
next if m[^(?:\#|//)];
next unless $filter->($_);
next unless my ($dbname) = /\t(\S+)$/;
next unless my $db = $dbs{$dbname};
next unless my $parent = $self->parent;
push @features,Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$_,$db);
}
return @features;
}
1;
__END__
=head1 NAME
Ace/Sequence/Multi.pm view on Meta::CPAN
# open reference database
$ref = Ace->connect(-host=>'stein.cshl.org',-port=>200009);
# open some secondary databases
$db1 = Ace->connect(-host=>'stein.cshl.org',-port=>200010);
$db2 = Ace->connect(-path=>'/usr/local/acedb/mydata');
# Make an Ace::Sequence::Multi object
$seq = Ace::Sequence::Multi->new(-name => 'CHROMOSOME_I,
-db => $ref,
-offset => 3_000_000,
-length => 1_000_000);
# add the secondary databases
$seq->add_secondary($db1,$db2);
# get all the homologies (a list of Ace::Sequence::Feature objs)
@homol = $seq->features('Similarity');
# Get information about the first one -- goes to the correct db
$feature = $homol[0];
Ace/Sequence/Multi.pm view on Meta::CPAN
from which to fetch annotation information.
=over 4
=item -source
The sequence source. This must be an I<Ace::Object> of the "Sequence"
class, or be a sequence-like object containing the SMap tag (see
below).
=item -offset
An offset from the beginning of the source sequence. The retrieved
I<Ace::Sequence> will begin at this position. The offset can be any
positive or negative integer. Offets are B<0-based>.
=item -length
The length of the sequence to return. Either a positive or negative
integer can be specified. If a negative length is given, the returned
sequence will be complemented relative to the source sequence.
=item -refseq
Ace/Sequence/Transcript.pm view on Meta::CPAN
Ace::Sequence::Transcript - Simple "Gene" Object
=head1 SYNOPSIS
# open database connection and get an Ace::Object sequence
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the transcripts
@genes = $seq->transcripts;
# get the exons from the first one
@exons = $genes[0]->exons;
# get the introns
@introns = $genes[0]->introns
Ace/Sequence/Transcript.pm view on Meta::CPAN
Return a list of Ace::Sequence::Feature objects corresponding to
coding sequence. THIS IS NOT YET IMPLEMENTED.
=item relative()
$relative = $gene->relative;
$gene->relative(1);
This turns on and off relative coordinates. By default, the exons and
intron features will be returned in the coordinate system used by the
gene. If relative() is set to a true value, then coordinates will be
expressed as relative to the start of the gene. The first exon will
(usually) be 1.
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,L<Ace::Sequence::Homol>,
L<Ace::Sequence::Feature>, L<Ace::Sequence::FeatureList>, L<GFF>
=head1 AUTHOR
acelib/wh/aceversion.h
acelib/wh/array.h
acelib/wh/bump.h
acelib/wh/bump_.h
acelib/wh/call.h
acelib/wh/dict.h
acelib/wh/freeout.h
acelib/wh/heap.h
acelib/wh/help.h
acelib/wh/help_.h
acelib/wh/keyset.h
acelib/wh/liste.h
acelib/wh/menu.h
acelib/wh/menu_.h
acelib/wh/mydirent.h
acelib/wh/mystdlib.h
acelib/wh/mytime.h
acelib/wh/regression.h
acelib/wh/regular.h
acelib/wh/version.h
acelib/wmake/ALPHA_4_DEF
Makefile.PL view on Meta::CPAN
}
}
$choice ||= 1; # safe default
my @extlib = ();
push @extlib,'Freesubs' if $choice >= 2;
push @extlib,'RPC' if $choice >= 3;
print "\n";
setup_sitedefs() if prompt("Do you want to install Ace::Browser? ","n") =~ /[yY]/;
my $headers = "./acelib/wh";
WriteMakefile(
'DISTNAME' => 'AcePerl',
'NAME' => 'Ace',
'VERSION_FROM' => 'Ace.pm', # finds $VERSION
'PMLIBDIRS' => ['GFF','Ace'],
'DIR' => \@extlib,
'DEFINE' => '',
'XSPROTOARG' => '-noprototypes',
Makefile.PL view on Meta::CPAN
PL_FILES => {'make_docs.PLS' => '.docs',
'util/install.PLS'=>'util/install.pl',
'util/ace.PLS'=>'util/ace.pl',
},
EXE_FILES => ['util/ace.pl'],
'clean' => {'FILES' => 'acelib/lib* acelib/*.o acelib/rpcace*.[ch]'},
);
exit 0;
sub setup_sitedefs {
my ($conf_path,$cgi_path,$html_path);
eval 'use Ace::Browser::LocalSiteDefs qw($SITE_DEFS $CGI_PATH $HTML_PATH)';
if ($SITE_DEFS) {
print "\n";
print "You have installed Ace::Browser before, using old settings for defaults.\n";
$conf_path = $SITE_DEFS;
$cgi_path = $CGI_PATH;
$html_path = $HTML_PATH;
}
$conf_path ||= '/usr/local/apache/conf/ace';
$cgi_path ||= '/usr/local/apache/cgi-bin/ace';
$html_path ||= '/usr/local/apache/htdocs/ace';
get_path("site-specific configuration files",\$conf_path);
get_path("acebrowser CGI scripts",\$cgi_path);
on installation.
At this point, Makefile.PL will create the make files necessary to build
AcePerl. Among other things, the Makefile.PL script will attempt
to guess the type of your machine and its operating system. This information
is needed to select the correct makefile in the ACEDB library
directory, AcePerl-X.XX/ace/.
If AcePerl fails to make correctly later in the process, it may be
because the script guessed wrong. You can override this guess by
setting the machine type using the ACEDB_MACHINE environment
variable. On a C-shell or TC-shell machine, use a command like
this one:
setenv ACEDB_MACHINE ALPHA_4_GCC; perl Makefile.PL
On a Bourne-shell or Korn-shell system, use:
ACEDB_MACHINE=ALPHA_4_GCC; export ACEDB_MACHINE
perl Makefile.PL
You can find a list of machine definitions in
AcePerl-X.XX/ace/wmake. There are lots of them, but only
one or two per operating system, so it's usually pretty
easy to choose the right one. The definitions have names
like ALPHA_4_GCC_DEF. Before setting the corresponding
environment variable, remove the "_DEF" from the end of the name.
In case you're wondering the "4" stands for version 4 of the ACEDB
server.
Please drop me a line to let me know what you had to do to get
the ACEDB libraries to compile. I'll fix up the Makefile so
that it works correctly for the next person who tries it.
4. make
This will build the ACEDB client library, libaceperl.a, in the ace
subdirectory. It will then link in the Perl client subs.
5. make test (optional)
You may "make test" to test the system. It will attempt to open a
connection to a database at beta.crbm.cnrs-mop.fr:20000100. You may
change these defaults by setting the environment variables ACEDB_HOST
and ACEDB_PORT, or by defining them on the command line, as in:
make test ACEDB_HOST=localhost ACEDB_PORT=200005
However, since some of the tests are dependent on specific values in
the database, this may cause some tests to fail. Do not be alarmed if
a handful of tests fail. Do be alarmed if all of the tests fail.
6. make install
despair: see the next section.
INSTALLING ACEPERL IN A NON-STANDARD LOCATION
By default, Perl will install AcePerl's library files within the
site-specific subdirectory of its library tree, usually
/usr/local/lib/perl5/site_perl. If you wish, you can install the
library files elsewhere.
Simply change to the AcePerl distribution directory and run the
Makefile.PL script with the INSTALLSITELIB switch set to the full path
of the directory you want to install into:
perl Makefile.PL INSTALLSITELIB=/path/to/library
Then "make" and "make install" as described before. You will now have
to tell Perl where to find AcePerl. You can do this on a
script-by-script basis, or by defining an environment variable that
will affect all scripts.
To tell a single script where to find AcePerl, add a "use lib" line
use lib /path/to/library;
use Ace;
To change Perl's library search path so that it finds AcePerl
automatically, define the PERL5LIB environment variable in your
.login, .cshrc or .profile script. PERL5LIB is a colon-delimited list
of directories in which Perl will search for included libraries. For
example:
setenv PERL5LIB "/path/to/library";
If AcePerl was built as part of the main Ace distribution, you will
want to define PERL5LIB to be the location of the machine-specific
build directory. For example:
setenv PERL5LIB $HOME/ace/bin.LINUX_4_OPT
Or you could reinstall AcePerl in the main Perl library tree just by
entering the wperl/ subdirectory, and rerunning "perl Makefile.PL"
without defining INSTALLSITELIB.
See ACEDB.HOWTO in the docs/ subdirectory for instructions on
obtaining and setting up the ACeDB database. You'll find other hints
here too.
USING ACEPERL
A. Read the copious documentation
perldoc Ace
B. Review the examples
Term::readline module installed, it gives you command-line editing,
completion, and history.
The script "dump_cdna.pl" shows you how to dump out all spliced cDNAs
from wormbase.org. Other dump scripts show similar tricks. You can
use these as templates for doing other biologically interesting
tricks.
There is also family of CGI scripts that run on top of AcePerl to give
a WebAce-like interface to Ace (it is not as feature-full as WebAce,
but it is probably easier to set up and run). This package is now part
of the AcePerl distribution, but is not installed unless you specifically
request it. See README.ACEBROWSER for details.
INSTALLING THE ACEDB SERVER
See ACEDB.HOWTO in the docs/ directory for instructions on compiling
acedb and installing the server application to start up when needed.
Lincoln Stein
lstein@cshl.org
README.ACEBROWSER view on Meta::CPAN
Acebrowser needs access to one or more configuration files.
Each file describes a data source and how information from
the data source is to be rendered. All configuration files
are stored in a directory at the location indicated here.
The default is /usr/local/apache/conf/ace/.
b. Acebrowser CGI script directory
The core of Acebrowser is a set of CGI scripts. This is the
directory that will contain them. Choose a directory that will
be recognized by the web server as containing CGI script. If
you are using Apache/mod_perl, select a directory under the
control of Apache::Registry.
The default is /usr/local/apache/cgi-bin/ace/
c. Acebrowser HTML files and images
Acebrowser uses a small number of static HTML files and images.
README.ACEBROWSER view on Meta::CPAN
Depending on the permissions of your web server directories, you may
have to be root in order to complete this step.
5. If you installed the CGI scripts in their default location, you
should now be able to search the C. elegans database by fetching the
following URL:
http://your.host/cgi-bin/ace/searches/text
You can then follow the links to browse the database. A slightly more
sophisticated search allows you to search a subset of object classes:
http://your.host/cgi-bin/ace/searches/basic
or the entire list of object classes:
http://your.host/cgi-bin/ace/searches/browser
There is also a default Acebrowser "home page" installed at the URL:
http://your.host/ace/index.html
README.ACEBROWSER view on Meta::CPAN
THE CONFIGURATION FILES
The configuration files are located in the directory selected for
acebrowser configuration. Their names are formed by appending ".pm"
to the symbolic name of the database. For example, the configuration
file "simple.pm" corresponds to the database "simple".
Each of the configuration files is actually an executable Perl script.
As such it can use any Perl constructions you wish, including variable
interpolation. The purpose of the configuration file is to set a
series of configuration variables, which by convention are all
uppercase. For example, here is an excerpt from the default.pm
configuration file:
$HOST = 'stein.cshl.org';
$PORT = 2005;
$USERNAME = '';
$PASSWORD = '';
In addition to scalar variables, the configuration file is used to set
arrays, hashes and specially-named functions.
If you are only interested in accessing a single database, it is
easiest to modify the default.pm configuration file. To serve
multiple databases, just make a copy of default.pm and edit the copy.
If, for some reason, Acebrowser cannot find its configuration files,
it will generate an internal server error. The location of the
configuration files directory is stored in the module
Ace::Browser::LocalSiteDefs, typically somewhere inside the
README.ACEBROWSER view on Meta::CPAN
find its configuration files by running the following command:
perl -MAce::Browser::LocalSiteDefs \
-e 'print $Ace::Browser::LocalSiteDefs::SITE_DEFS,"\n"'
To change this value, either reinstall Aceperl or edit
LocalSiteDefs.pm manually.
EDITING THE CONFIGURATION FILE
The settings in the default.pm configuration file distributed with
AcePerl should work with little, if any modification. The following
variables may need to be tweaked:
$ROOT = '/cgi-bin/ace';
This is the root (top level) for all the Acebrowser CGI scripts.
Change this if necessary.
$DOCROOT = '/ace';
README.ACEBROWSER view on Meta::CPAN
RPC-based gifaceserver.
$USERNAME = '';
$PASSWORD = '';
For password-protected ACEDB databases, these variables contain the
username and password.
$STYLESHEET = "$DOCROOT/stylesheets/aceperl.css";
This is the cascading stylesheet used to set the background color,
font, table colors, and so forth. You probably don't need to change
this, but you might want to modify the stylesheet itself.
@PICTURES = ($IMAGES => "$HTML_PATH/images");
This array indicates the location of the "images" subdirectory. The
first element of the array is the location of the directory as a URL,
and the second element is the location of the directory as a physical
path on the file system. This array is ignored when running under
modperl/Apache::Registry; modperl uses $IMAGES to look up the
README.ACEBROWSER view on Meta::CPAN
name => 'Class Browser',
url => "$ROOT/searches/browser",
},
query => {
name => 'Acedb Query',
url => "$ROOT/searches/query",
},
);
$SEARCH_ICON = "$ICONS/unknown.gif";
The @SEARCHES array sets the searches made available to users. The
first element in each pair is the symbolic name for the search. The
second element is a hash reference containing the keys "name" and
"url". The name is the bit of human readable text printed in the
list of searches located at the top of the AceBrowser page. The url
is the URL of the script that performs the search.
The $SEARCH_ICON variable selects an icon to use for the search
button.
README.ACEBROWSER view on Meta::CPAN
'url' => "generic/tree",
'label' => 'Tree Display',
'icon' => '/ico/text.gif' },
pic => {
'url' => "generic/pic",
'label' => 'Graphic Display',
'icon' => '/ico/image2.gif' },
);
As described in EXTENDING ACEBROWSER, the %DISPLAYS hash declares a
set of pages, or "displays", to be used for displaying certain Ace
object types.
%CLASSES = (
Default => [ qw/tree pic/ ],
);
As described in EXTENDING ACEBROWSER, the %CLASSES hash describes how
Acedb classes correspond to displays.
sub URL_MAPPER {
README.ACEBROWSER view on Meta::CPAN
The $BANNER variable contains HTML text that will be displayed at the
top of each generated page. You will probably want to change this.
$FOOTER = '';
The $FOOTER variable contains HTML text that is displayed at the
bottom of each generated page. You will probably want to change this.
$PRINT_PRIVACY_STATEMENT = 1;
If this variable is set to true, then AceBrowser will generate a link
in the footer that displays a privacy statement explaining
AceBrowser's use of cookies.
@FEEDBACK_RECIPIENTS = (
[ " $ENV{SERVER_ADMIN}", 'general complaints and suggestions', 1 ]
);
This array contains a list of recipient e-mail addresses for the
"feedback" page. Each recipient is an array reference containing
least two elements, the e-mail address and a comment. A third,
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
use constant WIDTH => 1024;
use constant HEIGHT => 768;
use constant ICONS => Configuration()->Icons;
use constant UP_ICON => ICONS .'/a_up.gif';
use constant DOWN_ICON => ICONS .'/a_down.gif';
use constant ZOOMIN_ICON => ICONS .'/a_zoomin.gif';
use constant ZOOMOUT_ICON => ICONS .'/a_zoomout.gif';
use constant JSCRIPT => <<END;
function send_click(e,url) {
if (e.offsetX)
send_click_ie(e,url);
else
send_click_ns(e,url);
}
function send_click_ns(e,url) {
window.location = url + (e.x-document.theMapImg.x) + '-' + (e.y-document.theMapImg.y);
}
function send_click_ie(e,url) {
window.location = url + e.offsetX + '-' + e.offsetY;
}
function s(obj,comment) {
if (obj != null) obj.title=comment;
window.status=comment;
return true;
}
function c() {
if (window.event) window.event.cancelBubble=true;
}
END
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
$map_start ||= $start;
$map_stop ||= $stop;
my($min,$max) = get_extremes($obj->db,$name);
# this section is responsible for centering on the place the user clicks
if (param('click')) {
my ($x,$y) = split '-',param('click');
my $pos = $map_start + $y/HEIGHT * ($map_stop - $map_start);
my $offset = $pos - ($map_start + $map_stop)/2;
$map_start += $offset;
$map_stop += $offset;
param('map_start' => $map_start);
param('map_stop' => $map_stop);
Delete('click');
}
my $self = url(-path_info=>1);
my $half = ($map_stop - $map_start)/2;
my $a1 = $map_start - $half;
acebrowser/cgi-bin/searches/basic view on Meta::CPAN
}
END
# fetch database handle
$DB = OpenDatabase() || AceError("Couldn't open database.");
my $search_class = param('class');
my $search_pattern = param('query');
my $offset = AceSearchOffset();
$URL = url();
$URL=~s!^http://[^/]+!!;
my ($objs,$count);
if (defined $search_class) {
if ($search_class eq 'Any' && $search_pattern) {
($objs,$count) = do_grep ($search_pattern,$offset);
} else {
($objs,$count) = do_search($search_class,$search_pattern || '*',$offset);
}
param('query' => param('query') . '*') if !$count && param('query') !~ /\*$/; #autoadd
}
DoRedirect(@$objs) if $count==1;
PrintTop(undef,undef,img({-src=>SEARCH_ICON,-align=>CENTER}).'Simple Search');
print p({-class=>'small'},
"Select the type of object you are looking for and optionally",
"type in a name or a wildcard pattern",
"(? for any one character. * for zero or more characters).",
"If no name is entered, the search displays all objects of the selected type.",
i('Anything'),'searches for the entered text across the entire database.');
display_search_form();
display_search($objs,$count,$offset,$search_class) if $search_class;
PrintBottom();
sub display_search_form {
CGI::autoEscape(0);
print start_form(-name=>'SimpleForm'),
table(
TR({-valign=>TOP},
acebrowser/cgi-bin/searches/basic view on Meta::CPAN
b('Name:'),textfield(-name=>'query'),br,
submit(-name=>'Search')
)
),
);
CGI::autoEscape(1);
print end_form();
}
sub do_search {
my ($class,$pattern,$offset) = @_;
my $count;
my (@objs) = $DB->fetch(-class=>$class,-pattern=>$pattern,
-count=>MAXOBJECTS,-offset=>$offset,
-total=>\$count);
return unless @objs;
return (\@objs,$count);
}
sub display_search {
my ($objs,$count,$offset,$class) = @_;
my $label = $class eq 'Any' ? '' :$class;
if ($count > 0) {
print p(strong($count),"$label objects found");
} else {
print p(font{-color=>'red'},'No matching objects found.',
'Try searching again with a * wildcard before or after the name (already added for you).');
return;
}
my @objects;
if ($class eq 'Any') {
@objects = map { a({-href=>Object2URL($_)},$_->class . ": $_") }
sort { $a->class cmp $b->class } @$objs;
} else {
@objects = map { a({-href=>Object2URL($_)},"$_") } @$objs;
}
AceResultsTable(\@objects,$count,$offset);
}
sub do_grep {
my ($text,$offset) = @_;
my $count;
my (@objs) = $DB->grep(-pattern=> $text,
-count => MAXOBJECTS,
-offset => $offset,
-total => \$count,
);
return unless @objs;
return (\@objs,$count);
}
acebrowser/cgi-bin/searches/browser view on Meta::CPAN
use lib '..';
use Ace 1.76;
use CGI::Carp qw/fatalsToBrowser/;
use CGI 2.42 qw/:standard :html3 escape/;
use Ace::Browser::AceSubs qw(:DEFAULT ResolveUrl DoRedirect);
use Ace::Browser::SearchSubs;
my $search_class = param('class');
my $search_pattern = param('query');
my $offset = AceSearchOffset();
# fetch database handle
$DB = OpenDatabase() || AceError("Couldn't open database.");
# here's where the search happens
my ($objs,$count);
$search_pattern ||= '*';
($objs,$count) = do_search($search_class,$search_pattern || '*',$offset) if $search_class;
DoRedirect(@$objs) if $count==1;
PrintTop(undef,undef,'Acedb Class Search');
display_search($objs,$count,$offset,$search_class,$search_pattern) if defined $search_class;
display_search_form();
PrintBottom;
sub display_search_form {
my @classlist = $DB->classes;
my $name = Configuration()->Name;
AceSearchTable("$name Class Browser",
table({-align=>'CENTER'},
TR({-valign=>'MIDDLE'},
td(td({-class=>'large',-rowspan=>2},scrolling_list(-name=>'class',
acebrowser/cgi-bin/searches/browser view on Meta::CPAN
td({-align=>'LEFT',-valign=>'TOP'},
table({-border=>0},
TR(td('Search pattern (optional):',textfield(-name=>'query'))),
TR(td({-align=>'RIGHT'},submit(-label=>'Search ACE')))))
)
)
);
}
sub do_search {
my ($class,$pattern,$offset) = @_;
my $count;
my (@objs) = $DB->fetch(-class=>$class,-pattern=>$pattern,
-count=>MAXOBJECTS,-offset=>$offset,
-total=>\$count);
return unless @objs;
return (\@objs,$count);
}
sub display_search {
my ($objs,$count,$offset,$class,$pattern) = @_;
my $title;
$title = $count > 0 ? p(strong($count),"objects of type",strong($class),"contain pattern",strong($pattern))
:p({-class=>'error'},'No matching objects found');
my @objects = map { ObjectLink($_) } @$objs;
AceResultsTable(\@objects,$count,$offset,$title);
}
acebrowser/cgi-bin/searches/query view on Meta::CPAN
use vars qw/$DB $URL %PAPERS/;
use Ace 1.38;
use CGI 2.42 qw/:standard :html3 escape/;
use CGI::Carp qw/fatalsToBrowser/;
use Ace::Browser::AceSubs qw(:DEFAULT DoRedirect);
use Ace::Browser::SearchSubs;
# zero globals in utilities
my $query = param('query');
my $offset = AceSearchOffset();
$URL = url();
$URL=~s!^http://[^/]+!!;
# fetch database handle
$DB = OpenDatabase() || AceError("Couldn't open database.");
my ($objs,$count);
($objs,$count) = do_search($query,$offset) if $query;
DoRedirect(@$objs) if $count==1;
PrintTop(undef,undef,'AceDB Query');
display_search_form();
display_search($objs,$count,$offset,$query) if $query;
PrintBottom();
sub display_search_form {
print p({-class=>'small'},
"Type in a search term using the Ace query language. Separate multiple statements with semicolons.",
br,
"Examples: ",
ul(
li(
acebrowser/cgi-bin/searches/query view on Meta::CPAN
sub do_search {
my ($query,$offset) = @_;
my $count;
my (@objs) = $DB->find(-query=> $query,
-count => MAXOBJECTS,
-offset => $offset,
-total => \$count);
return unless @objs;
return (\@objs,$count);
}
sub display_search {
my ($objs,$count,$offset,$query) = @_;
print p(strong($count),"objects satisfy the query",strong($query));
my @objects = map { a({-href=>Object2URL($_)},"$_") } @$objs;
AceResultsTable(\@objects,$count,$offset) if @objects;
}
acebrowser/cgi-bin/searches/text view on Meta::CPAN
use Ace 1.51;
use CGI 2.42 qw/:standard :html3 escape/;
use CGI::Carp qw/fatalsToBrowser/;
use Ace::Browser::AceSubs;
use Ace::Browser::SearchSubs;
# zero globals in utilities
my $pattern = param('query');
my $search_type = param('type');
my $offset = AceSearchOffset();
$URL = url();
$URL=~s!^http://[^/]+!!;
# fetch database handle
$DB = OpenDatabase() || AceError("Couldn't open database.");
my ($objs,$count);
($objs,$count) = do_search($pattern,$offset,$search_type) if $pattern;
DoRedirect(@$objs) if $count==1;
PrintTop(undef,undef,'AceDB Text Search');
display_search_form();
display_search($objs,$count,$offset,$pattern) if $pattern;
PrintBottom();
exit 0;
sub display_search_form {
print p({-class=>'small'},
"Type in text or keywords to search for.",
"The * and ? wildcard characters are allowed.");
print
start_form,
acebrowser/cgi-bin/searches/text view on Meta::CPAN
-labels=>{'short'=>'Fast search',
'long' =>'In-depth search'}
)
)
)
),
end_form;
}
sub do_search {
my ($pattern,$offset,$type) = @_;
my $count;
my (@objs) = $DB->grep(-pattern=> $pattern,
-count => MAXOBJECTS,
-offset => $offset,
-total => \$count,
-long => $type eq 'long',
);
return unless @objs;
return (\@objs,$count);
}
sub display_search {
my ($objs,$count,$offset,$pattern) = @_;
my $title = p(strong($count),"objects contain the keywords \"$pattern\"");
if(!$objs) {
print "<b>No matches were found.</b><p>\n";
return;
}
my @objects = map { ObjectLink($_,font({-color=>'red'},$_->class) . ": $_") }
sort { $a->class cmp $b->class } @$objs;
AceResultsTable(\@objects,$count,$offset,$title) if @objects;
}
acebrowser/conf/elegans.pm view on Meta::CPAN
# ========= Configuration information for the feedback script
@FEEDBACK_RECIPIENTS = (
[ ' Paul Sternberg <pws@its.caltech.edu>' => 'general complaints and suggestions'=>1 ],
[ ' Lincoln Stein <lstein@cshl.org>' => 'user interface' ],
[ ' Norma Foltz <norma@caltech.edu>' => 'cells and expression patterns' ],
[ ' Jonathan Hodgkin & Sylvia Martinelli <cgc@mrc-lmb.cam.ac.uk>' => 'genetic data; gene names'],
[ ' wormbase@caltech.edu ' => 'gene regulation and interactions' ],
[ ' Sylvia Martinelli <cgc@mrc-lmb.cam.ac.uk>' => 'addresses' ],
[ ' Theresa Stiernagle <stier@biosci.cbs.umn.edu>' => 'strains, bibliographic references' ],
[ ' Richard Durbin <rd@sanger.ac.uk>' =>'systematic genome sequence analysis, acedb problems' ],
[ ' Danielle & Jean Thierry-Mieg <mieg@ncbi.nlm.nih.gov>' => 'gene structures, ESTs and new largescale datasets' ],
[ ' John Spieth <jspieth@watson.wustl.edu>' => 'St. Louis sequence annotations; gene structures' ],
[ ' worm@sanger.ac.uk' => 'Cambridge sequence annotations; gene structures' ],
[ ' Alan Coulson <alan@sanger.ac.uk> ' => 'physical map' ],
);
@FEEDBACK_CHECKED = (0); # number zero is paul
# position of the chromosome tables, in URL space
$CHROMOSOME_TABLES = "$WB/chromosomes";
$CHROMOSOME_TABLE_LENGTH = 2_000_000;
acelib/Makefile view on Meta::CPAN
# suppress auto SCCS extraction
.SCCS_GET:
#################################################################
########## Machine dependent compiler modification ##############
############# Are included from an external file ################
#### This is equivalent to, but more portable than $($(CC)) #####
### Edit these rules to adapt the makefile to a new machine #####
# Note that you can keep different DEF files for the same machine
# setting various compiler options
#################################################################
include wmake/$(ACEDB_MACHINE)_DEF
FREE_OBJS = freesubs.o freeout.o messubs.o memsubs.o arraysub.o \
liste.o filsubs.o \
heap.o timesubs.o bump.o randsubs.o call.o menu.o dict.o \
helpsubs.o texthelp.o
###########################################################
## Compiler and library options
( run in 1.274 second using v1.01-cache-2.11-cpan-49f99fa48dc )