lib/Onis/Data/Persistent/Gdbm.pm

   1 package Onis::Data::Persistent::Gdbm;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp qw(carp confess);
   7 use GDBM_File;
   8
   9 use Onis::Config (qw(get_config));
  10
  11 =head1 NAME
  12
  13 Onis::Data::Persistent::Gdbm - Storage backend using GDBM_File.
  14
  15 =head1 DESCRIPTION
  16
  17 Storage backend that uses GDBM 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 $Alarm = chr (7);
  32
  33 our $GDBMDirectory = get_config ('gdbm_directory') || 'var';
  34 $GDBMDirectory =~ s#/$##g;
  35
  36 if (!$GDBMDirectory or !-d $GDBMDirectory)
  37 {
  38         print STDERR <<ERROR;
  39 The directory ``$GDBMDirectory'' does not exist or is not useable. Please
  40 create it before running onis.
  41 ERROR
  42         exit (1);
  43 }
  44
  45 our %Tables = ();
  46
  47 if ($::DEBUG & 0x0200)
  48 {
  49         require Data::Dumper;
  50 }
  51
  52 return (1);
  53
  54 sub new
  55 {
  56         my $pkg    = shift;
  57         my $name   = shift;
  58         my $key    = shift;
  59         my @fields = @_;
  60         my $caller = caller ();
  61         my $obj    = {};
  62         my %hash;
  63         my $i = 0;
  64         my $filename;
  65
  66         my $id = $caller . ':' . $name;
  67
  68         $filename = "$GDBMDirectory/$id.gdbm";
  69
  70         if (exists ($Tables{$id}))
  71         {
  72                 print STDERR $/, __FILE__, ": Name $name has been used in context $caller before.";
  73                 return (undef);
  74         }
  75
  76         $Tables{$id} = tie (%hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0664);
  77
  78         $obj->{'data'} = $Tables{$id};
  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
  85         if ($::DEBUG & 0x0200)
  86         {
  87                 my $prefix = __FILE__ . ': ';
  88                 my $dbg = Data::Dumper->Dump ([$obj], ['obj']);
  89                 $dbg =~ s/^/$prefix/mg; chomp ($dbg);
  90                 print STDOUT $/, $dbg;
  91         }
  92
  93         return (bless ($obj, $pkg));
  94 }
  95
  96 sub put
  97 {
  98         my $obj    = shift;
  99         my $key    = shift;
 100         my @fields = @_;
 101
 102         if ($obj->{'num_fields'} != scalar (@fields))
 103         {
 104                 my $id = $obj->{'id'};
 105                 carp ("Number of fields do not match ($id).");
 106                 return;
 107         }
 108
 109         if ($::DEBUG & 0x0200)
 110         {
 111                 print STDOUT $/, __FILE__, ': PUT(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @fields) . ')';
 112         }
 113
 114         $obj->{'data'}{$key} = join ($Alarm, @fields);
 115 }
 116
 117 sub get
 118 {
 119         my $obj = shift;
 120         my $key = shift;
 121         my @ret;
 122
 123         if (!exists ($obj->{'data'}{$key}))
 124         {
 125                 return (qw());
 126         }
 127
 128         @ret = split ($Alarm, $obj->{'data'}{$key});
 129
 130         if ($::DEBUG & 0x0200)
 131         {
 132                 print STDOUT $/, __FILE__, ': GET(', $obj->{'id'}, ', ', $key, ') = (' . join (', ', @ret) . ')';
 133         }
 134
 135         return (@ret);
 136 }
 137
 138 sub keys
 139 {
 140         my $obj = shift;
 141         my @fields = @_;
 142         my @field_indizes = ();
 143         my @keys = keys %{$obj->{'data'}};
 144         my $data = {};
 145
 146         if (!@fields)
 147         {
 148                 return (@keys);
 149         }
 150
 151         for (@keys)
 152         {
 153                 $data->{$_} = [split ($Alarm, $obj->{'data'}{$_})];
 154         }
 155
 156         for (@fields)
 157         {
 158                 my $field = $_;
 159                 if (!defined ($obj->{'field_index'}{$field}))
 160                 {
 161                         my $id = $obj->{'id'};
 162                         print STDERR $/, __FILE__, ": $field is not a valid field ($id).";
 163                         next;
 164                 }
 165                 push (@field_indizes, $obj->{'field_index'}{$field});
 166         }
 167
 168         return (sort
 169         sub {
 170                 for (@field_indizes)
 171                 {
 172                         my $d = $data->{$a}[$_] cmp $data->{$b}[$_];
 173                         return ($d) if ($d);
 174                 }
 175         }, @keys);
 176 }
 177
 178 sub del
 179 {
 180         my $obj = shift;
 181         my $key = shift;
 182
 183         if (exists ($obj->{'data'}{$key}))
 184         {
 185                 delete ($obj->{'data'}{$key});
 186         }
 187 }
 188
 189 END
 190 {
 191         for (keys (%Tables))
 192         {
 193                 my $key = $_;
 194                 untie (%{$Tables{$key}});
 195         }
 196 }
 197
 198 =head1 AUTHOR
 199
 200 Florian octo Forster, L<octo at verplant.org>
 201
 202 =cut