view release on metacpan or  search on metacpan

Ace.pm  view on Meta::CPAN

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);
  }

Ace.pm  view on Meta::CPAN

  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) {