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