AcePerl
view release on metacpan or search on metacpan
package Ace;
use strict;
use Carp qw(croak carp cluck);
use Scalar::Util 'weaken';
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Error $DEBUG_LEVEL);
use Data::Dumper;
use AutoLoader 'AUTOLOAD';
require Exporter;
use overload
'""' => 'asString',
'cmp' => 'cmp';
@ISA = qw(Exporter);
# Items to export into callers namespace by default.
@EXPORT = qw(STATUS_WAITING STATUS_PENDING STATUS_ERROR);
# Optional exports
@EXPORT_OK = qw(rearrange ACE_PARSE);
$VERSION = '1.92';
use constant STATUS_WAITING => 0;
use constant STATUS_PENDING => 1;
use constant STATUS_ERROR => -1;
use constant ACE_PARSE => 3;
use constant DEFAULT_PORT => 200005; # rpc server
use constant DEFAULT_SOCKET => 2005; # socket server
require Ace::Iterator;
require Ace::Object;
eval qq{use Ace::Freesubs}; # XS file, may not be available
# Map database names to objects (to fix file-caching issue)
my %NAME2DB;
# internal cache of objects
my %MEMORY_CACHE;
my %DEFAULT_CACHE_PARAMETERS = (
default_expires_in => '1 day',
auto_purge_interval => '12 hours',
);
# Preloaded methods go here.
$Error = '';
# Pseudonyms and deprecated methods.
*list = \&fetch;
*Ace::ERR = *Error;
# now completely deprecated and gone
# *find_many = \&fetch_many;
# *models = \&classes;
sub connect {
my $class = shift;
my ($host,$port,$user,$pass,$path,$program,
$objclass,$timeout,$query_timeout,$database,
$server_type,$url,$u,$p,$cache,$other);
# one-argument single "URL" form
if (@_ == 1) {
return $class->connect(-url=>shift);
}
# multi-argument (traditional) form
($host,$port,$user,$pass,
$path,$objclass,$timeout,$query_timeout,$url,$cache,$other) =
rearrange(['HOST','PORT','USER','PASS',
'PATH',['CLASS','CLASSMAPPER'],'TIMEOUT',
'QUERY_TIMEOUT','URL','CACHE'],@_);
($host,$port,$u,$pass,$p,$server_type) = $class->process_url($url)
or croak "Usage: Ace->connect(-host=>\$host,-port=>\$port [,-path=>\$path]\n"
if defined $url;
if ($path) { # local database
$server_type = 'Ace::Local';
} else { # either RPC or socket server
$host ||= 'localhost';
$user ||= $u || '';
$path ||= $p || '';
$port ||= $server_type eq 'Ace::SocketServer' ? DEFAULT_SOCKET : DEFAULT_PORT;
$query_timeout = 120 unless defined $query_timeout;
$server_type ||= 'Ace::SocketServer' if $port < 100000;
$server_type ||= 'Ace::RPC' if $port >= 100000;
}
# we've normalized parameters, so do the actual connect
eval "require $server_type" || croak "Module $server_type not loaded: $@";
if ($path) {
$database = $server_type->connect(-path=>$path,%$other);
} else {
$database = $server_type->connect($host,$port,$query_timeout,$user,$pass,%$other);
}
unless ($database) {
$Ace::Error ||= "Couldn't open database";
return;
}
my $contents = {
'database'=> $database,
'host' => $host,
'port' => $port,
'path' => $path,
'class' => $objclass || 'Ace::Object',
'timeout' => $query_timeout,
'user' => $user,
'pass' => $pass,
'other' => $other,
'date_style' => 'java',
'auto_save' => 0,
};
my $self = bless $contents,ref($class)||$class;
$self->_create_cache($cache) if $cache;
$self->name2db("$self",$self);
return $self;
}
sub reopen {
my $self = shift;
return 1 if $self->ping;
my $class = ref($self->{database});
my $database;
if ($self->{path}) {
$database = $class->connect(-path=>$self->{path},%{$self->other});
} else {
$database = $class->connect($self->{host},$self->{port}, $self->{timeout},
$self->{user},$self->{pass},%{$self->{other}});
}
unless ($database) {
$Ace::Error = "Couldn't open database";
return;
}
$self->{database} = $database;
1;
}
sub class {
my $self = shift;
my $d = $self->{class};
$self->{class} = shift if @_;
$d;
}
sub class_for {
my $self = shift;
my ($class,$id) = @_;
my $selected_class;
if (my $selector = $self->class) {
if (ref $selector eq 'HASH') {
$selected_class = $selector->{$class} || $selector->{'_DEFAULT_'};
}
elsif ($selector->can('class_for')) {
$selected_class = $selector->class_for($class,$id,$self);
}
elsif (!ref $selector) {
$selected_class = $selector;
}
else {
croak "$selector is neither a scalar, nor a HASH, nor an object that supports the class_for() method";
}
}
$selected_class ||= 'Ace::Object';
eval "require $selected_class; 1;" || croak $@
unless $selected_class->can('new');
$selected_class;
}
sub process_url {
my $class = shift;
my $url = shift;
my ($host,$port,$user,$pass,$path,$server_type) = ('','','','','','');
if ($url) { # look for host:port
local $_ = $url;
if (m!^rpcace://([^:]+):(\d+)$!) { # rpcace://localhost:200005
($host,$port) = ($1,$2);
$server_type = 'Ace::RPC';
} elsif (m!^sace://([\w:]+)\@([^:]+):(\d+)$!) { # sace://user@localhost:2005
($user,$host,$port) = ($1,$2,$3);
$server_type = 'Ace::SocketServer';
} elsif (m!^sace://([^:]+):(\d+)$!) { # sace://localhost:2005
($host,$port) = ($1,$2);
$server_type = 'Ace::SocketServer';
} elsif (m!^tace:(/.+)$!) { # tace:/path/to/database
$path = $1;
$server_type = 'Ace::Local';
} elsif (m!^(/.+)$!) { # /path/to/database
$path = $1;
$server_type = 'Ace::Local';
} else {
return;
}
}
if ($user =~ /:/) {
($user,$pass) = split /:/,$user;
}
return ($host,$port,$user,$pass,$path,$server_type);
}
# Return the low-level Ace::AceDB object
sub db {
return $_[0]->{'database'};
}
# Fetch a model from the database.
# Since there are limited numbers of models, we cache
# the results internally.
sub model {
my $self = shift;
require Ace::Model;
my $model = shift;
my $break_cycle = shift; # for breaking cycles when following #includes
my $key = join(':',$self,'MODEL',$model);
$self->{'models'}{$model} ||= eval{$self->cache->get($key)};
unless ($self->{models}{$model}) {
$self->{models}{$model} =
Ace::Model->new($self->raw_query("model \"$model\""),$self,$break_cycle);
eval {$self->cache->set($key=>$self->{models}{$model})};
}
return $self->{'models'}{$model};
}
# cached get
# pass "1" for fill to get a full fill
# pass any other true value to get a tag fill
sub get {
my $self = shift;
my ($class,$name,$fill) = @_;
# look in caches first
my $obj = $self->memory_cache_fetch($class=>$name)
|| $self->file_cache_fetch($class=>$name);
return $obj if $obj;
# _acedb_get() does the caching
$obj = $self->_acedb_get($class,$name,$fill) or return;
$obj;
}
sub _acedb_get {
my $self = shift;
my ($class,$name,$filltag) = @_;
return unless $self->count($class,$name) >= 1;
#return $self->{class}->new($class,$name,$self,1) unless $filltag;
return ($self->_list)[0] unless $filltag;
if (defined $filltag && $filltag eq '1') { # full fill
return $self->_fetch();
} else {
return $self->_fetch(undef,undef,$filltag);
}
}
#### CACHE AND CARRY CODE ####
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ":",$self,$class,$name;
return unless defined $MEMORY_CACHE{$key};
carp "memory_cache hit on $class:$name"
if Ace->debug;
return $MEMORY_CACHE{$key};
}
sub memory_cache_store {
my $self = shift;
croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
my $obj = shift;
my $key = join ':',$obj->db,$obj->class,$obj->name;
return if exists $MEMORY_CACHE{$key};
carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
weaken($MEMORY_CACHE{$key} = $obj);
}
sub memory_cache_clear {
my $self = shift;
%MEMORY_CACHE = ();
}
sub memory_cache_delete {
my $package = shift;
my $obj = shift or croak "Usage: memory_cache_delete(\$obj)";
my $key = join ':',$obj->db,$obj->class,$obj->name;
delete $MEMORY_CACHE{$key};
}
# Call as:
# $ace->file_cache_fetch($class=>$id)
sub file_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ':',$class,$name;
my $cache = $self->cache or return;
my $obj = $cache->get($key);
if ($obj && !exists $obj->{'.root'}) { # consistency checks
require Data::Dumper;
warn "CACHE BUG! Discarding inconsistent object $obj\n";
warn Data::Dumper->Dump([$obj],['obj']);
$cache->remove($key);
return;
}
warn "cache ",$obj?'hit':'miss'," on '$key'\n" if Ace->debug;
$self->memory_cache_store($obj) if $obj;
$obj;
}
# call as
# $ace->file_cache_store($obj);
sub file_cache_store {
my $self = shift;
my $obj = shift;
return unless $obj->name;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
warn "caching $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
if ($key eq ':') { # something badly wrong
cluck "NULL OBJECT";
}
$cache->set($key,$obj);
}
sub file_cache_delete {
my $self = shift;
my $obj = shift;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
carp "deleting $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
$cache->remove($key,$obj);
}
#### END: CACHE AND CARRY CODE ####
# Fetch one or a group of objects from the database
sub fetch {
my $self = shift;
my ($class,$pattern,$count,$offset,$query,$filled,$total,$filltag) =
rearrange(['CLASS',['NAME','PATTERN'],'COUNT','OFFSET','QUERY',
['FILL','FILLED'],'TOTAL','FILLTAG'],@_);
if (defined $class
&& defined $pattern
&& $pattern !~ /[\?\*]/
# && !wantarray
) {
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 {
my $self = shift;
my $params = shift;
$params = {} if $params and !ref $params;
return unless eval {require Cache::SizeAwareFileCache}; # not installed
(my $namespace = "$self") =~ s!/!_!g;
my %cache_params = (
namespace => $namespace,
%DEFAULT_CACHE_PARAMETERS,
%$params,
);
my $cache_obj = Cache::SizeAwareFileCache->new(\%cache_params);
$self->cache($cache_obj);
}
# class method
sub name2db {
shift;
my $name = shift;
return unless defined $name;
my $d = $NAME2DB{$name};
# weaken($NAME2DB{$name} = shift) if @_;
$NAME2DB{$name} = shift if @_;
$d;
}
# make a new object using indicated class and name pattern
sub new {
my $self = shift;
my ($class,$pattern) = rearrange([['CLASS'],['NAME','PATTERN']],@_);
croak "You must provide -class and -pattern arguments"
unless $class && $pattern;
# escape % signs in the string
$pattern = Ace->freeprotect($pattern);
$pattern =~ s/(?<!\\)%/\\%/g;
my $r = $self->raw_query("new $class $pattern");
if (defined($r) and $r=~/write access/im) { # this keeps changing
$Ace::Error = "Write access denied";
return;
}
unless ($r =~ /($class)\s+\"([^\"]+)\"$/im) {
$Ace::Error = $r;
return;
}
$self->fetch($1 => $2);
}
# perform an AQL query
sub aql {
my $self = shift;
my $query = shift;
my $db = $self->db;
my $r = $self->raw_query("aql -j $query");
if ($r =~ /(AQL error.*)/) {
$self->error($1);
return;
}
my @r;
foreach (split "\n",$r) {
next if m!^//!;
next if m!^\0!;
my ($class,$id) = Ace->split($_);
my @objects = map { $self->class_for($class,$id)->new(Ace->split($_),$self,1)} split "\t";
push @r,\@objects;
}
return @r;
}
# Return the contents of a keyset. Pattern matches are allowed, in which case
# the keysets will be merged.
sub keyset {
my $self = shift;
my $pattern = shift;
$self->raw_query (qq{find keyset "$pattern"});
$self->raw_query (qq{follow});
return $self->_list;
}
#########################################################
# These functions are for low-level (non OO) access only.
# This is for low-level access only.
sub show {
my ($self,$class,$pattern,$tag) = @_;
$Ace::Error = '';
return unless $self->count($class,$pattern);
# if we get here, then we've got some data to return.
my @result;
my $ts = $self->{'timestamps'} ? '-T' : '';
$self->{database}->query("show -j $ts $tag");
my $result = $self->read_object;
unless ($result =~ /(\d+) object dumped/m) {
$Ace::Error = 'Unexpected close during show';
return;
}
return grep (!m!^//!,split("\n\n",$result));
}
sub read_object {
my $self = shift;
return unless $self->{database};
my $result;
while ($self->{database}->status == STATUS_PENDING()) {
my $data = $self->{database}->read();
# $data =~ s/\0//g; # get rid of nulls in the buffer
$result .= $data if defined $data;
}
return $result;
}
# do a query, and return the result immediately
sub raw_query {
my ($self,$query,$no_alert,$parse) = @_;
$self->_alert_iterators unless $no_alert;
$self->{database}->query($query, $parse ? ACE_PARSE : () );
return $self->read_object;
}
# return the last error
sub error {
my $class = shift;
$Ace::Error = shift() if defined($_[0]);
$Ace::Error=~s/\0//g; # get rid of nulls
return $Ace::Error;
}
# close the database
sub close {
my $self = shift;
$self->raw_query('save') if $self->auto_save;
foreach (keys %{$self->{iterators}}) {
$self->_unregister_iterator($_);
}
delete $self->{database};
}
sub DESTROY {
my $self = shift;
return if caller() =~ /^Cache\:\:/;
warn "$self->DESTROY at ", join ' ',caller() if Ace->debug;
$self->close;
}
#####################################################################
###################### private routines #############################
sub rearrange {
my($order,@param) = @_;
return unless @param;
my %param;
if (ref $param[0] eq 'HASH') {
%param = %{$param[0]};
} else {
return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');
my $i;
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';
$query .= " -b $offset" if defined $offset;
$query .= " -c $count" if defined $count;
my $result = $self->raw_query($query);
$result =~ s/\0//g; # get rid of &$#&@( nulls
foreach (split("\n",$result)) {
my ($class,$name) = Ace->split($_);
next unless $class and $name;
my $obj = $self->memory_cache_fetch($class,$name);
$obj ||= $self->file_cache_fetch($class,$name);
unless ($obj) {
$obj = $self->class_for($class,$name)->new($class,$name,$self,1);
$self->memory_cache_store($obj);
$self->file_cache_store($obj);
}
push @result,$obj;
}
return @result;
}
# return a portion of the active list
sub _fetch {
my $self = shift;
my ($count,$start,$tag) = @_;
my (@result);
$tag = '' unless defined $tag;
my $query = "show -j $tag";
$query .= ' -T' if $self->{timestamps};
$query .= " -b $start" if defined $start;
$query .= " -c $count" if defined $count;
$self->{database}->query($query);
while (my @objects = $self->_fetch_chunk) {
push (@result,@objects);
}
# copy tag into a portion of the tree
if ($tag) {
for my $tree (@result) {
my $obj = $self->class_for($tree->class,$tree->name)->new($tree->class,$tree->name,$self,1);
$obj->_attach_subtree($tag=>$tree);
$tree = $obj;
}
}
# now recache 'em
for (@result) {
if (my $obj = $self->memory_cache_store($_)) {
%$obj = %$_ unless $obj->filled; # contents copy -- replace partial object with full object
$_ = $obj;
} else {
$self->memory_cache_store($_);
}
}
return wantarray ? @result : $result[0];
}
sub _fetch_chunk {
my $self = shift;
return unless $self->{database}->status == STATUS_PENDING();
my $result = $self->{database}->read();
$result =~ s/\0//g; # get rid of &$#&@!! nulls
my @chunks = split("\n\n",$result);
my @result;
foreach (@chunks) {
next if m!^//!;
next unless /\S/; # occasional empty lines
my ($class,$id) = Ace->split($_); # /^\?([^?]+)\?([^?]+)\?/m;
push(@result,$self->class_for($class,$id)->newFromText($_,$self));
}
return @result;
}
sub _alert_iterators {
my $self = shift;
foreach (keys %{$self->{iterators}}) {
$self->{iterators}{$_}->invalidate if $self->{iterators}{$_};
}
undef $self->{active_list};
}
sub asString {
my $self = shift;
return "tace://$self->{path}" if $self->{'path'};
my $server = $self->db && $self->db->isa('Ace::SocketServer') ? 'sace' : 'rpcace';
return "$server://$self->{host}:$self->{port}" if $self->{'host'};
return ref $self;
}
sub cmp {
my ($self,$arg,$reversed) = @_;
my $cmp;
if (ref($arg) and $arg->isa('Ace')) {
$cmp = $self->asString cmp $arg->asString;
} else {
$cmp = $self->asString cmp $arg;
}
return $reversed ? -$cmp : $cmp;
}
# Count the objects matching pattern without fetching them.
sub count {
my $self = shift;
my ($class,$pattern,$query) = rearrange(['CLASS',
['NAME','PATTERN'],
'QUERY'],@_);
$Ace::Error = '';
# A special case occurs when we have already fetched this
# object and it is already on the active list. In this
# case, we do not need to recount.
$query = '' unless defined $query;
$pattern = '' unless defined $pattern;
$class = '' unless defined $class;
my $active_tag = "$class$pattern$query";
if (defined $self->{'active_list'} &&
defined ($self->{'active_list'}->{$active_tag})) {
return $self->{'active_list'}->{$active_tag};
}
if ($query) {
$query = "query $query" unless $query=~/^query\s/;
} else {
$pattern =~ tr/\n//d;
$pattern ||= '*';
$pattern = Ace->freeprotect($pattern);
$query = "find $class $pattern";
}
my $result = $self->raw_query($query);
# unless ($result =~ /Found (\d+) objects/m) {
unless ($result =~ /(\d+) Active Objects/m) {
$Ace::Error = 'Unexpected close during find';
return;
}
return $self->{'active_list'}->{$active_tag} = $1;
}
1;
__END__
=head1 NAME
Ace - Object-Oriented Access to ACEDB Databases
=head1 SYNOPSIS
use Ace;
# open a remote database connection
$db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr',
-port => 20000100);
# 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) {
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;
my $ace_data = shift;
my @lines = split("\n",$ace_data);
foreach (@lines) { s/;/\\;/; } # protect semicolons
my $query = join("; ",@lines);
my $result = $self->raw_query("parse = $query");
$Ace::Error = $result=~/sorry|parse error/mi ? $result : '';
my @results = $self->_list(1,0);
return $results[0];
}
# Parse a single object as longtext and return the result
# as an object
sub parse_longtext {
my $self = shift;
my ($title,$body) = @_;
my $mm = "parse =
Longtext $title
$body
***LongTextEnd***
" ;
$mm =~ s/\//\\\//g ;
$mm =~ s/\n/\\n/g ;
$mm .= "\n" ;
my $result = $self->raw_query($mm) ;
$Ace::Error = $result=~/sorry|parse error/mi ? $result : '';
my @results = $self->_list(1,0);
return $results[0];
}
# Parse a file and return all the results
sub parse_file {
my $self = shift;
my ($file,$keepgoing) = @_;
local(*ACE);
local($/) = ''; # paragraph mode
my(@objects,$errors);
open(ACE,$file) || croak "$file: $!";
while (<ACE>) {
chomp;
my $obj = $self->parse($_);
unless ($obj) {
$errors .= $Ace::Error; # keep track of errors
last unless $keepgoing;
}
push(@objects,$obj);
}
close ACE;
$Ace::Error = $errors;
return @objects;
}
# Create a new Ace::Object in the indicated database
# (doesn't actually write into database until you do a commit)
sub new {
my $self = shift;
my ($class,$name) = rearrange([qw/CLASS NAME/],@_);
return if $self->fetch($class,$name);
my $obj = $self->class_for($class,$name)->new($class,$name,$self);
return $obj;
}
# Return the layout, which contains classes that should be displayed
sub layout {
my $self = shift;
my $result = $self->raw_query('layout');
$result=~s{\n(\s*\n|//.*\n|\0)+\Z}{}m; # get rid of extraneous information
$result;
}
# Return a hash of all the classes and the number of objects in each
sub class_count {
my $self = shift;
return $self->raw_query('classes') =~ /^\s+(\S+) (\d+)/gm;
}
# Return a hash of miscellaneous status information from the server
# (to be expanded later)
sub status {
my $self = shift;
my $data = $self->raw_query('status');
study $data;
my %status;
# -Code section
my ($program) = $data=~/Program:\s+(.+)/m;
my ($aceversion) = $data=~/Version:\s+(.+)/m;
my ($build) = $data=~/Build:\s+(.+)/m;
$status{code} = { program=>$program,
version=>$aceversion,
build =>$build};
# -Database section
my ($title) = $data=~/Title:\s+(.+)/m;
my ($name) = $data=~/Name:\s+(.+)/m;
my ($release) = $data=~/Release:\s+(.+)/m;
my ($directory) = $data=~/Directory:\s+(.+)/m;
my ($session) = $data=~/Session:\s+(\d+)/m;
my ($user) = $data=~/User:\s+(.+)/m;
my ($write) = $data=~/Write Access:\s+(.+)/m;
my ($address) = $data=~/Global Address:\s+(\d+)/m;
$status{database} = {
title => $title,
version => $name,
dbformat => $release,
directory => $directory,
session => $session,
user => $user,
write => $write,
address => $address,
};
# other info - not all
my ($classes) = $data=~/classes:\s+(\d+)/;
my ($keys) = $data=~/keys:\s+(\d+)/;
my ($memory) = $data=~/blocks:\s+\d+,\s+allocated \(kb\):\s+(\d+)/;
$status{resources} = {
classes => $classes,
keys => $keys,
memory => $memory * 1024,
};
return wantarray ? %status : \%status;
}
sub title {
my $self = shift;
my $status= $self->status;
$status->{database}{title};
}
sub version {
my $self = shift;
my $status= $self->status;
$status->{database}{version};
}
sub auto_save {
my $self = shift;
if ($self->db && $self->db->can('auto_save')) {
$self->db->auto_save;
} else {
$self->{'auto_save'} = $_[0] if defined $_[0];
return $self->{'auto_save'};
}
}
# Perform an ace query and return the result
sub find {
my $self = shift;
my ($query,$count,$offset,$filled,$total) = rearrange(['QUERY','COUNT',
'OFFSET',['FILL','FILLED'],'TOTAL'],@_);
$offset += 0;
$query = "find $query" unless $query=~/^find/i;
my $cnt = $self->count(-query=>$query);
$$total = $cnt if defined $total;
return $cnt unless wantarray;
$filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
#########################################################
# Grep function returns count in a scalar context, list
# of retrieved objects in a list context.
sub grep {
my $self = shift;
my ($pattern,$count,$offset,$filled,$filltag,$total,$long) =
rearrange(['PATTERN','COUNT','OFFSET',['FILL','FILLED'],'FILLTAG','TOTAL','LONG'],@_);
$offset += 0;
my $grep = defined($long) && $long ? 'LongGrep' : 'grep';
my $r = $self->raw_query("$grep $pattern");
my ($cnt) = $r =~ /Found (\d+) objects/m;
$$total = $cnt if defined $total;
return $cnt if !wantarray;
if ($filltag) {
@h = $self->_fetch($count,$offset,$filltag);
} else {
@h = $filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
@h;
}
sub pick {
my ($self,$class,$item) = @_;
$Ace::Error = '';
# assumption of uniqueness of name is violated by some classes!
# return () unless $self->count($class,$item) == 1;
return unless $self->count($class,$item) >= 1;
# if we get here, then we've got some data to return.
# yes, we're repeating code slightly...
my @result;
my $ts = $self->{'timestamps'} ? '-T' : '';
my $result = $self->raw_query("show -j $ts");
unless ($result =~ /(\d+) object dumped/m) {
$Ace::Error = 'Unexpected close during pick';
return;
}
@result = grep (!m!^\s*//!,split("\n\n",$result));
return $result[0];
}
# these two only get loaded if the Ace::Freesubs .XS isn't compiled
sub freeprotect {
my $class = shift;
my $text = shift;
$text =~ s/\n/\\n/g;
$text =~ s/\t/\\t/g;
$text =~ s/"/\\"/g;
return qq("$text");
}
sub split {
my $class = shift;
my $text = shift;
$text =~ s/\\n/\n/g;
$text =~ s/\\t/\t/g;
my ($id,$ts);
($class,$id,$ts) = $text=~m/^\?(.+)(?<!\\)\?(.+)(?<!\\)\?([^?]*)$/s;
$class ||= ''; # fix uninitialized variable warnings
$id ||= '';
$class =~ s/\\\?/?/g;
$id =~ s/\\\?/?/g;
return ($class,$id) unless $ts;
return ($class,$id,$ts); # return timestamp
}
# Return a list of all the classes known to the server.
sub classes {
my ($self,$invisible) = @_;
my $query = defined($invisible) && $invisible ?
"query find class !buried"
:
"query find class visible AND !buried";
$self->raw_query($query);
return $self->_list;
}
################## iterators ##################
# Fetch many objects in iterative style
sub fetch_many {
my $self = shift;
my ($class,$pattern,$filled,$query,$chunksize) = rearrange( ['CLASS',
['PATTERN','NAME'],
['FILL','FILLED'],
'QUERY',
'CHUNKSIZE'],@_);
$pattern ||= '*';
$pattern = Ace->freeprotect($pattern);
if (defined $query) {
$query = "query $query" unless $query=~/^query\s/;
} elsif (defined $class) {
$query = qq{query find $class $pattern};
} else {
croak "must call fetch_many() with the -class or -query arguments";
}
my $iterator = Ace::Iterator->new($self,$query,$filled,$chunksize);
return $iterator;
}
sub _register_iterator {
my ($self,$iterator) = @_;
$self->{iterators}{$iterator} = $iterator;
}
sub _unregister_iterator {
my ($self,$iterator) = @_;
$self->_restore_iterator($iterator);
delete $self->{iterators}{$iterator};
}
sub _save_iterator {
my $self = shift;
my $iterator = shift;
return unless $self->{iterators}{$iterator};
$self->{iterator_stack} ||= [];
return 1 if grep { $_ eq $iterator } @{$self->{iterator_stack}};
$self->raw_query("spush",'no_alert');
unshift @{$self->{iterator_stack}},$iterator;
1; # result code -- CHANGE THIS LATER
}
# horrid method that keeps the database's view of
# iterators in synch with our view
sub _restore_iterator {
my $self = shift;
my $iterator = shift;
# no such iterator known, return false
return unless $self->{iterators}{$iterator};
# make other iterators save themselves
$self->_alert_iterators;
# fetch the list of iterators stored on the stack
my $list = $self->{iterator_stack};
# spick not supported. Abandon ship
return if @$list > 1 and $self->{no_spick};
# Find the iterator in our list. This mirrors the
# position in the server stack
my $i;
for ($i=0; $i<@$list; $i++) {
last if $list->[$i] eq $iterator;
}
return unless $i < @$list;
# Sse spop if the list size is 1. Otherwise use spick, which is
# only supported in hacked versions of the server.
my $result = $i == 0 ? $self->raw_query("spop",'no_alert')
: $self->raw_query("spick $i",'no_alert');
if ($result =~ /Keyword spick does not match/) {
# _restore_iterator will now only work for a single iterator (non-reentrantly)
$self->{no_spick}++;
$self->raw_query('spop','no_alert') foreach @$list; # empty database stack
$self->{iterator_stack} = []; # and local copy
return;
}
unless (($result =~ /The stack now holds (\d+) keyset/ && ($1 == (@$list-1) ))
or
($result =~ /stack is (now )?empty/ && @$list == 1)
) {
$Ace::Error = 'Unexpected result from spick: $result';
return;
}
splice(@$list,$i,1); # remove from position
return 1;
}
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);
}
( run in 1.496 second using v1.01-cache-2.11-cpan-2398b32b56e )