view release on metacpan or  search on metacpan

Ace.pm  view on Meta::CPAN

  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;