AcePerl
view release on metacpan or search on metacpan
# open a local database connection
$local = Ace->connect(-path=>'~acedb/my_ace');
# simple queries
$sequence = $db->fetch(Sequence => 'D12345');
$count = $db->count(Sequence => 'D*');
@sequences = $db->fetch(Sequence => 'D*');
$i = $db->fetch_many(Sequence=>'*'); # fetch a cursor
while ($obj = $i->next) {
print $obj->asTable;
}
# complex queries
$query = <<END;
find Annotation Ready_for_submission ; follow gene ;
follow derived_sequence ; >DNA
END
@ready_dnas= $db->fetch(-query=>$query);
$ready = $db->fetch_many(-query=>$query);
# do something with obj
}
# database cut and paste
$sequence = $db->fetch(Sequence => 'D12345');
$local_db->put($sequence);
@sequences = $db->fetch(Sequence => 'D*');
$local_db->put(@sequences);
# Get errors
print Ace->error;
print $db->error;
=head1 DESCRIPTION
AcePerl provides an interface to the ACEDB object-oriented database.
Both read and write access is provided, and ACE objects are returned
as similarly-structured Perl objects. Multiple databases can be
opened simultaneously.
You will interact with several Perl classes: I<Ace>, I<Ace::Object>,
I<Ace::Iterator>, I<Ace::Model>. I<Ace> is the database accessor, and
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.
-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.
Like B<fetch()>, B<fetch_many()> takes an optional B<-fill> (or
B<-filled>) argument which retrieves the entire object rather than
just its name. This is efficient on a network with high latency if
you expect to be touching many parts of the object (rather than
=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.
=head2 datetime() and date()
$datetime = Ace->datetime($time);
$today = Ace->datetime();
$date = Ace->date($time);
$today = Ace->date([$time]);
splice(@$list,$i,1); # remove from position
return 1;
}
sub datetime {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d %02d:%02d:%02d",$year,$mon+1,$day,$hour,$min,$sec);
}
sub date {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d",$year,$mon+1,$day);
}
Ace/Browser/AceSubs.pm view on Meta::CPAN
=head1 SYNOPSIS
use Ace;
use Ace::Browser::AceSubs;
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:
Ace/Browser/AceSubs.pm view on Meta::CPAN
Header Footer DB_Name AceMultipleChoices);
%EXPORT_TAGS = ( );
use constant DEFAULT_DATABASE => 'default';
use constant PRIVACY => 'misc/privacy'; # privacy/cookie statement
use constant SEARCH_BROWSE => 'search'; # a fallback search script
my %VALID; # cache for get_symbolic() lookups
=item AceError($message)
This subroutine will print out an error message and exit the script.
The text of the message is taken from $message.
=cut
sub AceError {
my $msg = shift;
PrintTop(undef,undef,'Error');
print CGI::font({-color=>'red'},$msg);
PrintBottom();
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item AceHeader()
This function prints the HTTP header and issues a number of cookies
used for maintaining AceBrowser state. It is not exported by default.
=cut
=item AceAddCookie(@cookies)
This subroutine, which must be called b<after> OpenDatabase() and/or
GetAceObject() and b<before> PrintTop(), will add one or more cookies
to the outgoing HTTP headers that are emitted by AceHeader().
Cookies must be CGI::Cookie objects.
Ace/Browser/AceSubs.pm view on Meta::CPAN
my $search_data = cookie(-name => $search_name,
-value => query_string(),
-path=>'/',
);
my $last_search = cookie(-name=>"ACEDB_$db",
-value=>$quovadis,
-path=>'/');
push(@COOKIES,$search_data,$last_search);
}
print @COOKIES ? header(-cookie=>\@COOKIES,@_) : header(@_);
@COOKIES = ();
$HEADER++;
}
=item AceInit()
This subroutine initializes the AcePerl connection to the configured
database. If the database cannot be opened, it generates an error
message and exits. This subroutine is not exported by default, but is
Ace/Browser/AceSubs.pm view on Meta::CPAN
$HEADER = 0;
$TOP = 0;
@COOKIES = ();
# keeps track of what sections should be open
%OPEN = param('open') ? map {$_ => 1} split(' ',param('open')) : () ;
return 1 if Configuration();
# if we get here, it is a big NOT FOUND error
print header(-status=>'404 Not Found',-type=>'text/html');
$HEADER++;
print start_html(-title => 'Database Not Found',
-style => Ace::Browser::SiteDefs->getConfig(DEFAULT_DATABASE)->Style,
),
h1('Database not found'),
p('The requested database',i(get_symbolic()),'is not recognized',
'by this server.');
print p('Please return to the',a({-href=>referer()},'referring page.')) if referer();
print end_html;
Apache::exit(0) if defined &Apache::exit; # bug out of here!
exit(0);
}
=item AceMissing([$class,$name])
This subroutine will print out an error message indicating that an
object is present in AceDB, but that the information the user
requested is absent. It will then exit the script. This is
infrequently encountered when following XREFed objects. If the class
and name of the object are not provided as arguments, they are taken
from CGI's param() function.
=cut
sub AceMissing {
my ($class,$name) = @_;
$class ||= param('class');
$name ||= param('name');
PrintTop(undef,undef,$name);
print strong('There is no further information about this object in the database.');
PrintBottom();
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item AceMultipleChoices($symbol,$report,$objects)
This function is called when a search has recovered multiple objects
and the user must make a choice among them. The user is presented
with an ordered list of the objects, and asked to click on one of
Ace/Browser/AceSubs.pm view on Meta::CPAN
This subroutine is not exported by default.
=cut
sub AceMultipleChoices {
my ($symbol,$report,$objects) = @_;
if ($objects && @$objects == 1) {
my $destination = Object2URL($objects->[0]);
AceHeader(-Refresh => "1; URL=$destination");
print start_html (
'-Title' => 'Redirect',
'-Style' => Style(),
),
h1('Redirect'),
p("Automatically transforming this query into a request for corresponding object",
ObjectLink($objects->[0],$objects->[0]->class.':'.$objects->[0])),
p("Please wait..."),
Footer(),
end_html();
return;
}
PrintTop(undef,undef,'Multiple Choices');
print
p("Multiple $report objects correspond to $symbol.",
"Please choose one:"),
ol(
li([
map {ObjectLink($_,font({-color=>'red'},$_->class).': '.$_)} @$objects
])
);
PrintBottom();
}
=item AceNotFound([$class,$name])
This subroutine will print out an error message indicating that the
requested object is not present in AceDB, even as a name. It will then
exit the script. If the class and name of the object are not provided
as arguments, they are taken from CGI's param() function.
=cut
sub AceNotFound {
my $class = shift || param('class');
my $name = shift || param('name');
PrintTop(undef,undef,"$class: $name not found");
print p(font({-color => 'red'},
strong("The $class named \"$name\" is not found in the database.")));
PrintBottom();
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item ($uri,$physical_path) = AcePicRoot($directory)
This function returns the physical and URL paths of a temporary
directory in which the pic script can write pictures. Not exported by
Ace/Browser/AceSubs.pm view on Meta::CPAN
############### redirect to a different report #####################
sub AceRedirect {
my ($report,$object) = @_;
my $url = Configuration()->display($report,'url');
my $args = ref($object) ? "name=$object&class=".$object->class
: "name=$object";
my $destination = ResolveUrl($url => $args);
AceHeader(-Refresh => "1; URL=$destination");
print start_html (
'-Title' => 'Redirect',
'-Style' => Style(),
'-head' => meta({-http_equiv=>'Refresh',-content=>"1; URL=$destination"})
),
h1('Redirect'),
p("This request is being redirected to the \U$report\E display"),
p("This page will automatically display the requested object in",
"one seconds",a({-href=>$destination},'Click on this link'),
'to load the page immediately.'),
end_html();
Ace/Browser/AceSubs.pm view on Meta::CPAN
differs from AceRedirect() in that it generates a fast redirect
without alerting the user.
This function is not exported by default.
=cut
# redirect to the URL responsible for an object
sub DoRedirect {
my $obj = shift;
print redirect(Object2URL($obj));
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
=item $footer = Footer()
This function returns the contents of the footer as a string, but does
not print it out. It is not exported by default.
=cut
# Contents of the HTML footer. It gets printed immediately before the </BODY> tag.
# The one given here generates a link to the "feedback" page, as well as to the
# privacy statement. You may or may not want these features.
sub Footer {
if (my $footer = Configuration()->Footer) {
return $footer;
}
my $webmaster = $ENV{SERVER_ADMIN} || 'webmaster@sanger.ac.uk';
my $obj_name = escape(param('name'));
my $obj_class = escape(param('class')) || ucfirst url(-relative=>1);
Ace/Browser/AceSubs.pm view on Meta::CPAN
AceMultipleChoices($name,'',\@objs);
Apache->exit(0) if defined &Apache::exit;
exit(0);
}
return $objs[0];
}
=item $html = Header()
This subroutine returns the boilerplate at the top of the HTML page as
a string, but does not print it out. It is not exported by default.
=cut
sub Header {
my $config = Configuration();
my $dbname = get_symbolic();
return unless my $searches = $config->Searches;
my $banner = $config->Banner;
Ace/Browser/AceSubs.pm view on Meta::CPAN
first argument is an Ace::Object. The second, optional argument is
the text to use for the link. If not provided, the object's name
becomes the link text.
This function is used extensively to create cross references between
Ace::Objects on AceBrowser pages.
Example:
my $author = $db->fetch(Author => 'Sulston JE');
print ObjectLink($author,$author->Full_name);
This will print out a link to a page that will display details on the
author page. The text of the link will be the value of the Full_name
tag.
=cut
sub ObjectLink {
my $object = shift;
my $link_text = shift;
my $target = shift;
my $url = Object2URL($object,@_) or return ($link_text || "$object");
Ace/Browser/AceSubs.pm view on Meta::CPAN
# boilerplate for the top of the page
sub PrintTop {
my ($object,$class,$title,@additional_header_stuff) = @_;
return if $TOP++;
$class = $object->class if defined $object && ref($object);
$class ||= param('class') unless defined($title);
AceHeader();
$title ||= defined($object) ? "$class Report for: $object" : $class ? "$class Report" : ''
unless defined($title);
print start_html (
'-Title' => $title,
'-Style' => Style(),
@additional_header_stuff,
);
print Header();
print TypeSelector($object,$class) if defined $object;
print h1($title) if $title;
}
=item PrintBottom()
The PrintBottom() function outputs all the boilerplate at the bottom
of a typical AceBrowser page. If a user-defined footer is present in
the configuration file, that is printed. Otherwise, the method prints
a horizontal rule followed by links to the site home page, the AcePerl
home page, the privacy policy, and the feedback page.
=cut
sub PrintBottom {
print hr,Footer(),end_html();
}
=item $hashref = Style()
This subroutine returns a hashref containing a reference to the
configured stylesheet, in the following format:
{ -src => '/ace/stylesheets/current_stylesheet.css' }
Ace/Browser/AceSubs.pm view on Meta::CPAN
$label The text of the generated link, for example "sequence"
$object_count The number of objects that opening the section will reveal
$add_plural If true, the label will be pluralized when
appropriate
$add_count If true, the label will have the object count added
when appropriate
In a scalar context, Toggle() prints the link HTML and returns a
boolean flag. A true result indicates that the section is expanded
and should be generated. A false result indicates that the section is
collapsed.
In a list context, Toggle() returns a two-element list. The first
element is the HTML link that expands and contracts the section. The
second element is a boolean that indicates whether the section is
currently open or closed.
This example indicates typical usage:
my $sequence = GetAceObject();
print "sequence name = ",$sequence,"\n";
print "sequence clone = ",$sequence->Clone,"\n";
if (Toggle('dna','Sequence DNA')) {
print $sequence->asDNA;
}
An alternative way to do the same thing:
my $sequence = GetAceObject();
print "sequence name = ",$sequence,"\n";
print "sequence clone = ",$sequence->Clone,"\n";
my ($link,$open) = Toggle('dna','Sequence DNA');
print $link;
print $sequence->asDNA if $open;
=cut
# Toggle a subsection open and close
sub Toggle {
my ($section,$label,$count,$addplural,$addcount,$max_open) = @_;
$OPEN{$section}++ if defined($max_open) && $count <= $max_open;
my %open = %OPEN;
$label ||= $section;
Ace/Browser/AceSubs.pm view on Meta::CPAN
my $plural = ($addplural and $label !~ /s$/) ? "${label}s" : "$label";
$label = font({-class=>'toggle'},!$addcount ? $plural : "$count $plural");
}
param(-name=>'open',-value=>join(' ',keys %open));
my $url = url(-absolute=>1,-path_info=>1,-query=>1);
my $link = a({-href=>"$url#$section",-name=>$section},$img.' '.$label);
if (wantarray ){
return ($link,$OPEN{$section})
} else {
print $link,br;
return $OPEN{$section};
}
}
=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.
Ace/Browser/AceSubs.pm view on Meta::CPAN
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:
my $url = Url('../sequence_dump',"name=$name;long_dump=yes");
print a({-href=>$url},'Dump this sequence');
=cut
sub Url {
my ($display,$parameters) = @_;
my $url = Configuration()->display($display,'url');
return ResolveUrl($url,$parameters);
}
sub Open_table{
print '<table width=660>
<tr>
<td>';
}
sub Close_table{
print '</tr>
</td>
</table>';
}
# return host and port for symbolic database name
sub getDatabasePorts {
my $name = shift;
my $config = Ace::Browser::SiteDefs->getConfig($name);
return ($config->Host,$config->Port,
Ace/Browser/SearchSubs.pm view on Meta::CPAN
sub AceSearchOffset {
my $offset = param('offset') || 0;
$offset += param('scroll') if param('scroll');
$offset;
}
=item AceSearchTable([{hash}],$title,@contents)
Given a title and the HTML contents, this formats the search into a
table and gives it the background and foreground colors used elsewhere
for searches. The formatted search is then printed.
The HTML contents are usually a fill-out form. For convenience, you
can provide the contents in multiple parts (lines or elements) and
they will be concatenated together.
If the first argument is a hashref, then its contents will be passed
to start_form() to override the form arguments.
=cut
sub AceSearchTable {
my %attributes = %{shift()} if ref($_[0]) eq 'HASH';
my ($title,@body) = @_;
print
start_form(-action=>url(-absolute=>1,-path_info=>1).'#results',%attributes),
a({-name=>'search'},''),
table({-border=>0,-width=>'100%'},
TR({-valign=>'MIDDLE'},
td({-class=>'searchbody'},@body))),
end_form;
}
=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.
Ace/Browser/SearchSubs.pm view on Meta::CPAN
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;
Ace/Graphics/Panel.pm view on Meta::CPAN
$panel->add_track(transcript => \@transcripts,
-fillcolor => 'wheat',
-fgcolor => 'black',
-key => 'Curated Genes',
-bump => +1,
-height => 10,
-label => 1);
my $boxes = $panel->boxes;
print $panel->png;
=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.
Ace/Graphics/Panel.pm view on Meta::CPAN
-pad_bottom Additional whitespace between top 0
of image and bottom, in pixels
-pad_left Additional whitespace between left 0
of image and contents, in pixels
-pad_right Additional whitespace between right 0
of image and bottom, in pixels
-keycolor Background color for the key printed 'cornsilk'
at bottom of panel (if any)
-keyspacing Spacing between key glyphs in the 10
key printed at bottom of panel
(if any)
Typically you will pass new() an object that implements the
Bio::RangeI interface, providing a length() method, from which the
panel will derive its scale.
$panel = Ace::Graphics::Panel->new(-segment => $sequence,
-width => 800);
new() will return undef in case of an error. If the specified glyph
Ace/Graphics/Panel.pm view on Meta::CPAN
as "cyan" and as HTML-style #RRGGBB triples. The symbolic names are
the 140 colors defined in the Netscape/Internet Explorer color cube,
and can be retrieved using the Ace::Graphics::Panel->color_names()
method.
The background color is used for the background color of the track
itself. The foreground color controls the color of lines and strings.
The interior color is used for filled objects such as boxes.
The -label argument controls whether or not the ID of the feature
should be printed next to the feature. It is accepted by most, but
not all of the glyphs.
The -bump argument controls what happens when glyphs collide. By
default, they will simply overlap (value 0). A -bump value of +1 will
cause overlapping glyphs to bump downwards until there is room for
them. A -bump value of -1 will cause overlapping glyphs to bump
upwards.
The -key argument declares that the track is to be shown in a key
appended to the bottom of the image. The key contains a picture of a
Ace/Graphics/Track.pm view on Meta::CPAN
-fillcolor => 'wheat',
-fgcolor => 'black',
-bump => +1,
-height => 10,
-label => 1);
foreach (@transcripts) {
$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
Ace/Iterator.pm view on Meta::CPAN
Ace::Iterator - Iterate Across an ACEDB Query
=head1 SYNOPSIS
use Ace;
$db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr',
-port => 20000100);
$i = $db->fetch_many(Sequence=>'*'); # fetch a cursor
while ($obj = $i->next) {
print $obj->asTable;
}
=head1 DESCRIPTION
The Ace::Iterator class implements a persistent query on an Ace
database. You can create multiple simultaneous queries and retrieve
objects from each one independently of the others. This is useful
when a query is expected to return more objects than can easily fit
into memory. The iterator is essentially a database "cursor."
Ace/Local.pm view on Meta::CPAN
my $query = shift;
warn "query($query)\n" if $self->debug;
if ($self->debug) {
my $msg = $query || '';
warn "\tquery($msg)";
}
return undef if $self->{'status'} == STATUS_ERROR;
do $self->read() until $self->{'status'} != STATUS_PENDING;
my $wtr = $self->{'write'};
print $wtr "$query\n";
$self->{'status'} = STATUS_PENDING;
}
sub low_read { # hack to accomodate "uninitialized database" warning from tace
my $self = shift;
my $rdr = $self->{'read'};
return undef unless $self->{'status'} == STATUS_PENDING;
my $rin = '';
my $data = '';
vec($rin,fileno($rdr),1)=1;
Ace/Local.pm view on Meta::CPAN
Ace::Local - use giface, tace or gifaceclient to open a local connection to an Ace database
=head1 SYNOPSIS
use Ace::Local
my $ace = Ace::Local->connect(-path=>'/usr/local/acedb/elegans');
$ace->query('find author Se*');
die "Query unsuccessful" unless $ace->status;
$ace->query('show');
while ($ace->encore) {
print $ace->read;
}
=head1 DESCRIPTION
This class is provided for low-level access to local (non-networked)
Ace databases via the I<giface> program. You will generally not need
to access it directly. Use Ace.pm instead.
For the sake of completeness, the method can also use the I<aceclient>
program for its access. However the Ace::AceDB class is more efficient
Ace/Model.pm view on Meta::CPAN
=head1 NAME
Ace::Model - Get information about AceDB models
=head1 SYNOPSIS
use Ace;
my $db = Ace->connect(-path=>'/usr/local/acedb/elegans');
my $model = $db->model('Author');
print $model;
$name = $model->name;
@tags = $model->tags;
print "Paper is a valid tag" if $model->valid_tag('Paper');
=head1 DESCRIPTION
This class is provided for access to AceDB class models. It provides
the model in human-readable form, and does some limited but useful
parsing on your behalf.
Ace::Model objects are obtained either by calling an Ace database
handle's model() method to retrieve the model of a named class, or by
calling an Ace::Object's model() method to retrieve the object's
Ace/Model.pm view on Meta::CPAN
=head2 path()
@path = $model->path($tag)
Returns the path to the indicated tag, returning a list of intermediate tags.
For example, in the C elegans ?Locus model, the path for 'Compelementation_data"
will return the list ('Type','Gene').
=head2 asString()
print $model->asString;
asString() returns the human-readable representation of the model with
comments stripped out. Internally this method is called to
automatically convert the model into a string when appropriate. You
need only to start performing string operations on the model object in
order to convert it into a string automatically:
print "Paper is unique" if $model=~/Paper ?Paper UNIQUE/;
=head1 SEE ALSO
L<Ace>
=head1 AUTHOR
Lincoln Stein <lstein@w3.org> with extensive help from Jean
Thierry-Mieg <mieg@kaa.crbm.cnrs-mop.fr>
Ace/Object.pm view on Meta::CPAN
# 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';
# Pseudonyms and deprecated methods.
*isClass = \&isObject;
*pick = \&fetch;
*get = \&search;
*add = \&add_row;
sub AUTOLOAD {
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
Ace/Object.pm view on Meta::CPAN
@col = $sequence->at("Visible.$more_tags[1]")->col;
# Follow a pointer into database
$r = $sequence->at('Visible.Overlap_Right')->fetch;
$next = $r->at('Visible.Overlap_left')->fetch;
# Classy way to do the same thing
$r = $sequence->Overlap_right;
$next = $sequence->Overlap_left;
# Pretty-print object
print $sequence->asString;
print $sequence->asTabs;
print $sequence->asHTML;
# Update object
$sequence->replace('Visible.Overlap_Right',$r,'M55555');
$sequence->add('Visible.Homology','GR91198');
$sequence->delete('Source.Clone','MBR122');
$sequence->commit();
# Rollback changes
$sequence->rollback()
# Get errors
print $sequence->error;
=head1 DESCRIPTION
I<Ace::Object> is the base class for objects returned from ACEDB
databases. Currently there is only one type of I<Ace::Object>, but
this may change in the future to support more interesting
object-specific behaviors.
Using the I<Ace::Object> interface, you can explore the internal
structure of an I<Ace::Object>, retrieve its content, and convert it
Ace/Object.pm view on Meta::CPAN
=head2 name() method
$name = $object->name();
Return the name of the Ace::Object. This happens automatically
whenever you use the object in a context that requires a string or a
number. For example:
$object = $db->fetch(Author,"Thierry-Mieg J");
print "$object did not write 'Pride and Prejudice.'\n";
=head2 class() method
$class = $object->class();
Return the class of the object. The return value may be one of
"float," "int," "date," "tag," "txt," "dna," "peptide," and "scalar."
(The last is used internally by Perl to represent objects created
programatically prior to committing them to the database.) The class
may also be a user-constructed type such as Sequence, Clone or
Ace/Object.pm view on Meta::CPAN
The scalar context semantics are also slightly different. In a scalar
context, the autogenerated function will *always* move one step to the
right.
The list context semantics are identical to get(). If you want to
dereference all members of a multivalued tag, you have to do so manually:
@papers = $author->Paper;
foreach (@papers) {
my $paper = $_->fetch;
print $paper->asString;
}
You can provide an optional positional index to rapidly navigate
through the tree or to obtain tag[2] behavior. In the following
examples, the first two return the object's Fax number, and the third
returns all data two hops to the right of Address.
$object = $db->fetch(Author => 'Thierry-Mieg J');
($fax_no) = $object->Fax;
$fax_no = $object->Fax(1);
Ace/Object.pm view on Meta::CPAN
=head2 fetch() method
$new_object = $object->fetch;
$new_object = $object->fetch($tag);
Follow object into the database, returning a new object. This is
the best way to follow object references. For example:
$laboratory = $object->at('Laboratory')->fetch;
print $laboratory->asString;
Because the previous example is a frequent idiom, the optional $tag
argument allows you to combine the two operations into a single one:
$laboratory = $object->fetch('Laboratory');
=head2 follow() method
@papers = $object->follow('Paper');
@filled_papers = $object->follow(-tag=>'Paper',-filled=>1);
Ace/Object.pm view on Meta::CPAN
('Mail','CRBM duCNRS'):
@row = $object->Address->row(1);
In a scalar context, B<row()> returns the number of items in the row.
=head2 asString() method
$object->asString;
asString() returns a pretty-printed ASCII representation of the object
tree.
=head2 asTable() method
$object->asTable;
asTable() returns the object as a tab-delimited text table.
=head2 asAce() method
Ace/Object.pm view on Meta::CPAN
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;
This method will return true if the object is a "top level" object,
that is the root of an object tree rather than a subtree.
=head2 model() method
$model = $object->model;
This method will return the object's model as an Ace::Model object, or
undef if the object does not have a model. See L<Ace::Model> for
Ace/Object.pm view on Meta::CPAN
=head2 timestamp() method
$stamp = $object->timestamp;
The B<timestamp()> method will retrieve the modification time and date
from the object. This works both with top level objects and with
subtrees. Timestamp handling must be turned on in the database, or
B<timestamp()> will return undef.
The returned timestamp is actually a UserSession object which can be
printed and explored like any other object. However, there is
currently no useful information in UserSession other than its name.
=head2 comment() method
$comment = $object->comment;
This returns the comment attached to an object or object subtree, if
any. Comments are I<Comment> objects and have the interesting
property that a single comment can refer to multiple objects. If
there is no comment attached to the current subtree, this method will
Ace/Object.pm view on Meta::CPAN
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
# AUTOLOADED METHODS GO HERE
### Return the pretty-printed HTML table representation ###
### may pass a code reference to add additional formatting to cells ###
sub asHTML {
my $self = shift;
my ($modify_code) = rearrange(['MODIFY'],@_);
return unless defined($self->right);
my $string = "<TABLE BORDER>\n<TR ALIGN=LEFT VALIGN=TOP><TH>$self</TH>";
$modify_code = \&_default_makeHTML unless $modify_code;
$self->right->_asHTML(\$string,1,2,$modify_code);
$string .= "</TR>\n</TABLE>\n";
return $string;
Ace/Object.pm view on Meta::CPAN
}
#### In "ace" format ####
sub asAce {
my $self = shift;
my $string = $self->isRoot ? join(' ',$self->class,':',$self->escape) . "\n" : '';
$self->right->_asAce(\$string,0,[]);
return "$string\n\n";
}
### Pretty-printed version ###
sub asString {
my $self = shift;
my $MAXWIDTH = shift || $DEFAULT_WIDTH;
my $tabs = $self->asTable;
return "$self" unless $tabs;
my(@lines) = split("\n",$tabs);
my($result,@max);
foreach (@lines) {
my(@fields) = split("\t");
for (my $i=0;$i<@fields;$i++) {
Ace/Object.pm view on Meta::CPAN
my $class = $self->class;
my ($tagname,$attributes,$content) = ('','',''); # prevent uninitialized variable warnings
my $tab = " " x ($level-$position); # four spaces
$current_tag ||= $class;
$content = $name if $opts->{content};
if ($self->isTag) {
$current_tag = $tagname = $name;
$tag_level = 0;
} else {
$tagname = $tag_level > 0 ? sprintf "%s-%d",$current_tag,$tag_level + 1 : $current_tag;
$class = "#$class" unless $self->isObject;
$attributes .= qq( class="$class") if $opts->{class};
$attributes .= qq( value="$name") if $opts->{value};
}
if (my $c = $self->comment) {
$c = $self->escapeXML($c);
$attributes .= qq( comment="$c");
}
Ace/Sequence.pm view on Meta::CPAN
# Wrap it in an Ace::Sequence object
$seq = Ace::Sequence->new($obj);
# Find all the exons
@exons = $seq->features('exon');
# 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');
Ace/Sequence/Feature.pm view on Meta::CPAN
$feature = $homol[0];
$type = $feature->type;
$subtype = $feature->subtype;
$start = $feature->start;
$end = $feature->end;
$score = $feature->score;
# Follow the target
$target = $feature->info;
# print the target's start and end positions
print $target->start,'-',$target->end, "\n";
=head1 DESCRIPTION
I<Ace::Sequence::Feature> is a subclass of L<Ace::Sequence::Feature>
specialized for returning information about particular features in a
GFF format feature table.
=head1 OBJECT CREATION
You will not ordinarily create an I<Ace::Sequence::Feature> object
Ace/Sequence/FeatureList.pm view on Meta::CPAN
return $self->{$type}{$subtype};
}
# human-readable summary table
sub asString {
my $self = shift;
my ($type,$subtype);
for my $type ( sort $self->types() ) {
for my $subtype (sort $self->types($type) ) {
print join("\t",$type,$subtype,$self->{$type}{$subtype}),"\n";
}
}
}
1;
=head1 NAME
Ace::Sequence::FeatureList - Lightweight Access to Features
Ace/Sequence/FeatureList.pm view on Meta::CPAN
$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;
# Scalar context, 1 argument. Count this type
$gene_cnt = $list->types('Predicted_gene');
print "There are $gene_cnt genes here.\n";
# Array context, 1 argument. Get list of subtypes
@subtypes = $list->types('Predicted_gene');
# Two arguments. Count type & subtype
$genefinder_cnt = $list->types('Predicted_gene','genefinder');
=head1 DESCRIPTION
I<Ace::Sequence::FeatureList> is a small class that provides
Ace/Sequence/FeatureList.pm view on Meta::CPAN
For example, this code fragment will count the number of exons present
on the list:
$exon_count = $list->type('exon');
This code fragment will count the number of exons found by "genefinder":
$predicted_exon_count = $list->type('exon','genefinder');
This code fragment will print out all subtypes of "exon" and their
counts:
for my $subtype ($list->type('exon')) {
print $subtype,"\t",$list->type('exon',$subtype),"\n";
}
=item asString()
print $list->asString;
This dumps the list out in tab-delimited format. The order of columns
is type, subtype, count.
=back
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,
L<Ace::Sequence::Feature>, L<GFF>
Ace/Sequence/Homol.pm view on Meta::CPAN
# sort by score
@sorted = sort { $a->score <=> $b->score } @homol;
# the last one has the highest score
$best = $sorted[$#sorted];
# fetch its associated Ace::Sequence::Homol
$homol = $best->target;
# print out the sequence name, DNA, start and end
print $homol->name,' ',$homol->start,'-',$homol->end,"\n";
print $homol->asDNA;
=head1 DESCRIPTION
I<Ace::Sequence::Homol> is a subclass of L<Ace::Object> (B<not>
L<Ace::Sequence>) which is specialized for returning information about
a DNA or protein homology. This is a temporary placeholder for a more
sophisticated homology class which will include support for
alignments.
=head1 OBJECT CREATION
Ace/Sequence/Multi.pm view on Meta::CPAN
$feature = $homol[0];
$type = $feature->type;
$subtype = $feature->subtype;
$start = $feature->start;
$end = $feature->end;
$score = $feature->score;
# Follow the target
$target = $feature->info;
# print the target's start and end positions
print $target->start,'-',$target->end, "\n";
=head1 DESCRIPTION
I<Ace::Sequence::Multi> transparently combines information stored
about a sequence in a reference database with features tables from any
number of annotation databases. The resulting object can be used just
like an Ace::Sequence object, except that the features remember their
database of origin and go back to that database for information.
This class will only work properly if the reference database and all
Ace/SocketServer.pm view on Meta::CPAN
return unless my $sock = $self->{socket};
local $SIG{'PIPE'} = 'IGNORE';
$msg .= "\0"; # add terminating null
my $request;
if ($parse) {
$request = ACESERV_MSGDATA;
} else {
$request = $msg eq "encore\0" ? ACESERV_MSGENCORE : ACESERV_MSGREQ;
}
my $header = pack HEADER,WORDORDER_MAGIC,length($msg),0,$self->{client_id},0,$request;
print $sock $header,$msg;
}
sub _recv_msg {
my $self = shift;
my $strip_null = shift;
return unless my $sock = $self->{socket};
my ($header,$body);
my $bytes = CORE::read($sock,$header,HEADER_LEN);
unless ($bytes > 0) {
$self->{status} = STATUS_ERROR;
Makefile.PL view on Meta::CPAN
die "invalid choice: $choice!" if $choice < 1 || $choice > 3;
}
}
$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' => '',
Makefile.PL view on Meta::CPAN
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);
get_path("acebrowser HTML files and images",\$html_path);
open F,">Ace/Browser/LocalSiteDefs.pm" or die "Ace/Browser/LocalSiteDefs.pm: $!";
print F <<END;
# Globals for Ace::Browser::SiteDefs
# these get loaded into whatever package requires them (old style)
package Ace::Browser::LocalSiteDefs;
require Exporter;
\@ISA = qw(Exporter);
\@EXPORT = qw();
\@EXPORT_OK = qw(\$SITE_DEFS \$CGI_PATH \$HTML_PATH);
\$SITE_DEFS = '$conf_path';
\$CGI_PATH = '$cgi_path';
Makefile.PL view on Meta::CPAN
'
install-browser :
util/install.pl acebrowser/htdocs $html_path
util/install.pl acebrowser/cgi-bin $cgi_path
util/install.pl acebrowser/conf $conf_path
mkdir $html_path/images
chmod go+rwx $html_path/images
';
}
END
print qq(\n*** After "make install", run "make install-browser" to install acebrowser files. ***\n\n);
}
sub get_path {
my ($description,$pathref) = @_;
$$pathref = expand_twiddles(prompt("Directory for the $description (~username ok):",$$pathref));
return if -d $$pathref;
return if prompt("$$pathref does not exist. Shall I create it for you?",'y') !~ /[yY]/;
mkpath($$pathref) or warn "Couldn't create $$pathref. Please create it before installing.\n";
}
README.ACEBROWSER view on Meta::CPAN
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
"site_perl" subdirectory of the Perl library directory (use "perl -V"
to see where that is). You can find out where Acebrowser expects to
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:
README.ACEBROWSER view on Meta::CPAN
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.
@HOME = (
$DOCROOT => 'Home Page'
);
acebrowser/cgi-bin/generic/acetable view on Meta::CPAN
display_table($NAME," ");
exit 0;
sub display_table {
my ($name,$parms) = @_;
my $obj = $DB->raw_query("table -title -n $name $parms") || AceMissing($name,$parms);
my ($n,$c) = (escape($name),escape($parms));
print
start_html(-Title=>"$name: $parms",
-Style=>STYLE,
-Class=>'tree',
-Bgcolor=>BGCOLOR_TREE),
h1("$name: $parms"),
&show_table($obj),
#$obj->asHTML() || strong('No more text information about this object in the database'),
FOOTER,
end_html;
}
acebrowser/cgi-bin/generic/model view on Meta::CPAN
my $db = OpenDatabase;
my $class = $object->class;
my ($model) = $db->fetch(Model=>"?$class");
unless ($model) {
AceError("No model of type ?$class found");
PrintBottom();
exit 0;
}
print_tree($model);
PrintBottom();
exit 0;
sub print_tree {
my $obj = shift;
print $obj->asHTML(\&to_href)
|| strong('No more text information about this object in the database'),"\n";
}
# this is cut-and-paste out of etree, but with simplifications
sub to_href {
my $obj = shift;
unless ($obj->isObject or $obj->isTag) {
$obj =~s/\\n/<BR>/g;
return ($obj,0);
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
}
END
;
PrintTop($obj,undef,$obj ? "Graphic display of: $obj" : "Graphic display",
'-Bgcolor' => '#FFFFFF', # important to have a white bg for the gifs
'-Style' => $style,
-Script => JSCRIPT
);
print_prompt();
AceNotFound() unless $obj;
display_object($obj,$click);
PrintBottom();
sub print_prompt {
print
start_form(-name=>'question'),
table(
TR (th('Name'),td(textfield(-name=>'name')),
th('Class'),td(textfield(-name=>'class',-size=>15,-onChange=>'document.question.submit()')),
td(submit({-style=>'background: white',-name=>'Change'}))),
),
end_form;
}
sub display_object {
my ($obj,$click) = @_;
my $class = param('class');
my $name = $obj->name;
if (DISABLED) {
print h1({-class=>'error'},'Sorry, but graphical displays have been disabled temporarily.');
return;
}
# special case for sequences
if (lc($class) eq 'sequence' && $name =~ /SUPERLINK|CHROMOSOME/) {
print h1('This sequence is too large to display. Try a shorter segment.');
return;
}
build_map_navigation_panel($obj,$name,$class) if $class =~ /Map/i;
my $map_start = param('map_start');
my $map_stop = param('map_stop');
my $has_coords = defined $map_start && defined $map_stop;
my $safe_name = $name;
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
push(@param,(-dimensions=>[WIDTH,HEIGHT]));
push(@param,(-coords=>[param('map_start'),param('map_stop')])) if $has_coords;
}
my ($gif,$boxes) = $obj ? $obj->asGif(@param) : ();
unless (-e $image_file && -M $image_file < 0) {
local(*F);
open (F,">$image_file") || AceError("Can't open image file $image_file for writing: $!\n");
print F $gif || unpack("u",ERROR_GIF);
close F;
}
my $u = Url('pic') . "?" . query_string();
$u .= param('click') ? ',' : '&click=';
print
img({-src => $image_path,
-name => 'theMapImg',
-border=> 0,
# this is for Internet Explorer, has no effect on Netscape!
-onClick=>"send_click(event,'$u')",
-usemap=>'#theMap',
-isMap=>undef}),
;
print_map($name,$class,$boxes);
}
sub print_map {
my ($name,$class,$boxes) = @_;
my @lines;
my $old_clicks = param('click');
Delete('click');
# Collect some statistics in order to inhibit those features
# that are too dense to click on sensibly.
my %centers;
foreach my $box (@$boxes) {
my $center = center($box->{'coordinates'});
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
# Create default handling. Bad use of javascript, but can't think of any other way.
my $url = Url('pic', query_string());
my $simple_url = $url;
$url .= "&click=$old_clicks";
$url .= "," if $old_clicks;
push(@lines,qq(<AREA shape="default"
alt=""
onClick="send_click(event,'$url'); return false"
onMouseOver="return s(this,'clickable region')"
href="$simple_url">)) if $modern;
print qq(<map name="theMap">),join("\n",@lines),qq(</map>),"\n";
}
# special case for maps
# this builds the whole map control/navigation panel
sub build_map_navigation_panel {
my $obj = shift;
my ($name,$class) = @_;
my $map_start = param ('map_start');
my $map_stop = param ('map_stop');
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
my $a2 = $map_stop - ($map_start - $a1);
my $b2 = $map_stop + $half;
$b2 = $max if $b2 > $max;
my $b1 = $b2 - ($map_stop - $map_start);
my $m1 = $map_start + $half/2;
my $m2 = $map_stop - $half/2;
print start_table({-border=>1});
print TR(td({-align=>'CENTER',-class=>'datatitle',-colspan=>2},'Map Control'));
print start_TR();
print td(
table({-border=>0},
TR(td(' '),
td(
$map_start > $min ?
a({-href=>"$self?name=$name;class=$class;map_start=$a1;map_stop=$a2"},
img({-src=>UP_ICON,-align=>'MIDDLE',-border=>0}),' Up')
:
font({-color=>'#A0A0A0'},img({-src=>UP_ICON,-align=>'MIDDLE',-border=>0}),' Up')
),
td(' ')
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
$map_stop < $max ?
a({-href=>"$self?name=$name;class=$class;map_start=$b1;map_stop=$b2"},
img({-src=>DOWN_ICON,-align=>'MIDDLE',-border=>0}),' Down')
:
font({-color=>'#A0A0A0'},img({-src=>DOWN_ICON,-align=>'MIDDLE',-border=>0}),' Down')
),
td(' '))
)
);
print start_td({-rowspan=>2});
print start_form;
print start_p;
print hidden($_) foreach qw(class name);
print 'Show region between: ',
textfield(-name=>'map_start',-value=>sprintf("%.2f",$map_start),-size=>8,-override=>1),
' and ',
textfield(-name=>'map_stop',- value=>sprintf("%.2f",$map_stop),-size=>8,-override=>1),
' ';
print submit('Change');
print end_p;
print end_form;
print end_td(),end_TR(),end_table();
}
sub get_extremes {
my $db = shift;
my $chrom = shift;
my $select = qq(select gm[Position] from g in object("Map","$chrom")->Contains[2], gm in g->Map where gm = "$chrom");
my @positions = $db->aql("select min($select),max($select)");
my ($min,$max) = @{$positions[0]}[0,1];
return ($min,$max);
}
acebrowser/cgi-bin/generic/tree view on Meta::CPAN
unless ($obj) {
AceError(<<END) if param() && !param('name') && !param('class')
Call this script with URL parameters of
<VAR>name</VAR> and <VAR>class,</VAR> where
"name" and "class" correspond to the name and class of the
Ace object of interest.
END
}
PrintTop($obj);
print_prompt();
AceNotFound() unless $obj;
display_object($obj);
PrintBottom();
sub print_prompt {
print
start_form(-name=>'question'),
table(
TR (th('Name'),td(textfield(-name=>'name')),
th('Class'),td(textfield(-name=>'class',-size=>15,-onChange=>'document.question.submit()')),
td(submit({-style=>'background: white',-name=>'Change'}))),
),
end_form;
}
sub display_object {
my $obj = shift;
my $name = $obj->name;
my $class = $obj->class;
my ($n,$c) = (escape($name),escape($class));
my $myimage = ($class =~ /^Picture/ ? $obj->Pick_me_to_call->right->right : 'No_Image') ;
if ($class eq 'LongText'){
print $obj->asHTML(sub { pre(shift) });
}
else{
print $obj->asHTML(\&to_href) || strong('No more text information
about this object in the database'), "\n";
}
}
sub to_href {
my $obj = shift;
unless ($obj->isObject or $obj->isTag) {
if ($obj=~/\S{50}/){ # if you have >50 chars without a space
$obj=~s/(\S{50})/$1\n/g; # add some
acebrowser/cgi-bin/generic/xml view on Meta::CPAN
AceError(<<END) unless param('name') && param('class');
Call this script with URL parameters of
<VAR>name</VAR> and <VAR>class,</VAR> where
"name" and "class" correspond to the name and class of the
Ace object of interest.
END
my $obj = GetAceObject() || AceNotFound();
print header('text/plain');
print qq(<?xml version="1.0" standalone="yes"?>\n\n);
print $obj->asXML;
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
# class - class of object to update
# from - sender's e-mail address
# subject - subject of mail message
# remark - body of e-mail message
my $object_name = param('name');
my $object_class = param('class');
my $where_from = param('referer') || referer();
if (param('return') && $where_from !~ /\/feedback/ ) {
print redirect($where_from);
exit 0;
}
PrintTop(undef,undef,'Feedback Page');
if (Configuration->Feedback_recipients) {
@FEEDBACK_RECIPIENTS = @{Configuration->Feedback_recipients};
if (param('submit') && send_mail($object_name,$object_class,$where_from)) {
print_confirmation();
} else {
print start_form;
print_instructions();
print_form( $object_name,$object_class,DB_Name(),$where_from );
print end_form;
}
} else {
print p("No recipients for feedback are defined.");
print start_form(),
hidden(-name=>'referer',-value=>$where_from),br,
submit(-name=>'return',-value=>'Cancel & Return',-class=>'error'),
end_form();
}
PrintBottom;
sub print_top {
my $title = 'Data Submissions and Comments';
print start_html (
'-Title' => $title,
'-style' => Style(),
),
Header,
h1($title);
}
sub print_instructions {
my @defaults;
for (my $i=0; $i<@FEEDBACK_RECIPIENTS; $i++) {
push @defaults,$i if $FEEDBACK_RECIPIENTS[$i][2];
}
print
p({-class=>'small'},
"Use this form to send new data or corrections to",
"the maintainers of this database. An e-mail message",
"will be sent to the individuals selected from the list",
"below."),
blockquote({-class=>'small'},
checkbox_group(-name => 'recipients',
-Values => [(0..$#FEEDBACK_RECIPIENTS)],
-Labels => { map {
$_=>"$FEEDBACK_RECIPIENTS[$_]->[0] ($FEEDBACK_RECIPIENTS[$_]->[1])"
} (0..$#FEEDBACK_RECIPIENTS) },
-defaults=>\@defaults,
-linebreak=>1));
}
sub print_bottom {
print Footer;
}
sub print_form {
my ($name,$class,$db,$where_from) = @_;
print
table(
TR(th({-align=>'RIGHT'},"Your full name:"),
td({-align=>'LEFT'},textfield(-name=>'full_name',-size=>40))),
TR(th({-align=>'RIGHT'},"Your institution:"),
td({-align=>'LEFT'},textfield(-name=>'institution',-size=>40))),
TR(th({-align=>'RIGHT'},"Your e-mail address:"),
td({-align=>'LEFT'},textfield(-name=>'from',-size=>40))),
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
unless my $institution = param('institution');
push @missing,"Your e-mail address"
unless my $from = param('from');
push @missing,"A properly formatted e-mail address"
if $from && $from !~ /.+\@[\w.]+/;
push @missing,"A subject line"
unless my $subject = param('subject');
push @missing,"A comment or correction"
unless my $remark = param('remark');
if (@missing) {
print
p({-class=>'error'},
"Your submission could not be processed because",
"the following information was missing:"),
ol({-class=>'error'},
li(\@missing)),
p({-class=>'error'},
"Please fill in the missing fields and try again.");
return;
}
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
my $error = <<END;
Unable to send mail. Please try again later.
If the problem persists, contact the site\'s webmaster.
END
;
unless (open (MAIL,"|/usr/lib/sendmail -oi -t")) {
AceError($error);
return;
}
my $to = join(", ",@addresses);
print MAIL <<END;
From: $from ($name via ACEDB feedback page)
To: $to
Subject: $subject
Full name: $name
Institution: $institution
Address: $from
DATABASE RECORD: $obj_class: $obj_name
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
END
;
unless (close MAIL) {
AceError($error);
return;
}
return 1;
}
sub print_confirmation {
print
p("Thank you for taking the time to submit this information.",
"Please use the buttons below to submit more reports or to",
"return to the database.",
),
start_form,
submit(-name=>'restart',-label=>'Submit Another Report'),
hidden('referer'),
submit(-name=>'return',-label=>'Return to Database'),
end_form;
}
acebrowser/cgi-bin/misc/privacy view on Meta::CPAN
# -*- Mode: perl -*-
# file: privacy
# Privacy statement
use strict;
use Ace::Browser::AceSubs;
use CGI 2.42 qw/redirect h1 start_form end_form start_html hidden submit param referer p/;
my $where_from = param('referer') || referer();
if (param('return') && $where_from !~ /\/privacy/ ) {
print redirect($where_from);
exit 0;
}
PrintTop(undef,undef,'Privacy Statement');
print
p(
"This server logs the IP address of your browser and each database query.",
"This is done in order to track usage statistics",
"and to identify operational problems. This information is not used",
"to identify individuals or organizations, and is never shared with third",
"parties."
),
p(
"Cookies are used by the search pages in order to bookmark your search",
"requests. They do not persist after you exit the browser, and are never",
acebrowser/cgi-bin/moviedb/movie view on Meta::CPAN
use lib '..';
use vars '$DB';
use Ace 1.51;
use Ace::Browser::AceSubs;
use CGI 2.42 qw/:standard :html3 escape/;
my $movie = GetAceObject();
PrintTop($movie,'Movie');
print_prompt();
AceNotFound() unless $movie;
print_report($movie);
PrintBottom();
exit 0;
sub print_prompt {
print
start_form(),
p("Database ID",
textfield(-name=>'name'),
hidden(class=>'Movie'),
),
end_form;
}
sub print_report {
my $movie = shift;
print h2($movie->Title);
print p("Directed by ",map { ObjectLink($_,$_->Full_name) } $movie->Director);
print table(
TR({-align=>'LEFT'},
th('Released'),
td($movie->Released)),
TR({-align=>'LEFT'},
th(em('Starring')),
td(map { ObjectLink($_,$_->Full_name) } $movie->Cast)),
TR({-align=>'LEFT'},
th(em('Writer(s)')),
td(map { ObjectLink($_,$_->Full_name) } $movie->Writer)),
$movie->Based_on ?
acebrowser/cgi-bin/moviedb/person view on Meta::CPAN
use strict;
use lib '..';
use vars '$DB';
use Ace 1.51;
use Ace::Browser::AceSubs;
use CGI 2.42 qw/:standard :html3 escape/;
my $person = GetAceObject();
PrintTop($person,'Person');
print_prompt();
AceNotFound() unless $person;
print_report($person);
PrintBottom();
sub print_prompt {
print
start_form({-name=>'form1',-action=>Url(url(-relative=>1))}),
p("Database ID",
hidden(class=>'Person'),
textfield(-name=>'name')
),
end_form;
}
sub print_report {
my $person = shift;
print h2($person->Full_name);
if (my @address = $person->Address(2)) {
print h3('Contact Information'),blockquote(address(join(br,@address)));
print a({-href=>'mailto:' . $person->Email(1)},"Send e-mail to this person")
if $person->Email;
} else {
print p(font({-color=>'red'},'No contact information in database'));
}
if ($person->Born || $person->Height) {
print h3('Fun Facts'),
table({-border=>undef},
TR({-align=>'LEFT'}, th('Height'), td($person->Height(1) || '?')),
TR({-align=>'LEFT'}, th('Birthdate'),td($person->Born(1)|| '?'))
),
}
if (my @directed = $person->Directed) {
print h3('Movies Directed');
my @full_names = map { ObjectLink($_,$_->Title) } @directed;
print ol(li \@full_names);
}
if (my @scripted = $person->Scripted) {
print h3('Movies Scripted');
my @full_names = map { ObjectLink($_,$_->Title) } @scripted;
print ol(li \@full_names);
}
if (my @stars_in = $person->Stars_in) {
print h3('Starring Roles In');
my @full_names = map { ObjectLink($_,$_->Title) } @stars_in;
print ol(li \@full_names);
}
if (my @books = $person->Wrote) {
print h3('Wrote');
my @full_names = map { ObjectLink($_,$_->Title) } @books;
print ol(li \@full_names);
}
}
acebrowser/cgi-bin/searches/basic view on Meta::CPAN
($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},
td(radio_group(-name=>'class',
-Values=>\@classlist,
-Labels=>{@$classlist},
-default=>'Any',
-rows=>3)),
td({-align=>LEFT,-class=>'large'},
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;
}
acebrowser/cgi-bin/searches/query view on Meta::CPAN
($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(
[cite({-style=>'font-size: 10pt'},'find Author COUNT Paper > 100'),
cite({-style=>'font-size: 10pt'},'find Author IS "Garvin*" ; >Laboratory; >Staff')
]),br,
a({-href=>"http://probe.nalusda.gov:8000/aboutacedbquery.html",
-style=>'font-size: 10pt'},
'Documentation and more examples')
),
);
print start_form,
textfield(-name=>'query',-size=>80),br,
submit(-label=>'Query'),
end_form;
}
acebrowser/cgi-bin/searches/query view on Meta::CPAN
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
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,
table(
TR(
td("Search text: "),
td(textfield(-name=>'query',-size=>40)),
td(submit(-label=>'Search'))),
TR(
td(),
td({-colspan=>2},
radio_group(-name=>'type',
acebrowser/cgi-bin/searches/text view on Meta::CPAN
-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;
}
acelib/aceclientlib.c view on Meta::CPAN
signal (SIGALRM, wakeUp) ; /* reregister, otherwise you exit on SGI and LINUX */
}
static FILE *magicFileOpen (char *name)
{
FILE *f ;
f = fopen (name, "r") ;
if (f)
{ if (accessDebug)
printf ("// found %s immediately\n", name) ;
return f ;
}
/* test if directory readable by trying to open the file "." in
the directory. filcheck() and access() won't work in setuid()
situations.
*/
{ char *dirName, *cp ;
dirName = strnew (name, 0) ;
for (cp = dirName ; *cp ; ++cp) ;
while (cp > dirName && *cp != '/') --cp ;
*++cp = '.' ;
*++cp = 0 ;
if (!(f = fopen(dirName, "r")))
{ if (accessDebug)
printf ("// directory %s not readable\n", dirName) ;
return 0 ;
}
fclose (f) ;
}
{ int i ;
struct itimerval tval ;
signal (SIGALRM, wakeUp) ;
tval.it_interval.tv_sec = 0 ;
tval.it_interval.tv_usec = 5000 ; /* 5ms reload */
tval.it_value.tv_sec = 0 ;
tval.it_value.tv_usec = 1000 ; /* 1ms initial */
setitimer (ITIMER_REAL, &tval, 0) ;
for (i = 0 ; i < 1000 ; ++i) /* 5 seconds */
{ pause () ; /* wait until SIGALRM handled */
f = fopen (name, "r") ;
if (f)
{ if (accessDebug)
printf ("// found %s after %d msecs\n", name, 5*i+1) ;
tval.it_interval.tv_usec = tval.it_value.tv_usec = 0 ;
setitimer (ITIMER_REAL, &tval, 0) ;
return f ;
}
}
if (accessDebug)
printf ("// failed to find %s after %d msecs\n", name, 5*i+1) ;
tval.it_interval.tv_usec = tval.it_value.tv_usec = 0 ;
setitimer (ITIMER_REAL, &tval, 0) ;
}
return 0 ;
}
static int getMagic (int magic1, char *nm)
{ int magic = 0, magic2 = 0, magic3 = 0 ;
FILE *f ;
acelib/aceclientlib.c view on Meta::CPAN
if (!freecard(level))
goto fin ;
cp = freeword () ;
if (!cp)
{ messerror ("Can't obtain write pass name from server") ;
goto fin ;
}
if (accessDebug)
printf ("// Write pass file: %s\n", cp) ;
if (strcmp(cp, "NON_WRITABLE"))
{ f = magicFileOpen (cp) ;
if (f)
{ if (fscanf(f, "%d", &magic3) != 1)
messerror ("failed to read file") ;
fclose(f) ;
}
}
if ((cp = freeword ()) &&
!magic3) /* must be able to read if can write */
{ if (accessDebug)
printf ("// Read pass file: %s\n", cp) ;
if (strcmp(cp, "PUBLIC") && strcmp(cp,"RESTRICTED"))
{ f = magicFileOpen (cp) ;
if (!f)
{ messout ("// Access to this database is restricted, sorry (can't open pass file)\n") ;
goto fin ;
}
if (fscanf(f, "%d", &magic2) != 1)
messerror ("failed to read file") ;
fclose(f) ;
}
acelib/aceclientlib.c view on Meta::CPAN
magic = magic1 ;
if (magic2)
magic = magic1 * magic2 % 73256171 ;
if (magic3)
magic = magic1 * magic3 % 43532334 ;
fin:
freeclose(level) ;
#ifdef DEEP_DEBUG
printf ("// magic1=%d, magic2=%d, magic3=%d, magic=%d\n",
magic1, magic2, magic3, magic) ;
#endif
return magic ;
}
/*************************************************************
Open RPC connection to server
INPUT
char *host hostname running server
( run in 1.274 second using v1.01-cache-2.11-cpan-de7293f3b23 )