AcePerl
view release on metacpan or search on metacpan
my $self = shift;
my ($class,$name,$filltag) = @_;
return unless $self->count($class,$name) >= 1;
#return $self->{class}->new($class,$name,$self,1) unless $filltag;
return ($self->_list)[0] unless $filltag;
if (defined $filltag && $filltag eq '1') { # full fill
return $self->_fetch();
} else {
return $self->_fetch(undef,undef,$filltag);
}
}
#### CACHE AND CARRY CODE ####
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
push(@result,$self->class_for($class,$id)->newFromText($_,$self));
}
return @result;
}
sub _alert_iterators {
my $self = shift;
foreach (keys %{$self->{iterators}}) {
$self->{iterators}{$_}->invalidate if $self->{iterators}{$_};
}
undef $self->{active_list};
}
sub asString {
my $self = shift;
return "tace://$self->{path}" if $self->{'path'};
my $server = $self->db && $self->db->isa('Ace::SocketServer') ? 'sace' : 'rpcace';
return "$server://$self->{host}:$self->{port}" if $self->{'host'};
return ref $self;
}
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
-timeout 25
-query_timeout 120
If you prefer to use a more Smalltalk-like message-passing syntax, you
can open a connection this way too:
$db = connect Ace -host=>'beta.crbm.cnrs-mop.fr',-port=>20000100;
The return value is an Ace handle to use to access the database, or
undef if the connection fails. If the connection fails, an error
message can be retrieved by calling Ace->error.
You may check the status of a connection at any time with ping(). It
will return a true value if the database is still connected. Note
that Ace will timeout clients that have been inactive for any length
of time. Long-running clients should attempt to reestablish their
connection if ping() returns false.
$db->ping() || die "not connected";
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.
This method behaves differently depending on whether it is called in a
scalar or a list context, and whether it is asked to search for a name
pattern or a simple name.
When called with a class and a simple name, it returns the object
referenced by that time, or undef, if no such object exists. In an
array context, it will return an empty list.
When called with a class and a name pattern in a list context, fetch()
returns the list of objects that match the name. When called with a
pattern in a scalar context, fetch() returns the I<number> of objects
that match without actually retrieving them from the database. Thus,
it is similar to count().
In the examples below, the first line of code will fetch the Sequence
object whose database ID is I<D12345>. The second line will retrieve
all objects matching the pattern I<D1234*>. The third line will
return the count of objects that match the same pattern.
$object = $db->fetch(Sequence => 'D12345');
@objects = $db->fetch(Sequence => 'D1234*');
$cnt = $db->fetch(Sequence =>'D1234*');
A variety of communications and database errors may occur while
processing the request. When this happens, undef or an empty list
will be returned, and a string describing the error can be retrieved
by calling Ace->error.
When retrieving database objects, it is possible to retrieve a
"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
B<fetch_many()> instead (see below). Also see the get() method, which
is equivalent to the simple two-argument form of fetch().
=item get() method
$object = $db->get($class,$name [,$fill]);
The get() method will return one and only one AceDB object
identified by its class and name. The optional $fill argument can be
used to control how much data is retrieved from the database. If $fill
is absent or undefined, then the method will return a lightweight
"stub" object that is filled with information as requested in a lazy
fashion. If $fill is the number "1" then the retrieved object contains
all the relevant information contained within the database. Any other
true value of $fill will be treated as a tag name: the returned object
will be prefilled with the subtree to the right of that tag.
Examples:
# return lightweight stub for Author object "Sulston JE."
$author = $db->get(Author=>'Sulston JE');
=head2 aql() method
$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);
database. In case of an error, processing will stop at the last
object successfully written and an error message will be placed in
Ace->error();
=head2 parse() method
$object = $db->parse('data to parse');
This will parse the Ace tags contained within the "data to parse"
string, convert it into an object in the databse, and return the
resulting Ace::Object. In case of a parse error, the undefined value
will be returned and a (hopefully informative) description of the
error will be returned by Ace->error().
For example:
$author = $db->parse(<<END);
Author : "Glimitz JR"
Full_name "Jonathan R. Glimitz"
Mail "128 Boylston Street"
Mail "Boston, MA"
This method can also be used to parse several objects, but only the
last object successfully parsed will be returned.
=head2 parse_longtext() method
$object = $db->parse($title,$text);
This will parse the long text (which may contain carriage returns and
other funny characters) and place it into the database with the given
title. In case of a parse error, the undefined value will be returned
and a (hopefully informative) description of the error will be
returned by Ace->error(); otherwise, a LongText object will be returned.
For example:
$author = $db->parse_longtext('A Novel Inhibitory Domain',<<END);
We have discovered a novel inhibitory domain that inhibits
many classes of proteases, including metallothioproteins.
This inhibitory domain appears in three different gene families studied
to date...
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.
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
just retrieving the value of a few tags).
B<fetch_many()> retrieves objects from the database in groups of a
This will return an I<Ace::Model> object corresponding to the
indicated class.
=head2 new() method
$obj = $db->new($class,$name);
$obj = $db->new(-class=>$class,
-name=>$name);
Create a new object in the database with the indicated class and name
and return a pointer to it. Will return undef if the object already
exists in the database. The object isn't actually written into the database
until you call Ace::Object::commit().
=head2 raw_query() method
$r = $db->raw_query('Model');
Send a command to the database and return its unprocessed output.
This method is necessary to gain access to features that are not yet
implemented in this module, such as model browsing and complex
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()
=over 4
=item new($host,$port,$query_timeout)
Connect to the host $host at port $port. Queries will time out after
$query_timeout seconds. If timeout is not specified, it defaults to
120 (two minutes).
If successful, this call returns an Ace::AceDB connection object.
Otherwise, it returns undef. Example:
$acedb = Ace::AceDB->new('localhost',200005,5)
|| die "Couldn't connect";
The Ace::AceDB object can also be accessed from the high-level Ace
interface by calling the ACE::db() method:
$db = Ace->new(-host=>'localhost',-port=>200005);
$acedb = $db->db();
Ace/Browser/AceSubs.pm view on Meta::CPAN
There are two main types of AceBrowser scripts:
=over 4
=item display scripts
These are called with the CGI parameters b<name> and b<class>,
corresponding to the name and class of an AceDB object to display.
The subroutine GetAceObject() will return the requested object, or
undef if the object does not exist.
To retrieve the parameters, use the CGI.pm param() method:
$name = param('name');
$class = param('class');
=item search scripts
These are not called with any CGI parameters on their first
Ace/Browser/AceSubs.pm view on Meta::CPAN
=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.
Ace/Browser/AceSubs.pm view on Meta::CPAN
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
called by PrintTop() and Header() internally.
=cut
# Subroutines used by all scripts.
# Will generate an HTTP 'document not found' error if you try to get an
# undefined database name. Check the return code from this function and
# return immediately if not true (actually, not needed because we exit).
sub AceInit {
$HEADER = 0;
$TOP = 0;
@COOKIES = ();
# keeps track of what sections should be open
%OPEN = param('open') ? map {$_ => 1} split(' ',param('open')) : () ;
return 1 if Configuration();
Ace/Browser/AceSubs.pm view on Meta::CPAN
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
them.
The three arguements are:
$symbol The keyword or query string the user was searching
on, undef if none.
$report The symbolic name of the current display, or undef
if none.
$objects An array reference containing the Ace objects in
question.
This subroutine is not exported by default.
=cut
sub AceMultipleChoices {
Ace/Browser/AceSubs.pm view on Meta::CPAN
'-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();
}
Ace/Browser/AceSubs.pm view on Meta::CPAN
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
Ace/Browser/AceSubs.pm view on Meta::CPAN
}
=item $object = GetAceObject()
This function is called by display scripts to return the
Ace::Object.that the user wishes to view. It automatically opens or
refreshes the database, and performs the request using the values of the
"name" and "class" CGI variables.
If a single object is found, the function returns it as the function
result. If no objects are found, it returns undef. If more than one
object is found, the function invokes AceMultipleChoices() and exits
the script.
=cut
# open database, return object requested by CGI parameters
sub GetAceObject {
my $db = OpenDatabase() || AceError("Couldn't open database."); # exits
my $name = param('name') or return;
my $class = param('class') or return;
Ace/Browser/AceSubs.pm view on Meta::CPAN
(my $name = path_info())=~s!^/!!;
return $name if defined $name && $name ne ''; # get from additional path info
my $path = url(-absolute=>1);
return $VALID{$path} if exists $VALID{$path};
my @path = split '/',$path;
pop @path;
for my $name ((reverse @path),'default') {
next unless $name;
return $VALID{$path} if exists $VALID{$name};
return $VALID{$path} = $name if Ace::Browser::SiteDefs->getConfig($name);
$VALID{$path} = undef;
}
return;
}
1;
__END__
=back
=head1 BUGS
Ace/Browser/SiteDefs.pm view on Meta::CPAN
Thereafter, it's just a matter of making the proper method calls.
If the Configuration file is a.... The method call returns a...
---------------------------------- ----------------------------
Scalar variable Scalar
Array variable Array reference
Hash variable Hash reference
Subroutine Code reference
If a variable is not defined, the corresponding method will return undef.
=head1 BUGS
Please report them.
=head1 SEE ALSO
L<Ace::Object>, L<Ace::Browser::AceSubs>, L<Ace::Browsr::SearchSubs>,
the README.ACEBROWSER file.
Ace/Browser/SiteDefs.pm view on Meta::CPAN
my %data;
# get the scalars
local *symbol;
foreach (keys %{"${namespace}::"}) {
*symbol = ${"${namespace}::"}{$_};
$data{ucfirst(lc $_)} = $symbol if defined($symbol);
$data{ucfirst(lc $_)} = \%symbol if defined(%symbol);
$data{ucfirst(lc $_)} = \@symbol if defined(@symbol);
$data{ucfirst(lc $_)} = \&symbol if defined(&symbol);
undef *symbol unless defined &symbol; # conserve some memory
}
# special case: get the search scripts as both an array and as a hash
if (my @searches = @{"$namespace\:\:SEARCHES"}) {
$data{Searches} = [ @searches[map {2*$_} (0..@searches/2-1)] ];
%{$data{Search_titles}} = @searches;
}
# return this thing as a blessed object
return bless \%data,$package;
Ace/Graphics/Glyph/triangle.pm view on Meta::CPAN
my $gd = shift;
my $fg = $self->fgcolor;
my $orient = $self->option('orient') || 'S';
# find the center and vertices
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $xmid = ($x1+$x2)/2;
my $ymid = ($y1+$y2)/2;
my ($vx1,$vy1,$vx2,$vy2,$vx3,$vy3) = undef;
#effectively the width of the base
my $p = abs($x2 - $x1);
my $q = $p/2;
if ($self->option('point')){
$p = $self->option('point');
$p = $p > $self->option('height') ? $self->option('height') : $p;
$q = $p/2;
$x1 = $xmid - $q; $x2 = $xmid + $q;
$y1 = $ymid - $q; $y2 = $ymid + $q;
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
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])
Ace/Graphics/Panel.pm view on Meta::CPAN
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
name is not a valid one, new() will throw an exception.
=back
=head2 OBJECT METHODS
=over 4
=item $track = $panel->add_track($glyph,$features,@options)
Ace/Graphics/Panel.pm view on Meta::CPAN
-font Glyph font gdSmallFont
-label Whether to draw a label false
-bump Bump direction 0
-connect_groups false
Connect groups by a
dashed line (see below)
-key Show this track in the undef
key
Colors can be expressed in either of two ways: as symbolic names such
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.
Ace/Graphics/Track.pm view on Meta::CPAN
my $class = shift;
my ($glyph_name,$features,@options) = @_;
$glyph_name ||= 'generic';
$features ||= [];
my $glyph_factory = $class->make_factory($glyph_name,@options);
my $self = bless {
features => [], # list of Ace::Sequence::Feature objects
factory => $glyph_factory, # the glyph class associated with this track
glyphs => undef, # list of glyphs
},$class;
$self->add_feature($_) foreach @$features;
$self;
}
# control bump direction:
# +1 => bump downward
# -1 => bump upward
# 0 => no bump
sub bump {
Ace/Graphics/Track.pm view on Meta::CPAN
=over 4
=item $track = Ace::Graphics::Track->new($glyph_name,$features,@options)
The new() method creates a new track object from the provided glyph
name and list of features. The arguments are similar to those in
Ace::Graphics::Panel->new().
If successful new() will return a new Ace::Graphics::Track.
Otherwise, it will return undef.
If the specified glyph name is not a valid one, new() will throw an
exception.
=back
=head2 OBJECT METHODS
Once a track is created, the following methods can be invoked.
Ace/Graphics/Track.pm view on Meta::CPAN
Because layout is an expensive operation, calling this method several
times will return the previously-cached result, ignoring any changes
to track attributes.
=item $height = $track->height
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
Ace/Iterator.pm view on Meta::CPAN
use Ace 1.50 qw(rearrange);
$VERSION = '1.51';
sub new {
my $pack = shift;
my ($db,$query,$filled,$chunksize) = rearrange([qw/DB QUERY FILLED CHUNKSIZE/],@_);
my $self = {
'db' => $db,
'query' => $query,
'valid' => undef,
'cached_answers' => [],
'filled' => ($filled || 0),
'chunksize' => ($chunksize || 40),
'current' => 0
};
bless $self,$pack;
$db->_register_iterator($self) if $db && ref($db);
$self;
}
Ace/Iterator.pm view on Meta::CPAN
my $val = $self->{active};
$self->{active} = shift if @_;
return $val;
}
sub restore_context {
my $self = shift;
return unless my $db = $self->{db};
$db->raw_query($self->{query})
unless $self->{saved_ok} and $db->_restore_iterator($self);
undef $self->{saved_ok}; # no longer there!
}
1;
__END__
=head1 NAME
Ace::Iterator - Iterate Across an ACEDB Query
Ace/Iterator.pm view on Meta::CPAN
chunksize to optimize the retrieval for your application.
=back
=head2 next() method
$object = $iterator->next;
This method retrieves the next object from the query, performing
whatever database accesses it needs. After the last object has been
fetched, the next() will return undef. Usually you will call next()
inside a loop like this:
while (my $object = $iterator->next) {
# do something with $object
}
Because of the way that object caching works, next() will be most
efficient if you are only looping over one iterator at a time.
Although parallel access will work correctly, it will be less
efficient than serial access. If possible, avoid this type of code:
Ace/Local.pm view on Meta::CPAN
} else {
$path ||= DEFAULT_DB;
$path = _expand_twiddles($path);
$args = $path;
}
my($rdr,$wtr) = (gensym,gensym);
my($pid) = open2($rdr,$wtr,"$program $args");
unless ($pid) {
$Ace::Error = <$rdr>;
return undef;
}
# Figure out the prompt by reading until we get zero length,
# then take whatever's at the end.
unless ($nosync) {
local($/) = "> ";
my $data = <$rdr>;
($prompt) = $data=~/^(.+> )/m;
unless ($prompt) {
$Ace::Error = "$program didn't open correctly";
return undef;
}
}
return bless {
'read' => $rdr,
'write' => $wtr,
'prompt' => $prompt,
'pid' => $pid,
'auto_save' => 1,
'status' => $nosync ? STATUS_PENDING : STATUS_WAITING, # initial stuff to read
Ace/Local.pm view on Meta::CPAN
sub query {
my $self = shift;
my $query = shift;
warn "query($query)\n" if $self->debug;
if ($self->debug) {
my $msg = $query || '';
warn "\tquery($msg)";
}
return undef if $self->{'status'} == STATUS_ERROR;
do $self->read() until $self->{'status'} != STATUS_PENDING;
my $wtr = $self->{'write'};
print $wtr "$query\n";
$self->{'status'} = STATUS_PENDING;
}
sub low_read { # hack to accomodate "uninitialized database" warning from tace
my $self = shift;
my $rdr = $self->{'read'};
return undef unless $self->{'status'} == STATUS_PENDING;
my $rin = '';
my $data = '';
vec($rin,fileno($rdr),1)=1;
unless (select($rin,undef,undef,1)) {
$self->{'status'} = STATUS_WAITING;
return undef;
}
sysread($rdr,$data,READSIZE);
return $data;
}
sub read {
my $self = shift;
return undef unless $self->{'status'} == STATUS_PENDING;
my $rdr = $self->{'read'};
my $len = defined $self->{'buffer'} ? length($self->{'buffer'}) : 0;
my $plen = length($self->{'prompt'});
my ($result, $bytes, $pos, $searchfrom);
while (1) {
# Read the data directly onto the end of the buffer
$bytes = sysread($rdr, $self->{'buffer'},
Ace/Local.pm view on Meta::CPAN
=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
successful. You must then call read() repeatedly in order to fetch
the query result.
Ace/Local.pm view on Meta::CPAN
entire result. Canonical example:
$accessor->query("find Sequence D*");
die "Got an error ",$accessor->error() if $accessor->status == STATUS_ERROR;
while ($accessor->status == STATUS_PENDING) {
$result .= $accessor->read;
}
=head2 low_read()
Read whatever data's available, or undef if none. This is only used
by the ace.pl replacement for giface/tace.
=head2 status()
Return the status code from the last operation. Status codes are
exported by default when you B<use> Ace.pm. The status codes you may
see are:
STATUS_WAITING The server is waiting for a query.
STATUS_PENDING A query has been sent and Ace is waiting for
Ace/Object.pm view on Meta::CPAN
}
$self = $self->fetch if !$no_dereference &&
!$self->isRoot && $self->db; # dereference, if need be
croak "Null object tag \"$func_name\"" unless $self;
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.
Ace/Object.pm view on Meta::CPAN
# this feature if timestamps are active.
unless ($self->filled) {
my $subobject = $self->newFromText(
$self->db->show($self->class,$self->name,$tag),
$self->db
);
if ($subobject) {
$subobject->{'.nocache'}++;
$self->_attach_subtree($lctag => $subobject);
} else {
$self->{'.PATHS'}{$lctag} = undef;
}
$self->_dirty(1);
last TRY;
}
my @col = $self->col;
foreach (@col) {
next unless $_->isTag;
if (lc $_ eq $lctag) {
$self->{'.PATHS'}{$lctag} = $_;
Ace/Object.pm view on Meta::CPAN
next unless $_->isTag;
if (my $r = $_->search($tag)) {
$self->{'.PATHS'}{$lctag} = $r;
$self->_dirty(1);
last TRY;
}
}
# If we got here, we just didn't find it. So tag the cache
# as empty so that we don't try again
$self->{'.PATHS'}{$lctag} = undef;
$self->_dirty(1);
}
my $t = $self->{'.PATHS'}{$lctag};
return unless $t;
if (defined $subtag) {
if ($subtag =~ /^\d+$/) {
$pos = $subtag;
} else { # position on subtag and search again
Ace/Object.pm view on Meta::CPAN
}
return;
}
# Used to munge special data types. Right now dates are the
# only examples.
sub _ace_format {
my $self = shift;
my ($class,$name) = @_;
return undef unless defined $class && defined $name;
return $class eq 'date' ? $self->_to_ace_date($name) : $name;
}
# It's an object unless it is one of these things
sub _isObject {
return unless defined $_[0];
$_[0] !~ /^(float|int|date|tag|txt|peptide|dna|scalar|[Tt]ext|comment)$/;
}
# utility routine used to split a tag path into individual components
Ace/Object.pm view on Meta::CPAN
$full_name = $object->right->right;
$full_name = $object->right(2);
$city = $object->right->down->down->right->right->down->down;
$city = $object->right->down(2)->right(2)->down(2);
If $object contains the "Thierry-Mieg J" Author object, then the first
series of accesses shown above retrieves the string "Jean
Thierry-Mieg" and the second retrieves "34033 Montpellier." If the
right or bottom pointers are NULL, these methods will return undef.
In addition to being somewhat awkard, you will probably never need to
use these methods. A simpler way to retrieve the same information
would be to use the at() method described in the next section.
The right() and down() methods always walk through the tree of the
current object. They do not follow object pointers into the database.
Use B<fetch()> (or the deprecated B<pick()> or B<follow()> methods)
instead.
Ace/Object.pm view on Meta::CPAN
For example:
$fax_no = $object->get('Fax',0);
--> "Fax"
$fax_no = $object->get('Fax',1);
--> "33-67-521559"
$fax_no = $object->get('Fax',2);
--> undef # nothing beyond the fax number
@address = $object->get('Address',2);
--> ('CRBM duCNRS','BP 5051','34033 Montpellier','FRANCE',
'mieg@kaa.cnrs-mop.fr,'33-67-613324','33-67-521559')
It is important to note that B<get()> only traverses tags. It will
not traverse nodes that aren't tags, such as strings, integers or
objects. This is in keeping with the behavior of the Ace query
language "show" command.
Ace/Object.pm view on Meta::CPAN
=head2 kill() method
$result_code = $object->kill;
This will remove the object from the database immediately and
completely. It does not wait for a commit(), and does not respond to
a rollback(). If successful, you will be left with an empty object
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');
Ace/Object.pm view on Meta::CPAN
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
details.
=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
return undef.
Currently you cannot create a new comment in AcePerl or edit an old
one.
=head2 error() method
$error = $object->error;
Returns the error from the previous operation, if any. As in
Ace::error(), this string will only have meaning if the previous
Ace/Object.pm view on Meta::CPAN
# for insertion. Also need to link them together into a row.
my $previous;
foreach (@values) {
if (ref($_) && $_->isa('Ace::Object')) {
$_ = $_->_clone;
} else {
$_ = $self->new('scalar',$_);
}
$previous->{'.right'} = $_ if defined $previous;
$previous = $_;
$_->{'.right'} = undef; # make sure it doesn't automatically expand!
}
# position at the indicated tag (creating it if necessary)
my (@tags) = $self->_split_tags($tag);
my $p = $self;
foreach (@tags) {
$p = $p->_insert($_);
}
if ($p->{'.right'}) {
$p = $p->{'.right'};
Ace/Object.pm view on Meta::CPAN
@values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } ($oldvalue,@rest)
if defined($oldvalue);
unless ($tag =~ /\./) {
my $model = $self->model;
my @intermediate_tags = $model->path($tag);
$tag = join '.',@intermediate_tags,$tag;
}
my $row = join(".",($tag,map { (my $x = $_) =~s/\./\\./g; $x } @values));
my $subtree = $self->at($row,undef,1); # returns the parent
if (@values
&& defined($subtree->{'.right'})
&& "$subtree->{'.right'}" eq $oldvalue) {
$subtree->{'.right'} = $subtree->{'.right'}->down;
} else {
$subtree->{'.down'} = $subtree->{'.down'}->{'.down'}
}
push(@{$self->{'.update'}},join(' ','-D',
Ace/Object.pm view on Meta::CPAN
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::Error = $result;
}
return if $Ace::Error;
undef $self->{'.update'};
# this will force a fresh retrieval of the object
# and synchronize our in-memory copy with the db
delete $self->{'.right'};
delete $self->{'.PATHS'};
return 1;
}
# undo changes
sub rollback {
my $self = shift;
undef $self->{'.update'};
# this will force object to be reloaded from database
# next time it is needed.
delete $self->{'.right'};
delete $self->{'.PATHS'};
1;
}
sub debug {
my $self = shift;
Ace->debug(@_);
Ace/Sequence.pm view on Meta::CPAN
# create subroutine that filters GFF files for certain feature types
sub _make_filter {
my $self = shift;
my $automerge = $self->automerge;
# parse out the filter
my %filter;
foreach (@_) {
my ($type,$filter) = split(':',$_,2);
if ($automerge && lc($type) eq 'transcript') {
@filter{'exon','intron','Sequence','cds'} = ([undef],[undef],[undef],[undef]);
} elsif ($automerge && lc($type) eq 'clone') {
@filter{'Clone_left_end','Clone_right_end','Sequence'} = ([undef],[undef],[undef]);
} else {
push @{$filter{$type}},$filter;
}
}
# create pattern-match sub
my $sub;
my $promiscuous; # indicates that there is a subtype without a type
if (%filter) {
Ace/Sequence.pm view on Meta::CPAN
ancestor, but do not have to be directly related. An attempt to use a
disjunct reference sequence, such as one on a different chromosome,
will fail.
=item -name
As an alternative to using an I<Ace::Object> with the B<-source>
argument, you may specify a source sequence using B<-name> and B<-db>.
The I<Ace::Sequence> module will use the provided database accessor to
fetch a Sequence object with the specified name. new() will return
undef is no Sequence by this name is known.
=item -db
This argument is required if the source sequence is specified by name
rather than by object reference.
=back
If new() is successful, it will create an I<Ace::Sequence> object and
return it. Otherwise it will return undef and return a descriptive
message in Ace->error(). Certain programming errors, such as a
failure to provide required arguments, cause a fatal error.
=head2 Reference Sequences and the Coordinate System
When retrieving information from an I<Ace::Sequence>, the coordinate
system is based on the sequence segment selected at object creation
time. That is, the "+1" strand is the natural direction of the
I<Ace::Sequence> object, and base pair 1 is its first base pair. This
behavior can be overridden by providing a reference sequence to the
Ace/Sequence.pm view on Meta::CPAN
$name = $seq->name;
Return the name of the source sequence as a string.
=head2 get_parent()
$parent = $seq->parent;
Return the immediate ancestor of this I<Ace::Sequence> (i.e., the
sequence that contains this one). The return value is a new
I<Ace::Sequence> or undef, if no parent sequence exists.
=head2 get_children()
@children = $seq->get_children();
Returns all subsequences that exist as independent objects in the
ACeDB database. What exactly is returned is dependent on the data
model. In older ACeDB databases, the only subsequences are those
under the catchall Subsequence tag. In newer ACeDB databases, the
objects returned correspond to objects to the right of the S_Child
Ace/Sequence/Feature.pm view on Meta::CPAN
sub seqname {
my $self = shift;
my $seq = $self->_field('seqname');
$self->db->fetch(Sequence=>$seq);
}
sub method { shift->_field('method',@_) } # ... I prefer "method"
sub subtype { shift->_field('method',@_) } # ... or even "subtype"
sub type { shift->_field('type',@_) } # ... I prefer "type"
sub score { shift->_field('score',@_) } # float indicating some sort of score
sub frame { shift->_field('frame',@_) } # one of 1, 2, 3 or undef
sub info { # returns Ace::Object(s) with info about the feature
my $self = shift;
unless ($self->{group}) {
my $info = $self->{info}{group} || 'Method "'.$self->method.'"';
$info =~ s/(\"[^\"]*);([^\"]*\")/$1$;$2/g;
my @data = split(/\s*;\s*/,$info);
foreach (@data) { s/$;/;/g }
$self->{group} = [map {$self->toAce($_)} @data];
}
return wantarray ? @{$self->{group}} : $self->{group}->[0];
Ace/Sequence/Feature.pm view on Meta::CPAN
you will more usually use the inherited end() method to obtain the end
of the feature relative to the I<Ace::Sequence> from which it was
derived.
=item score()
$score = $feature->score;
For features that are associated with a numeric score, such as
similarities, this returns that value. For other features, this
method returns undef.
=item strand()
$strand = $feature->strand;
Returns the strandedness of this feature, either "+1" or "-1". For
features that are not stranded, returns 0.
=item reversed()
$reversed = $feature->reversed;
Returns true if the feature is reversed relative to its source
sequence.
=item frame()
$frame = $feature->frame;
For features that have a frame, such as a predicted coding sequence,
returns the frame, either 0, 1 or 2. For other features, returns undef.
=item group()
=item info()
=item target()
$info = $feature->info;
These methods (synonyms for one another) return an Ace::Object
Ace/Sequence/Multi.pm view on Meta::CPAN
ancestor, but do not have to be directly related. An attempt to use a
disjunct reference sequence, such as one on a different chromosome,
will fail.
=item -name
As an alternative to using an I<Ace::Object> with the B<-source>
argument, you may specify a source sequence using B<-name> and B<-db>.
The I<Ace::Sequence> module will use the provided database accessor to
fetch a Sequence object with the specified name. new() will return
undef is no Sequence by this name is known.
=item -db
This argument is required if the source sequence is specified by name
rather than by object reference. It must be a previously opened
handle to the reference database.
=item -secondary
This argument points to one or more previously-opened annotation
databases. You may use a scalar if there is only one annotation
database. Otherwise, use an array reference. You may add and delete
annotation databases after the object is created by using the
add_secondary() and delete_secondary() methods.
=back
If new() is successful, it will create an I<Ace::Sequence::Multi>
object and return it. Otherwise it will return undef and return a
descriptive message in Ace->error(). Certain programming errors, such
as a failure to provide required arguments, cause a fatal error.
=head1 OBJECT METHODS
Most methods are inherited from I<Ace::Sequence>. The following
additional methods are supported:
=over 4
Ace/SocketServer.pm view on Meta::CPAN
sub read {
my $self = shift;
return _error("No pending query") unless $self->status == STATUS_PENDING;
$self->_do_encore || return if $self->encore;
# call select() here to time out
if ($self->{timeout}) {
my $rdr = '';
vec($rdr,fileno($self->{socket}),1) = 1;
my $result = select($rdr,undef,undef,$self->{timeout});
return _error("Query timed out") unless $result;
}
my ($msg,$body) = $self->_recv_msg;
return unless defined $msg;
$msg =~ s/\0.+$//; # socketserver bug workaround: get rid of junk in message
if ($msg eq ACESERV_MSGOK or $msg eq ACESERV_MSGFAIL) {
$self->{status} = STATUS_WAITING;
$self->{encoring} = 0;
} elsif ($msg eq ACESERV_MSGENCORE) {
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
}
my $style = Style();
$style->{'code'} =<<END;
BODY {
background-color: #FFFFFF;
}
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();
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
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');
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
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 );
acebrowser/cgi-bin/misc/privacy view on Meta::CPAN
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",
acebrowser/cgi-bin/moviedb/person view on Meta::CPAN
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);
}
acebrowser/cgi-bin/searches/basic view on Meta::CPAN
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;
acebrowser/cgi-bin/searches/browser view on Meta::CPAN
# 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'},
acebrowser/cgi-bin/searches/query view on Meta::CPAN
$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: ",
acebrowser/cgi-bin/searches/text view on Meta::CPAN
$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.");
acebrowser/conf/elegans.pm view on Meta::CPAN
# elements.
$MAX_IN_COLUMN = 100;
# location of random pictures to display on certain pages
$RANDOM_PICTS = "$WB/random_pic";
$PIC_SCRIPT = "$ROOT/misc/random_pic";
#========================= WORMBASE-SPECIFIC CONFIGURATION ==================
# ========== An icon to use for "home" ==========
# leaving this undefined suppresses the generation of a "home" link
# $HOME_ICON = "$ICONS/arrows/uarrw.gif";
# ========= An icon to use for searching =======
# leaving this undefined suppresses the generation of a "search" link
# $SEARCH_ICON = "$ICONS/unknown.gif";
# position of the big banner
$BANNERS = "$WB/banners";
$BANNERS = "$WB/banners";
@BANNER_SIZE = (640,56);
# fixed width for the page
$PAGEWIDTH = 660;
acelib/Makefile view on Meta::CPAN
###########################################################
## Compiler and library options
## CC, LIBS, NAME are defined in $(ACEDB_MACHINE)_DEF
##
IDIR = -I. -I./wh
# Do not use -I/usr/include
# it prevents gcc from picking up its own includes
# (cc goes to /usr/include anyway)
## to undefine any rubbish
CCFLAGS =
GCFLAGS =
## Different platforms use CC or COMPILE.c
# (USEROPTS - see comments at top of file)
#
CC = $(COMPILER) $(USEROPTS) $(IDIR) -D$(NAME) -c
COMPILE.c = $(COMPILER) $(USEROPTS) $(IDIR) -D$(NAME) -c
###########################################################
acelib/filsubs.c view on Meta::CPAN
static int dirOrder(void *a, void *b)
{
char *cp1 = *(char **)a, *cp2 = *(char**)b;
return strcmp(cp1, cp2) ;
} /* dirOrder */
/* returns an Array of strings representing the filename in the
given directory according to the spec. "r" will list all files,
and "rd" will list all directories.
The behaviour of the "w" spec is undefined.
The array has to be destroyed using filDirectoryDestroy,
because the memory of the strings needs to be reclaimed as well. */
UTIL_FUNC_DEF Array filDirectoryCreate (char *dirName,
char *ending,
char *spec)
{
Array a ;
#if !defined(WIN32) && !defined(DARWIN)
DIR *dirp ;
acelib/wh/mystdlib.h view on Meta::CPAN
/* typedef fpos_t myoff_t; why? i remove this on jan 98 to compile on fujitsu */
typedef off_t myoff_t;
typedef mysize_t myFile_t;
#define FIL_BUFFER_SIZE 256
#define DIR_BUFFER_SIZE MAXPATHLEN
#if defined(WIN32)
/* _MAX_PATH is 260 in WIN32 but each path component can be max. 256 in size */
#undef DIR_BUFFER_SIZE
#define DIR_BUFFER_SIZE FIL_BUFFER_SIZE
#define MAXPATHLEN _MAX_PATH
#define popen _popen
#define pclose _pclose
/* rename to actual WIN32 built-in functions
* (rbrusk): this little code generated a "trigraph" error message
* when built in unix with the gcc compiler; however, I don't understand
* why gcc even sees this code, which is #if defined(WIN32)..#endif protected.
examples/ace.pl view on Meta::CPAN
while (<>) {
chomp;
evaluate($_);
} continue {
print $PROMPT;
}
}
quit();
sub quit {
undef $DB;
print "\n// A bientot!\n";
exit 0;
}
sub evaluate {
my $query = shift;
my @commands;
if ($query=~/^(quit|exit)/i) {
quit();
exit 0;
examples/ace.pl view on Meta::CPAN
push (@commands,setup_parse($1,$2));
} else {
push (@commands,$query);
}
foreach (@commands) {
print "$_\n" if @commands > 1;
$_ = setup_remote_parse($_) if /^parse (?!=)/ && !$PATH;
$DB->db->query($_) || return undef;
die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR;
while ($DB->db->status == STATUS_PENDING) {
my $h = $DB->db->read;
$h=~s/\0+\Z//; # get rid of nulls in data stream!
print $h;
print "\n" unless $h =~ /\n\Z/;
}
die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR;
examples/ace.pl view on Meta::CPAN
# if we're local, then we just create a series
# of parse commands and let tace take care of reading
# the file
return map {"parse $_"} @files if $PATH;
# if we're talking to a remote server, we create a series of parse
# commands and stop at the first file that we find
my @c;
local(*F);
local($/) = undef; # file slurp
foreach (@files) {
open (F,$_) || die "Couldn't open $_: $!";
print "parse $_\n";
my $result = $DB->raw_query(scalar(<F>),1);
print $result;
return if $result=~/error|sorry/i and $command ne 'pparse';
close F;
}
return ();
}
local($^W) = 0;
my($num, $true,$msg) = @_;
print($true ? "ok $num\n" : "not ok $num $msg\n");
}
# Test code:
my $ptr = Ace::SocketServer->connect(HOST,PORT,50);
test(2,$ptr,"connection failed");
die "Couldn't establish connection to database. Aborting tests.\n" unless $ptr;
test(3,$ptr->status() == STATUS_WAITING,"did not get wait status");
test(4,$ptr->query("Find Paper"),"query() returned undef");
test(5,$ptr->status() == STATUS_PENDING,"did not get pending status");
test(6,$ptr->read,"read failed");
test(7,$ptr->status() == STATUS_WAITING,"did not get wait status");
test(8,$ptr->query("List"),"query(list) returned undef");
my $data;
while ($ptr->status() == STATUS_PENDING) {
$data = $ptr->read();
}
test(9,length($data)>0,"didn't get data");
test(10,$ptr->status() == STATUS_WAITING,"did not get waiting status");
util/ace.PLS view on Meta::CPAN
while (<>) {
chomp;
evaluate($_);
} continue {
print $PROMPT;
}
}
quit();
sub quit {
undef $DB;
print "\n// A bientot!\n";
exit 0;
}
sub evaluate {
my $query = shift;
my @commands;
if ($query=~/^(quit|exit)/i) {
quit();
exit 0;
util/ace.PLS view on Meta::CPAN
push (@commands,setup_parse($1,$2));
} else {
push (@commands,$query);
}
foreach (@commands) {
print "$_\n" if @commands > 1;
$_ = setup_remote_parse($_) if /^parse (?!=)/ && !$PATH;
$DB->db->query($_) || return undef;
die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR;
while ($DB->db->status == STATUS_PENDING) {
my $h = $DB->db->read;
$h=~s/\0+\Z//; # get rid of nulls in data stream!
print $h;
print "\n" unless $h =~ /\n\Z/;
}
die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR;
util/ace.PLS view on Meta::CPAN
# if we're local, then we just create a series
# of parse commands and let tace take care of reading
# the file
return map {"parse $_"} @files if $PATH;
# if we're talking to a remote server, we create a series of parse
# commands and stop at the first file that we find
my @c;
local(*F);
local($/) = undef; # file slurp
foreach (@files) {
open (F,$_) || die "Couldn't open $_: $!";
print "parse $_\n";
my $result = $DB->raw_query(scalar(<F>),1);
print $result;
return if $result=~/error|sorry/i and $command ne 'pparse';
close F;
}
return ();
}
( run in 5.008 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )