view release on metacpan or  search on metacpan

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

# MMapDB uses btrees. hence, keys are already ordered
sub list_keys {
  my ($I)=@_;
  my $k=$I->basekey;
  my $db=$I->_db;
  my ($idx)=$db->index_lookup($db->mainidx, @$k, 'actn');
  return unless defined $idx;
  my @res;
  for( my $it=$db->index_iterator($idx); my ($key)=$it->(); ) {
    push @res, [$key];
  }
  return @res;
}

# MMapDB uses btrees. hence, keys are already ordered
sub list_keys_and_uris {
  my ($I, $key)=@_;

  my $k=$I->basekey;
  my $db=$I->_db;

  my @res;
  if( length $key ) {
    my ($idx)=$db->index_lookup($db->mainidx, @$k, 'actn', $key);
    return unless defined $idx;
    for( my $it=$db->index_iterator($idx); my ($subkey)=$it->(); ) {
      push @res, [$key, $subkey];
    }
  } else {
    my ($idx)=$db->index_lookup($db->mainidx, @$k, 'actn');
    return unless defined $idx;
    for( my $it=$db->index_iterator($idx); ($key, $idx)=$it->(); ) {
      for( my $jt=$db->index_iterator($idx); my ($subkey)=$jt->(); ) {
	push @res, [$key, $subkey];
      }
    }
  }
  return @res;
}

sub begin {
  my ($I)=@_;
  die "ERROR: read-only mode\n" if( $I->readonly );
  $I->_db->begin;
}

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

  $I->_db->commit;
  return "0 but true";
}

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

  $I->_db->rollback;
  return "0 but true";
}

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

  return $I->insert($new) if $I->delete($old)>0;
  return "0 but true";
}

sub insert {
  my $I=shift;
  my $new=shift;

  die "ERROR: KEY must not contain spaces.\n" if( $new->[nKEY]=~/\s/ );
  die "ERROR: URI must not contain spaces.\n" if( $new->[nURI]=~/\s/ );

  $I->_db->insert([[@{$I->basekey}, 'actn', $new->[nKEY], $new->[nURI]],
		   pack("N2", @{$new}[nBLOCK, nORDER]), $new->[nACTION]]);
  if( length $new->[nNOTE] ) {
    $I->_db->insert([[@{$I->basekey}, 'note', $new->[nKEY], $new->[nURI]],
		     pack("N2", @{$new}[nBLOCK, nORDER]), $new->[nNOTE]]);
  }

  return 1;
}

sub delete {
  my $I=shift;
  my $old=shift;

  my $db=$I->_db;
  my $r=$db->data_record( $db->id_index_lookup($old->[oID]) );
  return "0 but true" unless( $r );

  my $ouri=pop @{$r->[0]};
  my $okey=pop @{$r->[0]};
  my $sort=pack('N2', @{$old}[oBLOCK, oORDER]);
  if( $okey eq $old->[oKEY] and
      $ouri eq $old->[oURI] and
      $sort eq $r->[1] ) {
    $db->delete_by_id($old->[oID]);

    # delete note if any
    foreach my $pos ($db->index_lookup($db->mainidx, @{$I->basekey},
				       'note', $okey, $ouri)) {
      $r=$db->data_record( $pos );
      if( $r->[1] eq $sort ) {
	$db->delete_by_id($r->[3]);
	last;
      } elsif($r->[1] gt $sort) {
	last;
      }
    }

    return 1;
  }

  return "0 but true" unless( $r );
}

sub clear {