view release on metacpan or  search on metacpan

lib/Cache/BDB.pm  view on Meta::CPAN

		__set_time => $now, 
		__last_access_time => $now,
		__version => $Cache::BDB::VERSION,
		__data => $value};

    $rv = $db->db_put($key, $data);

    return $rv ? 0 : 1;
}

sub add {
  my ($self, $key, $value, $ttl) = @_;

  return $self->get($key) ? 0 : $self->set($key, $value, $ttl);
}

sub replace {
  my ($self, $key, $value, $ttl) = @_;

  return $self->get($key) ? $self->set($key, $value, $ttl) : 0;
}

sub get {
    my ($self, $key) = @_;

    return undef unless $key;
    my $db = $self->{__db};
    my $t = time();

    my $data;

    if($self->{auto_purge_on_get}) {
      my $interval = $self->{auto_purge_interval};
      if($t > ($self->{__last_purge_time} + $interval)) {
	$self->purge();
	$self->{__last_purge_time} = $t;
      }
    }
    
    my $rv = $db->db_get($key, $data);
    return undef if $rv == DB_NOTFOUND;
    return undef unless $data->{__data};

    if($self->__is_expired($data, $t)) {
      $self->remove($key) unless $self->{disable_auto_purge};
      return undef;
    } 
    # this is pretty slow, leaving it out for now. if i start supporting
    # access time related stuff i'll need to work on it.
    #      $self->_update_access_time($key, $data, $t); 
    
    return $data->{__data};
}

sub get_bulk {
    my $self = shift;
    my $t = time();
    my $count = 0;
    
    my $db = $self->{__db};
    my $cursor = $db->db_cursor();
    
    my %ret;
    my ($k, $v) = ('','');

    while($cursor->c_get($k, $v, DB_NEXT) == 0) {
      my $d = $self->get($k);
      $ret{$k} = $d if $d;
    }
    $cursor->c_close();

    return \%ret;
}

sub _update_access_time {
    my ($self, $key, $data, $t)  = @_;
    
    my $db = $self->{__db};
    $t ||= time();
    $data->{__last_access_time} = $t;

    my $rv = $db->db_put($key, $data);
    
    return $rv;
}

###########################
# Cache meta information. #
###########################

sub count {
    my $self = shift;
    my $total = 0;

    my $db = $self->{__db};
    my $stats = $db->db_stat;
    my $type = $db->type;

    $total =  ($type == DB_HASH) ? 
      $stats->{hash_ndata} : $stats->{bt_ndata};

    return $total;
}

sub size {
    my $self = shift;
    
    my $db = $self->{__db};

    eval { require Devel::Size };
    if($@) {
      warn "size() currently requires Devel::Size";
      return 0;
    }
    else {
      import Devel::Size qw(total_size);
    }
    
    my ($k, $v) = ('','');
    my $size = 0;

    my $cursor = $self->{__db}->db_cursor();
    while($cursor->c_get($k, $v, DB_NEXT) == 0) {
	$size += total_size($v->{__data});
    }

    $cursor->c_close();
    return $size;
}

##############################################
# Methods for removing items from the cache. #
##############################################

sub remove {
    my ($self, $key) = @_;

    my $rv;
    my $v = '';
    my $db = $self->{__db};
    $rv = $db->db_del($key);

    warn "compaction failed!" if $self->_compact();

    return $rv ? 0 : 1;
}

*delete = \&remove;  

sub clear {
    my $self = shift;
    my $rv;

    my $count = 0;
    my $db = $self->{__db};
    $rv = $db->truncate($count);

    warn "compaction failed!" if $self->_compact();

    return $count;
}

sub purge {
    my $self = shift;
    my $t = time();
    my $count = 0;
    
    my $db = $self->{__db};
    my $cursor = $db->db_cursor(DB_WRITECURSOR);

    my ($k, $v) = ('','');
    while($cursor->c_get($k, $v, DB_NEXT) == 0) {
      if($self->__is_expired($v, $t)) {
	$cursor->c_del();
	$count++;
      }
    }
    $cursor->c_close();

    warn "compaction failed!" if $self->_compact();

    return $count;
}

sub __is_expired {
    my ($self, $data, $t) = @_;
    $t ||= time();

    return 1 if($data->{__expires} && $data->{__expires} < $t);
    return 0;
}

sub is_expired {
    my ($self, $key) = @_;

    my $data;
    my $t = time();
    return 0 unless $key;
    my $db = $self->{__db};
    my $rv = $db->db_get($key, $data);

    return 0 unless $data;
    return $self->__is_expired($data, $t);
}

sub _compact {
  my $self = shift;

  my $rv = 0; # assume success, if compact isn't available pretend its cool
  my $db = $self->{__db};
  if($db->can('compact') && 
     $db->type == DB_BTREE && 
     !$self->{disable_compact}) {
    $rv = $db->compact(undef, undef, undef, DB_FREE_SPACE, undef);
  }
  return $rv;
}

1;