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