AcePerl
view release on metacpan or search on metacpan
# the results internally.
sub model {
my $self = shift;
require Ace::Model;
my $model = shift;
my $break_cycle = shift; # for breaking cycles when following #includes
my $key = join(':',$self,'MODEL',$model);
$self->{'models'}{$model} ||= eval{$self->cache->get($key)};
unless ($self->{models}{$model}) {
$self->{models}{$model} =
Ace::Model->new($self->raw_query("model \"$model\""),$self,$break_cycle);
eval {$self->cache->set($key=>$self->{models}{$model})};
}
return $self->{'models'}{$model};
}
# cached get
# pass "1" for fill to get a full fill
# pass any other true value to get a tag fill
sub get {
my $self = shift;
my ($class,$name,$fill) = @_;
# look in caches first
my $obj = $self->memory_cache_fetch($class=>$name)
|| $self->file_cache_fetch($class=>$name);
return $obj if $obj;
# _acedb_get() does the caching
$obj = $self->_acedb_get($class,$name,$fill) or return;
$obj;
}
sub _acedb_get {
my $self = shift;
my ($class,$name,$filltag) = @_;
return unless $self->count($class,$name) >= 1;
#return $self->{class}->new($class,$name,$self,1) unless $filltag;
return ($self->_list)[0] unless $filltag;
if (defined $filltag && $filltag eq '1') { # full fill
return $self->_fetch();
} else {
return $self->_fetch(undef,undef,$filltag);
}
}
#### CACHE AND CARRY CODE ####
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ":",$self,$class,$name;
return unless defined $MEMORY_CACHE{$key};
carp "memory_cache hit on $class:$name"
if Ace->debug;
return $MEMORY_CACHE{$key};
}
sub memory_cache_store {
my $self = shift;
croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
my $obj = shift;
my $key = join ':',$obj->db,$obj->class,$obj->name;
return if exists $MEMORY_CACHE{$key};
carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
weaken($MEMORY_CACHE{$key} = $obj);
}
sub memory_cache_clear {
my $self = shift;
%MEMORY_CACHE = ();
}
sub memory_cache_delete {
my $package = shift;
my $obj = shift or croak "Usage: memory_cache_delete(\$obj)";
my $key = join ':',$obj->db,$obj->class,$obj->name;
delete $MEMORY_CACHE{$key};
}
# Call as:
# $ace->file_cache_fetch($class=>$id)
sub file_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ':',$class,$name;
my $cache = $self->cache or return;
my $obj = $cache->get($key);
if ($obj && !exists $obj->{'.root'}) { # consistency checks
require Data::Dumper;
warn "CACHE BUG! Discarding inconsistent object $obj\n";
warn Data::Dumper->Dump([$obj],['obj']);
$cache->remove($key);
return;
}
warn "cache ",$obj?'hit':'miss'," on '$key'\n" if Ace->debug;
$self->memory_cache_store($obj) if $obj;
$obj;
}
# call as
# $ace->file_cache_store($obj);
sub file_cache_store {
my $self = shift;
my $obj = shift;
return unless $obj->name;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
warn "caching $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
if ($key eq ':') { # something badly wrong
cluck "NULL OBJECT";
}
$cache->set($key,$obj);
}
sub file_cache_delete {
my $self = shift;
my $obj = shift;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
carp "deleting $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
$cache->remove($key,$obj);
}
#### END: CACHE AND CARRY CODE ####
# Fetch one or a group of objects from the database
sub fetch {
my $self = shift;
my ($class,$pattern,$count,$offset,$query,$filled,$total,$filltag) =
rearrange(['CLASS',['NAME','PATTERN'],'COUNT','OFFSET','QUERY',
['FILL','FILLED'],'TOTAL','FILLTAG'],@_);
if (defined $class
&& defined $pattern
&& $pattern !~ /[\?\*]/
# && !wantarray
) {
return $self->get($class,$pattern,$filled);
}
$offset += 0;
$pattern ||= '*';
$pattern = Ace->freeprotect($pattern);
if (defined $query) {
$query = "query $query" unless $query=~/^query\s/;
} elsif (defined $class) {
$query = qq{find $class $pattern};
} else {
croak "must call fetch() with the -class or -query arguments";
}
my $r = $self->raw_query($query);
my ($cnt) = $r =~ /Found (\d+) objects/m;
$$total = $cnt if defined $total;
# Scalar context and a pattern match operation. Return the
# object count without bothering to fetch the objects
return $cnt if !wantarray and $pattern =~ /(?:[^\\]|^)[*?]/;
my(@h);
if ($filltag) {
@h = $self->_fetch($count,$offset,$filltag);
} else {
@h = $filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
return wantarray ? @h : $h[0];
}
sub cache {
my $self = shift;
my $d = $self->{filecache};
$self->{filecache} = shift if @_;
$d;
}
sub _create_cache {
# These functions are for low-level (non OO) access only.
# This is for low-level access only.
sub show {
my ($self,$class,$pattern,$tag) = @_;
$Ace::Error = '';
return unless $self->count($class,$pattern);
# if we get here, then we've got some data to return.
my @result;
my $ts = $self->{'timestamps'} ? '-T' : '';
$self->{database}->query("show -j $ts $tag");
my $result = $self->read_object;
unless ($result =~ /(\d+) object dumped/m) {
$Ace::Error = 'Unexpected close during show';
return;
}
return grep (!m!^//!,split("\n\n",$result));
}
sub read_object {
my $self = shift;
return unless $self->{database};
my $result;
while ($self->{database}->status == STATUS_PENDING()) {
my $data = $self->{database}->read();
# $data =~ s/\0//g; # get rid of nulls in the buffer
$result .= $data if defined $data;
}
return $result;
}
# do a query, and return the result immediately
sub raw_query {
my ($self,$query,$no_alert,$parse) = @_;
$self->_alert_iterators unless $no_alert;
$self->{database}->query($query, $parse ? ACE_PARSE : () );
return $self->read_object;
}
# return the last error
sub error {
my $class = shift;
$Ace::Error = shift() if defined($_[0]);
$Ace::Error=~s/\0//g; # get rid of nulls
return $Ace::Error;
}
# close the database
sub close {
my $self = shift;
$self->raw_query('save') if $self->auto_save;
foreach (keys %{$self->{iterators}}) {
$self->_unregister_iterator($_);
}
delete $self->{database};
}
sub DESTROY {
my $self = shift;
return if caller() =~ /^Cache\:\:/;
warn "$self->DESTROY at ", join ' ',caller() if Ace->debug;
$self->close;
}
#####################################################################
###################### private routines #############################
sub rearrange {
my($order,@param) = @_;
return unless @param;
my %param;
if (ref $param[0] eq 'HASH') {
%param = %{$param[0]};
} else {
return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');
my $i;
for ($i=0;$i<@param;$i+=2) {
$param[$i]=~s/^\-//; # get rid of initial - if present
$param[$i]=~tr/a-z/A-Z/; # parameters are upper case
}
%param = @param; # convert into associative array
}
my(@return_array);
local($^W) = 0;
my($key)='';
foreach $key (@$order) {
my($value);
if (ref($key) eq 'ARRAY') {
foreach (@$key) {
last if defined($value);
$value = $param{$_};
delete $param{$_};
}
} else {
$value = $param{$key};
delete $param{$key};
}
push(@return_array,$value);
}
push (@return_array,\%param) if %param;
return @return_array;
}
# do a query, but don't return the result
sub _query {
my ($self,@query) = @_;
$self->_alert_iterators;
$self->{'database'}->query("@query");
}
# return a portion of the active list
sub _list {
my $self = shift;
my ($count,$offset) = @_;
my (@result);
my $query = 'list -j';
style to one or the other.
=head2 timestamps() method
$timestamps_on = $db->timestamps();
$db->timestamps(1);
Whenever a data object is updated, AceDB records the time and date of
the update, and the user ID it was running under. Ordinarily, the
retrieval of timestamp information is suppressed to conserve memory
and bandwidth. To turn on timestamps, call the B<timestamps()> method
with a true value. You can retrieve the current value of the setting
by calling the method with no arguments.
Note that activating timestamps disables some of the speed
optimizations in AcePerl. Thus they should only be activated if you
really need the information.
=head2 auto_save()
Sets or queries the I<auto_save> variable. If true, the "save"
command will be issued automatically before the connection to the
database is severed. The default is true.
Examples:
$db->auto_save(1);
$flag = $db->auto_save;
=head2 error() method
Ace->error;
This returns the last error message. Like UNIX errno, this variable
is not reset between calls, so its contents are only valid after a
method call has returned a result value indicating a failure.
For your convenience, you can call error() in any of several ways:
print Ace->error();
print $db->error(); # $db is an Ace database handle
print $obj->error(); # $object is an Ace::Object
There's also a global named $Ace::Error that you are free to use.
=head2 datetime() and date()
$datetime = Ace->datetime($time);
$today = Ace->datetime();
$date = Ace->date($time);
$today = Ace->date([$time]);
These convenience functions convert the UNIX timestamp given by $time
(seconds since the epoch) into a datetime string in the format that
ACEDB requires. date() will truncate the time portion.
If not provided, $time defaults to localtime().
=head1 OTHER METHODS
=head2 debug()
$debug_level = Ace->debug([$new_level])
This class method gets or sets the debug level. Higher integers
increase verbosity. 0 or undef turns off debug messages.
=head2 name2db()
$db = Ace->name2db($name [,$database])
This class method associates a database URL with an Ace database
object. This is used internally by the Ace::Object class in order to
discover what database they "belong" to.
=head2 cache()
Get or set the Cache::SizeAwareFileCache object, if one has been
created.
=head2 memory_cache_fetch()
$obj = $db->memory_cache_fetch($class,$name)
Given an object class and name return a copy of the object from the
in-memory cache. The object will only be cached if a copy of the
object already exists in memory space. This is ordinarily called
internally.
=head2 memory_cache_store($obj)
Store an object into the memory cache. This is ordinarily called
internally.
=head2 memory_cache_delete($obj)
Delete an object from the memory cache. This is ordinarily called
internally.
=head2 memory_cache_clear()
Completely clears the memory cache.
=head2 file_cache_fetch()
$obj = $db->file_cache_fetch($class,$name)
Given an object class and name return a copy of the object from the
file cache. This is ordinarily called internally.
=head2 file_cache_store($obj)
Store an object into the file cache. This is ordinarily called
internally.
=head2 file_cache_delete($obj)
Delete an object from the file cache. This is ordinarily called
internally.
=head1 THE LOW LEVEL C API
Internally Ace.pm makes C-language calls to libace to send query
strings to the server and to retrieve the results. The class that
exports the low-level calls is named Ace::AceDB.
also exported by default. Possible values:
ACE_INVALID
ACE_OUTOFCONTEXT
ACE_SYNTAXERROR
ACE_UNRECOGNIZED
Please see the ace client library documentation for a full description
of these error codes and their significance.
=item encore()
This method may return true after you have performed one or more
read() operations, and indicates that there is more data to read. You
will not ordinarily have to call this method.
=back
=head1 BUGS
1. The ACE model should be consulted prior to updating the database.
2. There is no automatic recovery from connection errors.
3. Debugging has only one level of verbosity, despite the best
of intentions.
4. Performance is poor when fetching big objects, because of
many object references that must be created. This could be
improved.
5. When called in an array context at("tag[0]") should return the
current tag's entire column. It returns the current subtree instead.
6. There is no way to add comments to objects.
7. When timestamps are active, many optimizations are disabled.
8. Item number eight is still missing.
=head1 SEE ALSO
L<Ace::Object>, L<Ace::Local>, L<Ace::Model>,
L<Ace::Sequence>,L<Ace::Sequence::Multi>.
=head1 AUTHOR
Lincoln Stein <lstein@cshl.org> with extensive help from Jean
Thierry-Mieg <mieg@kaa.crbm.cnrs-mop.fr>
Copyright (c) 1997-1998 Cold Spring Harbor Laboratory
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
# -------------------- AUTOLOADED SUBS ------------------
sub debug {
my $package = shift;
my $d = $DEBUG_LEVEL;
$DEBUG_LEVEL = shift if @_;
$d;
}
# Return true if the database is still connected. This is oddly convoluted
# because there are numerous things that can go wrong, including:
# 1. server has gone away
# 2. server has timed out our connection! (grrrrr)
# 3. communications channel contains unread garbage and is in an inconsistent state
sub ping {
my $self = shift;
local($SIG{PIPE})='IGNORE'; # so we don't get a fatal exception during the check
my $result = $self->raw_query('');
return unless $result; # server has gone away
return if $result=~/broken connection|client time out/; # server has timed us out
return unless $self->{database}->status() == STATUS_WAITING(); #communications oddness
return 1;
}
# Get or set the display style for dates
sub date_style {
my $self = shift;
$self->{'date_style'} = $_[0] if defined $_[0];
return $self->{'date_style'};
}
# Get or set whether we retrieve timestamps
sub timestamps {
my $self = shift;
$self->{'timestamps'} = $_[0] if defined $_[0];
return $self->{'timestamps'};
}
# Add one or more objects to the database
sub put {
my $self = shift;
my @objects = @_;
my $count = 0;
$Ace::Error = '';
foreach my $object (@objects) {
croak "Can't put a non-Ace object into an Ace database"
unless $object->isa('Ace::Object');
croak "Can't put a non-object into a database"
unless $object->isObject;
$object = $object->fetch unless $object->isRoot; # make sure we're putting root object
my $data = $object->asAce;
$data =~ s/\n/; /mg;
my $result = $self->raw_query("parse = $data");
$Ace::Error = $result if $result =~ /sorry|parse error/mi;
return $count if $Ace::Error;
$count++; # bump if succesful
}
return $count;
}
# Parse a single object and return the result as an object
sub parse {
my $self = shift;
( run in 1.548 second using v1.01-cache-2.11-cpan-13bb782fe5a )