lib/Onis/Data/Persistent/Dbm.pm

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