X-Git-Url: https://git.distorted.org.uk/~mdw/catacomb-perl/blobdiff_plain/f9952aec1cf6c64a5681308eea817b6113a37433..fcd15e0b7a3d0f0ca2f30953573f8d1f6b8e8bd2:/Catacomb/Key.pm

diff --git a/Catacomb/Key.pm b/Catacomb/Key.pm
new file mode 100644
index 0000000..6f84492
--- /dev/null
+++ b/Catacomb/Key.pm
@@ -0,0 +1,189 @@
+# -*-perl-*-
+#
+# $Id$
+#
+# Key management
+#
+# (c) 2004 Straylight/Edgeware
+#
+
+#----- Licensing notice -----------------------------------------------------
+#
+# This file is part of the Perl interface to Catacomb.
+#
+# Catacomb/Perl is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+# 
+# Catacomb/Perl is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+# 
+# You should have received a copy of the GNU General Public License
+# along with Catacomb/Perl; if not, write to the Free Software Foundation,
+# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+#----- Key data -------------------------------------------------------------
+
+package Catacomb::Key::StructData;
+use Carp;
+use Catacomb::Base;
+
+sub TIEHASH { bless [$_[1], []], $_[0]; }
+sub FETCH { Catacomb::Key::Data::StructItem->new($_[0][0], $_[1]); }
+sub EXISTS { !!$_[0][0]->_get->structfind($_[1]); }
+sub DELETE { $_[0][0]->_get->structdel($_[1]); }
+sub CLEAR { $_[0][0]->_get()->setstruct(); }
+sub STORE {
+  my ($me, $k, $v) = @_;
+  $me->[0]->_get()->structcreate($k)->set($v);
+}
+sub FIRSTKEY {
+  my ($me) = @_;
+  my $kd = $me->[0]->_get();
+  my $i = $kd->structiter();
+  my @k = ();
+  while (my $k = $i->next()) {
+    push(@k, $k);
+  }
+  $me->[1] = \@k;
+  return shift(@k);
+}
+sub NEXTKEY { shift(@{$_[0][1]}); }
+
+package Catacomb::Key::DataRef;
+use Carp;
+use Catacomb::Base;
+use Catacomb::MP;
+use Catacomb::EC;
+sub _adopt {
+  my $kd = shift;
+  defined($kd) or return;
+  $kd = bless [$kd], Catacomb::Key::Data;
+  return wantarray ? ($kd, @_) : $kd;
+}
+sub new { my $me = shift(@_); bless [@_], $me; }
+sub _proxy { my ($op, $kd, @args) = @_; &$op($kd->_get(), @args); }
+
+sub setbinary { _proxy(\&Catacomb::Key::DataImpl::setbinary, @_); }
+sub setencrypted { _proxy(\&Catacomb::Key::DataImpl::setencrypted, @_); }
+sub setmp { _proxy(\&Catacomb::Key::DataImpl::setec, @_); }
+sub setstring { _proxy(\&Catacomb::Key::DataImpl::setstring, @_); }
+sub setec { _proxy(\&Catacomb::Key::DataImpl::setec, @_); }
+
+sub flags { _proxy(\&Catacomb::Key::DataImpl::flags, @_); }
+
+sub getbinary { _proxy(\&Catacomb::Key::DataImpl::getbinary, @_); }
+sub getencrypted { _proxy(\&Catacomb::Key::DataImpl::getencrypted, @_); }
+sub getmp { _proxy(\&Catacomb::Key::DataImpl::getmp, @_); }
+sub getstring { _proxy(\&Catacomb::Key::DataImpl::getstring, @_); }
+sub getec { _proxy(\&Catacomb::Key::DataImpl::getec, @_); }
+
+sub setstruct { _proxy(\&Catacomb::Key::DataImpl::setstruct, @_); }
+sub structfind { Catacomb::Key::Data::StructItem->new($_[0], $_[1]); }
+sub structcreate {
+  _proxy(\&Catacomb::Key::DataImpl::structcreate, @_);
+  Catacomb::Key::Data::StructItem->new($_[0], $_[1]);
+}
+sub structiter { _proxy(\&Catacomb::Key::DataImpl::structiter, @_); }
+sub structdel { _proxy(\&Catacomb::Key::DataImpl::structdel, @_); }
+sub structopen {  my %h; tie %h, Catacomb::Key::StructData, $_[0]; \%h; }
+
+sub copy {
+  croak("Usage: Catacomb::Key::Data::Ref::copy(kd, kkd, [filter])")
+    unless @_ >= 2 && @_ <= 3;
+  my $kd = Catacomb::Key::Data->new();
+  $kd->_get()->set($_[0]->_get(), $_[1]);
+  return $kd;
+}
+sub lock { _adopt(_proxy(\&Catacomb::Key::DataImpl::lock, @_)); }
+sub unlock { _adopt(_proxy(\&Catacomb::Key::DataImpl::unlock, @_)); }
+sub plock { _adopt(_proxy(\&Catacomb::Key::DataImpl::plock, @_)); }
+sub punlock { _adopt(_proxy(\&Catacomb::Key::DataImpl::punlock, @_)); }
+sub read { _adopt(Catacomb::Key::DataImpl::read(@_)); }
+sub write { _proxy(\&Catacomb::Key::DataImpl::write, @_); }
+sub decode { _adopt(Catacomb::Key::DataImpl::decode(@_)); }
+sub encode { _proxy(\&Catacomb::Key::DataImpl::encode, @_); }
+
+package Catacomb::Key::Data;
+use Carp;
+@ISA = qw(Catacomb::Key::DataRef);
+sub _get { $_[0][0]; }
+## Perl will randomly zap my reference during cleanup.  Just pretend
+## we didn't notice.
+sub DESTROY { $_[0][0]->free() if defined $_[0][0]; }
+sub new {
+  croak("Usage: Catacomb::Key::Data::new(me)") unless @_ == 1;
+  Catacomb::Key::DataRef::_adopt(Catacomb::Key::DataImpl->new());
+}
+
+package Catacomb::Key::Data::StructItem;
+@ISA = qw(Catacomb::Key::DataRef);
+sub _get { $_[0][0]->_get()->structfind($_[0][1]); }
+
+package Catacomb::Key::Data::KeyData;
+@ISA = qw(Catacomb::Key::DataRef);
+sub _get { $_[0][0]->_data(); }
+
+#----- Actual keys ----------------------------------------------------------
+
+package Catacomb::Key::Attrs;
+use Carp;
+
+sub TIEHASH { bless [$_[1], []], $_[0]; }
+sub FETCH { $_[0][0]->getattr($_[1]); }
+sub EXISTS { defined($_[0][0]->getattr($_[1])); }
+sub STORE { $_[0][0]->putattr($_[1], $_[2]); }
+sub DELETE { $_[0][0]->putattr($_[1]); }
+sub FIRSTKEY {
+  my ($me) = @_;
+  my $k = $me->[0];
+  my $i = $k->attriter();
+  my @a;
+  while (my $a = $i->next()) { push(@a, $a); }
+  $me->[1] = \@a;
+  return shift(@a);
+}
+sub NEXTKEY { shift(@{$_[0][1]}); }
+
+package Catacomb::Key;
+
+sub attrs {
+  croak("Usage: Catacomb::Key::attrs(k)") unless @_ == 1;
+  my %a;
+  tie %a, Catacomb::Key::Attrs, @_;
+  return \%a;
+}
+
+sub data {
+  croak("Usage: Catacomb::Key::data(k)") unless @_ == 1;
+  return Catacomb::Key::Data::KeyData->new($_[0]);
+}
+
+package Catacomb::Key::File;
+use Carp;
+use Catacomb::Base;
+
+sub qtag {
+  croak("Usage: Catacomb::Key::File::qtag(kf, tag)") unless @_ == 2;
+  my ($kf, $tag) = @_;
+  my @q = ();
+  if ($tag =~ /^([^.]*)\.(.*)$/) {
+    $tag = $1;
+    @q = split(/\./, $2);
+  }
+  my $k = $kf->bytag($tag) or return;
+  my $d = $k->data();
+  my $f = $k->fulltag();
+  foreach my $t (@q) {
+    $d = $d->structfind($t) or return;
+    $f .= "." . $t;
+  }
+  return $k, $d, $f;
+}
+
+#----- That's all, folks ----------------------------------------------------
+
+1;