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);
# 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";
build build date of acedb binary in format Jan 25 2003 16:21:24
database
title name of the database
version version of the database
dbformat database format version number
directory directory in which the database is stored
session session number
user user under which server is running
write whether the server has write access
address global address - not known if this is useful
resources
classes number of classes defined
keys number of keys defined
memory amount of memory used by acedb objects (bytes)
For example, to get the program version:
my $version = $db->status->{code}{version};
=head2 title() method
my $title = $db->title
Returns the version of the current database, equivalent
to $db->status->{database}{title};
=head2 version() method
my $version = $db->version;
Returns the version of the current database, equivalent
to $db->status->{database}{version};
=head2 date_style() method
$style = $db->date_style();
$style = $db->date_style('ace');
$style = $db->date_style('java');
For historical reasons, AceDB can display dates using either of two
different formats. The first format, which I call "ace" style, puts
the year first, as in "1997-10-01". The second format, which I call
"java" style, puts the day first, as in "01 Oct 1997 00:00:00" (this
is also the style recommended for Internet dates). The default is to
use the latter notation.
B<date_style()> can be used to set or retrieve the current style.
Called with no arguments, it returns the current style, which will be
one of "ace" or "java." Called with an argument, it will set the
style to one or the other.
=head2 timestamps() method
$timestamps_on = $db->timestamps();
$db->timestamps(1);
Whenever a data object is updated, AceDB records the time and date of
the update, and the user ID it was running under. Ordinarily, the
retrieval of timestamp information is suppressed to conserve memory
and bandwidth. To turn on timestamps, call the B<timestamps()> method
with a true value. You can retrieve the current value of the setting
by calling the method with no arguments.
Note that activating timestamps disables some of the speed
optimizations in AcePerl. Thus they should only be activated if you
really need the information.
=head2 auto_save()
Sets or queries the I<auto_save> variable. If true, the "save"
command will be issued automatically before the connection to the
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])
( run in 1.562 second using v1.01-cache-2.11-cpan-98e64b0badf )