6f84492c016b736962ccc8b8913e0866e672c296
7 # (c) 2004 Straylight/Edgeware
10 #----- Licensing notice -----------------------------------------------------
12 # This file is part of the Perl interface to Catacomb.
14 # Catacomb/Perl is free software; you can redistribute it and/or modify
15 # it under the terms of the GNU General Public License as published by
16 # the Free Software Foundation; either version 2 of the License, or
17 # (at your option) any later version.
19 # Catacomb/Perl is distributed in the hope that it will be useful,
20 # but WITHOUT ANY WARRANTY; without even the implied warranty of
21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 # GNU General Public License for more details.
24 # You should have received a copy of the GNU General Public License
25 # along with Catacomb/Perl; if not, write to the Free Software Foundation,
26 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 #----- Key data -------------------------------------------------------------
30 package Catacomb
::Key
::StructData
;
34 sub TIEHASH
{ bless [$_[1], []], $_[0]; }
35 sub FETCH
{ Catacomb
::Key
::Data
::StructItem
->new($_[0][0], $_[1]); }
36 sub EXISTS
{ !!$_[0][0]->_get->structfind($_[1]); }
37 sub DELETE
{ $_[0][0]->_get->structdel($_[1]); }
38 sub CLEAR
{ $_[0][0]->_get()->setstruct(); }
40 my ($me, $k, $v) = @_;
41 $me->[0]->_get()->structcreate($k)->set($v);
45 my $kd = $me->[0]->_get();
46 my $i = $kd->structiter();
48 while (my $k = $i->next()) {
54 sub NEXTKEY
{ shift(@
{$_[0][1]}); }
56 package Catacomb
::Key
::DataRef
;
63 defined($kd) or return;
64 $kd = bless [$kd], Catacomb
::Key
::Data
;
65 return wantarray ?
($kd, @_) : $kd;
67 sub new
{ my $me = shift(@_); bless [@_], $me; }
68 sub _proxy
{ my ($op, $kd, @args) = @_; &$op($kd->_get(), @args); }
70 sub setbinary
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::setbinary
, @_); }
71 sub setencrypted
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::setencrypted
, @_); }
72 sub setmp
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::setec
, @_); }
73 sub setstring
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::setstring
, @_); }
74 sub setec
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::setec
, @_); }
76 sub flags
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::flags
, @_); }
78 sub getbinary
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::getbinary
, @_); }
79 sub getencrypted
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::getencrypted
, @_); }
80 sub getmp
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::getmp
, @_); }
81 sub getstring
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::getstring
, @_); }
82 sub getec
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::getec
, @_); }
84 sub setstruct
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::setstruct
, @_); }
85 sub structfind
{ Catacomb
::Key
::Data
::StructItem
->new($_[0], $_[1]); }
87 _proxy
(\
&Catacomb
::Key
::DataImpl
::structcreate
, @_);
88 Catacomb
::Key
::Data
::StructItem
->new($_[0], $_[1]);
90 sub structiter
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::structiter
, @_); }
91 sub structdel
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::structdel
, @_); }
92 sub structopen
{ my %h; tie
%h, Catacomb
::Key
::StructData
, $_[0]; \
%h; }
95 croak
("Usage: Catacomb::Key::Data::Ref::copy(kd, kkd, [filter])")
96 unless @_ >= 2 && @_ <= 3;
97 my $kd = Catacomb
::Key
::Data
->new();
98 $kd->_get()->set($_[0]->_get(), $_[1]);
101 sub lock { _adopt
(_proxy
(\
&Catacomb
::Key
::DataImpl
::lock, @_)); }
102 sub unlock
{ _adopt
(_proxy
(\
&Catacomb
::Key
::DataImpl
::unlock
, @_)); }
103 sub plock
{ _adopt
(_proxy
(\
&Catacomb
::Key
::DataImpl
::plock
, @_)); }
104 sub punlock
{ _adopt
(_proxy
(\
&Catacomb
::Key
::DataImpl
::punlock
, @_)); }
105 sub read { _adopt
(Catacomb
::Key
::DataImpl
::read(@_)); }
106 sub write { _proxy
(\
&Catacomb
::Key
::DataImpl
::write, @_); }
107 sub decode
{ _adopt
(Catacomb
::Key
::DataImpl
::decode
(@_)); }
108 sub encode
{ _proxy
(\
&Catacomb
::Key
::DataImpl
::encode
, @_); }
110 package Catacomb
::Key
::Data
;
112 @ISA = qw(Catacomb
::Key
::DataRef
);
113 sub _get
{ $_[0][0]; }
114 ## Perl will randomly zap my reference during cleanup. Just pretend
116 sub DESTROY
{ $_[0][0]->free() if defined $_[0][0]; }
118 croak
("Usage: Catacomb::Key::Data::new(me)") unless @_ == 1;
119 Catacomb
::Key
::DataRef
::_adopt
(Catacomb
::Key
::DataImpl
->new());
122 package Catacomb
::Key
::Data
::StructItem
;
123 @ISA = qw(Catacomb
::Key
::DataRef
);
124 sub _get
{ $_[0][0]->_get()->structfind($_[0][1]); }
126 package Catacomb
::Key
::Data
::KeyData
;
127 @ISA = qw(Catacomb
::Key
::DataRef
);
128 sub _get
{ $_[0][0]->_data(); }
130 #----- Actual keys ----------------------------------------------------------
132 package Catacomb
::Key
::Attrs
;
135 sub TIEHASH
{ bless [$_[1], []], $_[0]; }
136 sub FETCH
{ $_[0][0]->getattr($_[1]); }
137 sub EXISTS
{ defined($_[0][0]->getattr($_[1])); }
138 sub STORE
{ $_[0][0]->putattr($_[1], $_[2]); }
139 sub DELETE
{ $_[0][0]->putattr($_[1]); }
143 my $i = $k->attriter();
145 while (my $a = $i->next()) { push(@a, $a); }
149 sub NEXTKEY
{ shift(@
{$_[0][1]}); }
151 package Catacomb
::Key
;
154 croak
("Usage: Catacomb::Key::attrs(k)") unless @_ == 1;
156 tie
%a, Catacomb
::Key
::Attrs
, @_;
161 croak
("Usage: Catacomb::Key::data(k)") unless @_ == 1;
162 return Catacomb
::Key
::Data
::KeyData
->new($_[0]);
165 package Catacomb
::Key
::File
;
170 croak
("Usage: Catacomb::Key::File::qtag(kf, tag)") unless @_ == 2;
173 if ($tag =~ /^([^.]*)\.(.*)$/) {
175 @q = split(/\./, $2);
177 my $k = $kf->bytag($tag) or return;
179 my $f = $k->fulltag();
181 $d = $d->structfind($t) or return;
187 #----- That's all, folks ----------------------------------------------------