view release on metacpan or  search on metacpan

lib/Apache2/Translation/BDB.pm  view on Meta::CPAN

}

sub list_keys {
  my $I=$_[0];

  my (%h, $k, $v, $c, $stat);
  $c=$I->_db2->db_cursor;
  for( $stat=$c->c_get($k, $v, DB_FIRST);
       $stat==0;
       $stat=$c->c_get($k, $v, DB_NEXT_NODUP) ) {
    undef $h{(split /\t/, $k)[0]};
  }

  return map {[$_]} sort keys %h;
}

sub list_keys_and_uris {
  my ($I,$key)=@_;
  $key='' unless( defined $key );

  my (@l, $k, $v, $c, $stat);
  $c=$I->_db2->db_cursor;

  for( $stat=$c->c_get($k, $v, DB_FIRST);
       $stat==0;
       $stat=$c->c_get($k, $v, DB_NEXT_NODUP) ) {
    my @v=split /\t/, $k;
    push @l, [@v] if( !length($key) or $key eq $v[0] );
  }
  return sort {$a->[0] cmp $b->[0] or $a->[1] cmp $b->[1]} @l;
}

sub begin {
  my ($I)=@_;

  $I->_txn=$I->bdbenv->txn_begin
    ( $I->parent_txn ? $I->parent_txn : undef, DB_TXN_NOSYNC );
  die "ERROR: Cannot create transaction: $BerkeleyDB::Error\n"
    unless( defined $I->_txn );
  $I->_txn->Txn($I->_db1, $I->_db2, $I->extra_db);
}

sub commit {
  my ($I)=@_;

  my $rc=!$I->_txn->txn_commit;
  undef $I->_txn;
  $I->bdbenv->txn_checkpoint(0,0);
  return $rc;
}

sub rollback {
  my ($I)=@_;

  return unless( $I->_txn );
  my $rc=!$I->_txn->txn_abort;
  undef $I->_txn;
  return $rc;
}

sub update {
  my $I=shift;
  my $old=shift;
  my $new=shift;

  my ($v, $c, $stat, $rc);
  $c=$I->_db1->db_cursor;

  if( ($rc=$c->c_get($old->[oID], $v, DB_SET))==0 ) {
    my $el=decode($v);
    if( $el->[BLOCK]==$old->[oBLOCK] and $el->[ORDER]==$old->[oORDER] ) {
      @{$el}[BLOCK,ORDER,ACTION,KEY,URI,NOTE]=
	@{$new}[nBLOCK,nORDER,nACTION,nKEY,nURI,nNOTE];
      $rc=$c->c_put($old->[oID],
		    encode($el),
		    DB_CURRENT);
      die "__RETRY__\n" if( $rc==DB_LOCK_DEADLOCK );
      return $rc==0 ? 1 : 0;
    }
  } elsif( $rc==DB_LOCK_DEADLOCK ) {
    die "__RETRY__\n" if( $rc==DB_LOCK_DEADLOCK );
  }
  return "0 but true";
}

sub insert {
  my ($I, $new)=@_;

  # fetch a new id
  my ($k, $v, $c, $id, $rc);
  $c=$I->extra_db->db_cursor;
  if( ($rc=$c->c_get($k='id_seq', $v, DB_SET))==0 ) {
    $rc=$c->c_put( $k, $id=$v+1, DB_CURRENT );
  } else {
    die "__RETRY__\n" if( $rc==DB_LOCK_DEADLOCK );
    $rc=$I->extra_db->db_put( $k, $id=1 );
  }
  die "__RETRY__\n" if( $rc==DB_LOCK_DEADLOCK );

  my $el=[];
  @{$el}[BLOCK,ORDER,ACTION,KEY,URI,NOTE,ID]=
    (@{$new}[nBLOCK,nORDER,nACTION,nKEY,nURI,nNOTE], $id);

  $rc=$I->_db1->db_put( $id, encode($el) );
  die "__RETRY__\n" if( $rc==DB_LOCK_DEADLOCK );
  return $rc==0 ? 1 : 0;
}

sub delete {
  my ($I, $old)=@_;

  my ($v, $c, $stat, $rc);
  $c=$I->_db1->db_cursor;

  if( ($rc=$c->c_get($old->[oID], $v, DB_SET))==0 ) {
    my $el=decode($v);
    if( $el->[BLOCK]==$old->[oBLOCK] and $el->[ORDER]==$old->[oORDER] ) {
      $rc=$c->c_del;
      die "__RETRY__\n" if( $rc==DB_LOCK_DEADLOCK );
      return $rc==0 ? 1 : 0;
    }