fcd15e0b |
1 | # -*-perl-*- |
2 | # |
3 | # $Id$ |
4 | # |
5 | # Key management |
6 | # |
7 | # (c) 2004 Straylight/Edgeware |
8 | # |
9 | |
10 | #----- Licensing notice ----------------------------------------------------- |
11 | # |
12 | # This file is part of the Perl interface to Catacomb. |
13 | # |
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. |
18 | # |
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. |
23 | # |
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. |
27 | |
28 | #----- Key data ------------------------------------------------------------- |
29 | |
30 | package Catacomb::Key::StructData; |
31 | use Carp; |
32 | use Catacomb::Base; |
33 | |
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(); } |
39 | sub STORE { |
40 | my ($me, $k, $v) = @_; |
41 | $me->[0]->_get()->structcreate($k)->set($v); |
42 | } |
43 | sub FIRSTKEY { |
44 | my ($me) = @_; |
45 | my $kd = $me->[0]->_get(); |
46 | my $i = $kd->structiter(); |
47 | my @k = (); |
48 | while (my $k = $i->next()) { |
49 | push(@k, $k); |
50 | } |
51 | $me->[1] = \@k; |
52 | return shift(@k); |
53 | } |
54 | sub NEXTKEY { shift(@{$_[0][1]}); } |
55 | |
56 | package Catacomb::Key::DataRef; |
57 | use Carp; |
58 | use Catacomb::Base; |
59 | use Catacomb::MP; |
60 | use Catacomb::EC; |
61 | sub _adopt { |
62 | my $kd = shift; |
63 | defined($kd) or return; |
64 | $kd = bless [$kd], Catacomb::Key::Data; |
65 | return wantarray ? ($kd, @_) : $kd; |
66 | } |
67 | sub new { my $me = shift(@_); bless [@_], $me; } |
68 | sub _proxy { my ($op, $kd, @args) = @_; &$op($kd->_get(), @args); } |
69 | |
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, @_); } |
75 | |
76 | sub flags { _proxy(\&Catacomb::Key::DataImpl::flags, @_); } |
77 | |
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, @_); } |
83 | |
84 | sub setstruct { _proxy(\&Catacomb::Key::DataImpl::setstruct, @_); } |
85 | sub structfind { Catacomb::Key::Data::StructItem->new($_[0], $_[1]); } |
86 | sub structcreate { |
87 | _proxy(\&Catacomb::Key::DataImpl::structcreate, @_); |
88 | Catacomb::Key::Data::StructItem->new($_[0], $_[1]); |
89 | } |
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; } |
93 | |
94 | sub copy { |
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]); |
99 | return $kd; |
100 | } |
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, @_); } |
109 | |
110 | package Catacomb::Key::Data; |
111 | use Carp; |
112 | @ISA = qw(Catacomb::Key::DataRef); |
113 | sub _get { $_[0][0]; } |
114 | ## Perl will randomly zap my reference during cleanup. Just pretend |
115 | ## we didn't notice. |
116 | sub DESTROY { $_[0][0]->free() if defined $_[0][0]; } |
117 | sub new { |
118 | croak("Usage: Catacomb::Key::Data::new(me)") unless @_ == 1; |
119 | Catacomb::Key::DataRef::_adopt(Catacomb::Key::DataImpl->new()); |
120 | } |
121 | |
122 | package Catacomb::Key::Data::StructItem; |
123 | @ISA = qw(Catacomb::Key::DataRef); |
124 | sub _get { $_[0][0]->_get()->structfind($_[0][1]); } |
125 | |
126 | package Catacomb::Key::Data::KeyData; |
127 | @ISA = qw(Catacomb::Key::DataRef); |
128 | sub _get { $_[0][0]->_data(); } |
129 | |
130 | #----- Actual keys ---------------------------------------------------------- |
131 | |
132 | package Catacomb::Key::Attrs; |
133 | use Carp; |
134 | |
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]); } |
140 | sub FIRSTKEY { |
141 | my ($me) = @_; |
142 | my $k = $me->[0]; |
143 | my $i = $k->attriter(); |
144 | my @a; |
145 | while (my $a = $i->next()) { push(@a, $a); } |
146 | $me->[1] = \@a; |
147 | return shift(@a); |
148 | } |
149 | sub NEXTKEY { shift(@{$_[0][1]}); } |
150 | |
151 | package Catacomb::Key; |
152 | |
153 | sub attrs { |
154 | croak("Usage: Catacomb::Key::attrs(k)") unless @_ == 1; |
155 | my %a; |
156 | tie %a, Catacomb::Key::Attrs, @_; |
157 | return \%a; |
158 | } |
159 | |
160 | sub data { |
161 | croak("Usage: Catacomb::Key::data(k)") unless @_ == 1; |
162 | return Catacomb::Key::Data::KeyData->new($_[0]); |
163 | } |
164 | |
165 | package Catacomb::Key::File; |
166 | use Carp; |
167 | use Catacomb::Base; |
168 | |
169 | sub qtag { |
170 | croak("Usage: Catacomb::Key::File::qtag(kf, tag)") unless @_ == 2; |
171 | my ($kf, $tag) = @_; |
172 | my @q = (); |
173 | if ($tag =~ /^([^.]*)\.(.*)$/) { |
174 | $tag = $1; |
175 | @q = split(/\./, $2); |
176 | } |
177 | my $k = $kf->bytag($tag) or return; |
178 | my $d = $k->data(); |
179 | my $f = $k->fulltag(); |
180 | foreach my $t (@q) { |
181 | $d = $d->structfind($t) or return; |
182 | $f .= "." . $t; |
183 | } |
184 | return $k, $d, $f; |
185 | } |
186 | |
187 | #----- That's all, folks ---------------------------------------------------- |
188 | |
189 | 1; |