lib/Onis/Data/Persistent/Dbm.pm

   1 package Onis::Data::Persistent::Dbm;
   2
   3 use strict;
   4 use warnings;
   5
   6 BEGIN
   7 {
   8         @AnyDBM_File::ISA = (qw(DB_File GDBM_File SDBM_File NDBM_File ODBM_File));
   9 }
  10
  11 use Carp qw(carp confess);
  12 use Fcntl (qw(O_RDWR O_CREAT));
  13 use AnyDBM_File;
  14
  15 use Onis::Config (qw(get_config));
  16
  17 =head1 NAME
  18
  19 Onis::Data::Persistent::Dbm - Storage backend using AnyDBM_File.
  20
  21 =head1 DESCRIPTION
  22
  23 Storage backend that uses DBM files for storing data permanently.
  24
  25 =head1 CONFIGURATION OPTIONS
  26
  27 =over 4
  28
  29 =item B<dbm_directory>: I<E<lt>dirE<gt>>
  30
  31 Directory in which the DBM-files are kept. Defaults to the B<var>-directory in
  32 onis' main directory..
  33
  34 =back
  35
  36 =cut
  37
  38 our $DBMDirectory = get_config ('dbm_directory') || 'var';
  39 $DBMDirectory =~ s#/$##g;
  40
  41 if (!$DBMDirectory or !-d $DBMDirectory)
  42 {
  43         print STDERR <<ERROR;
  44 The directory ``$DBMDirectory'' does not exist or is not useable. Please
  45 create it before running onis.
  46 ERROR
  47         exit (1);
  48 }
  49
  50 our $Alarm = chr (7);
  51 our %Objects = ();
  52
  53 if ($::DEBUG & 0x0200)
  54 {
  55         require Data::Dumper;
  56 }
  57
  58 return (1);
  59
  60 sub new
  61 {
  62         my $pkg    = shift;
  63         my $name   = shift;
  64         my $key    = shift;
  65         my @fields = @_;
  66         my $caller = caller ();
  67         my $obj    = {};
  68         my %hash;
  69         my $i = 0;
  70         my $filename;
  71
  72         my $id = $caller . ':' . $name;
  73         $id =~ s#/##g;
  74
  75         $filename = "$DBMDirectory/$id.dbm";
  76
  77         if (exists ($Objects{$id}))
  78         {
  79                 print STDERR $/, __FILE__, ": Name $name has been used in context $caller before.";
  80                 return (undef);
  81         }
  82
  83         no strict (qw(subs));
  84         tie (%hash, 'AnyDBM_File', $filename, O_RDWR | O_CREAT, 0666) or die ("tie: $!");
  85
  86         $obj->{'data'} = tied %hash;
  87         $obj->{'key'} = $key;
  88         $obj->{'fields'} = [@fields];
  89         $obj->{'num_fields'} = scalar (@fields);
  90         $obj->{'field_index'} = {map { $_ => $i++ } (@fields)};
  91         $obj->{'id'} = $id;
  92         $obj->{'cache'} = {};
  93
  94         if ($::DEBUG & 0x0200)
  95         {
  96                 my $prefix = __FILE__ . ': ';
  97                 my $dbg = Data::Dumper->Dump ([$obj], ['obj']);
  98                 $dbg =~ s/^/$prefix/mg; chomp ($dbg);
  99                 print STDOUT $/, $dbg;
 100         }
 101
 102         $Objects{$id} = bless ($obj, $pkg);
 103         return ($Objects{$id});
 104 }
 105
 106 sub put
 107 {
 108         my $obj    = shift;
 109         my $key    = shift;
 110         my @fields = @_;
 111
 112         if ($obj->{'num_fields'} != scalar (@fields))
 113         {
 114                 my $id = $obj->{'id'};
 115                 carp ("Number of fields do not match ($id).");
 116                 return;
 117         }
 118
 119         if ($::DEBUG & 0x0200)
 120         {
 121                 print STDOUT $/, __FILE__, ': PUT(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @fields) . ')';
 122         }
 123
 124         $obj->{'cache'}{$key} = [@fields];
 125 }
 126
 127 sub get
 128 {
 129         my $obj = shift;
 130         my $key = shift;
 131         my $val;
 132         my @ret;
 133         my $db = $obj->{'data'};
 134
 135         if (!exists ($obj->{'cache'}{$key}))
 136         {
 137                 $val = $db->FETCH ($key);
 138                 if (!defined ($val))
 139                 {
 140                         $obj->{'cache'}{$key} = undef;
 141                 }
 142                 else
 143                 {
 144                         $obj->{'cache'}{$key} = [split ($Alarm, $val)];
 145                 }
 146         }
 147
 148         if (!defined ($obj->{'cache'}{$key}))
 149         {
 150                 return (qw());
 151         }
 152         else
 153         {
 154                 @ret = @{$obj->{'cache'}{$key}};
 155         }
 156
 157         if ($::DEBUG & 0x0200)
 158         {
 159                 print STDOUT $/, __FILE__, ': GET(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @ret) . ')';
 160         }
 161
 162         return (@ret);
 163 }
 164
 165 sub keys
 166 {
 167         my $obj = shift;
 168         my @fields = @_;
 169         my @field_indizes = ();
 170         my $db = $obj->{'data'};
 171         my $key;
 172         my $val;
 173
 174         no strict (qw(subs));
 175         for (($key, $val) = $db->FIRSTKEY (); defined ($key) and defined ($val); ($key, $val) = $db->NEXTKEY ($key))
 176         {
 177                 next if (defined ($obj->{'cache'}{$key}));
 178
 179                 $obj->{'cache'}{$key} = [split ($Alarm, $val)];
 180         }
 181
 182         if (!@fields)
 183         {
 184                 return (keys %{$obj->{'cache'}});
 185         }
 186
 187         for (@fields)
 188         {
 189                 my $field = $_;
 190                 if (!defined ($obj->{'field_index'}{$field}))
 191                 {
 192                         my $id = $obj->{'id'};
 193                         print STDERR $/, __FILE__, ": $field is not a valid field ($id).";
 194                         next;
 195                 }
 196                 push (@field_indizes, $obj->{'field_index'}{$field});
 197         }
 198
 199         return (sort
 200         {
 201                 for (@field_indizes)
 202                 {
 203                         my $d = $obj->{'cache'}{$a}[$_] cmp $obj->{'cache'}{$b}[$_];
 204                         return ($d) if ($d);
 205                 }
 206         } (keys %{$obj->{'cache'}}));
 207 }
 208
 209 sub del
 210 {
 211         my $obj = shift;
 212         my $key = shift;
 213         my $db = $obj->{'data'};
 214
 215         if (exists ($obj->{'cache'}{$key}))
 216         {
 217                 if (defined ($obj->{'cache'}{$key}))
 218                 {
 219                         $db->DELETE ($key);
 220                         $obj->{'cache'}{$key} = undef;
 221                 }
 222                 # It's known that the key doesn't exist..
 223         }
 224         else
 225         {
 226                 $db->DELETE ($key);
 227                 $obj->{'cache'}{$key} = undef;
 228         }
 229 }
 230
 231 sub sync
 232 {
 233         my $obj = shift;
 234         my $db = $obj->{'data'};
 235
 236         for (CORE::keys %{$obj->{'cache'}})
 237         {
 238                 my $key = $_;
 239                 next unless (defined ($obj->{'cache'}{$key}));
 240
 241                 my $val = join ($Alarm, @{$obj->{'cache'}{$key}});
 242
 243                 $db->STORE ($key, $val);
 244                 delete ($obj->{'cache'}{$key});
 245         }
 246
 247         $db->sync ();
 248 }
 249
 250 END
 251 {
 252         for (CORE::keys (%Objects))
 253         {
 254                 my $key = $_;
 255                 my $obj = $Objects{$key};
 256                 $obj->sync ();
 257         }
 258 }
 259
 260 =head1 AUTHOR
 261
 262 Florian octo Forster, L<octo at verplant.org>
 263
 264 =cut