File Coverage

blib/lib/Ace.pm

Criterion	Covered	Total	%
statement	88	425	20.7
branch	18	232	7.7
condition	10	89	11.2
subroutine	17	53	32.0
pod	22	31	70.9
total	155	830	18.6

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/(?
  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__