1 package Onis::Data::Persistent::Dbm;
6 use Carp qw(carp confess);
9 use Onis::Config (qw(get_config));
13 Onis::Data::Persistent::Dbm - Storage backend using AnyDBM_File.
17 Storage backend that uses DBM files for storing data permanently.
19 =head1 CONFIGURATION OPTIONS
23 =item B<gdbm_directory>: I<E<lt>dirE<gt>>
25 Directory in which the GDBM-files are kept.
31 our $DBMDirectory = get_config ('gdbm_directory') || 'var';
32 $DBMDirectory =~ s#/$##g;
34 if (!$DBMDirectory or !-d $DBMDirectory)
37 The directory ``$DBMDirectory'' does not exist or is not useable. Please
38 create it before running onis.
46 if ($::DEBUG & 0x0200)
59 my $caller = caller ();
65 my $id = $caller . ':' . $name;
68 $filename = "$GDBMDirectory/$id.gdbm";
70 if (exists ($Objects{$id}))
72 print STDERR $/, __FILE__, ": Name $name has been used in context $caller before.";
78 $obj->{'data'} = tie (%hash, 'AnyDBM_File', $filename, O_CREAT|O_RDWR, 0664);
80 $obj->{'fields'} = [@fields];
81 $obj->{'num_fields'} = scalar (@fields);
82 $obj->{'field_index'} = {map { $_ => $i++ } (@fields)};
86 if ($::DEBUG & 0x0200)
88 my $prefix = __FILE__ . ': ';
89 my $dbg = Data::Dumper->Dump ([$obj], ['obj']);
90 $dbg =~ s/^/$prefix/mg; chomp ($dbg);
91 print STDOUT $/, $dbg;
94 return (bless ($obj, $pkg));
102 my $db = $obj->{'data'};
104 if ($obj->{'num_fields'} != scalar (@fields))
106 my $id = $obj->{'id'};
107 carp ("Number of fields do not match ($id).");
111 if ($::DEBUG & 0x0200)
113 print STDOUT $/, __FILE__, ': PUT(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @fields) . ')';
116 $obj->{'cache'}{$key} = [@fields];
125 my $db = $obj->{'data'};
127 if (!exists ($obj->{'cache'}{$key}))
129 if ($db->get ($key, $val))
131 $obj->{'cache'}{$key} = undef;
135 $obj->{'cache'}{$key} = [split ($Alarm, $val)];
139 if (!defined ($obj->{'cache'}{$key}))
145 @ret = @{$obj->{'cache'}{$key}};
148 if ($::DEBUG & 0x0200)
150 print STDOUT $/, __FILE__, ': GET(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @ret) . ')';
160 my @field_indizes = ();
161 my $db = $obj->{'data'};
165 for ($db->seq ($key, $val, R_FIRST); $db->seq ($key, $val, R_NEXT) == 0;)
167 next if (defined ($obj->{'cache'}{$key}));
168 $obj->{'cache'}{$key} = [split ($Alarm, $val)];
173 return (keys %{$obj->{'cache'}});
179 if (!defined ($obj->{'field_index'}{$field}))
181 my $id = $obj->{'id'};
182 print STDERR $/, __FILE__, ": $field is not a valid field ($id).";
185 push (@field_indizes, $obj->{'field_index'}{$field});
192 my $d = $obj->{'cache'}{$a}[$_] cmp $obj->{'cache'}{$b}[$_];
202 my $db = $obj->{'data'};
204 if (exists ($obj->{'cache'}{$key}))
206 if (defined ($obj->{'cache'}{$key}))
209 $obj->{'cache'}{$key} = undef;
211 # It's known that the key doesn't exist..
216 $obj->{'cache'}{$key} = undef;
223 my $db = $obj->{'data'};
225 for (keys %{$obj->{'cache'}})
228 my $val = join ($Alarm, @{$obj->{'cache'}{$key}});
230 $db->put ($key, $val);
231 delete ($obj->{'cache'}{$key});
239 for (keys (%Objects))
248 Florian octo Forster, L<octo at verplant.org>