DumbDBM_File.pm

   1 package DumbDBM_File;
   2
   3 # DumbDBM_File - Portable DBM implementation
   4 #
   5 # Based on Python's dumbdbm / dbm.dumb
   6 #
   7 # Author: Patrick Canterino <patrick@patshaping.de>
   8
   9 use strict;
  10
  11 use Carp qw(carp croak);
  12 use Fcntl;
  13
  14 our $VERSION = '0.1';
  15
  16 our $_BLOCKSIZE = 512;
  17
  18 sub _update {
  19         my $self = shift;
  20         local *FILE;
  21
  22         $self->{'_index'} = { };
  23
  24         open(FILE,'<'.$self->{'_dirfile'}) or carp $!;
  25
  26         while(<FILE>) {
  27                 my $line = $_;
  28                 $line =~ s/\s+$//g;
  29
  30                 my ($key,@pos_and_siz_pair) = eval($line);
  31                 $self->{'_index'}->{$key} = \@pos_and_siz_pair;
  32         }
  33 }
  34
  35 sub _commit {
  36         my $self = shift;
  37
  38         unlink($self->{'_bakfile'});
  39         rename($self->{'_dirfile'},$self->{'_bakfile'});
  40
  41         open(FILE,'>'.$self->{'_dirfile'}) or carp $!;
  42
  43         while(my($key,$pos_and_siz_pair) = each(%{$self->{'_index'}})) {
  44                 print FILE "'$key', ($pos_and_siz_pair->[0], $pos_and_siz_pair->[1])\n";
  45         }
  46
  47         close(FILE);
  48 }
  49
  50 sub _addval {
  51         my ($self,$val) = @_;
  52         local *FILE;
  53
  54         open(FILE,'+<'.$self->{'_datfile'}) or carp $!;
  55         binmode(FILE);
  56         seek(FILE,0,2);
  57
  58         my $pos = tell(FILE);
  59         my $npos = int(($pos + $_BLOCKSIZE - 1) / $_BLOCKSIZE) * $_BLOCKSIZE;
  60
  61         print FILE "\0" x ($npos-$pos);
  62
  63         $pos = $npos;
  64
  65         print FILE $val;
  66
  67         close(FILE);
  68
  69         return ($pos,length($val));
  70 }
  71
  72 sub _setval {
  73         my ($self,$pos,$val) = @_;
  74         local *FILE;
  75
  76         open(FILE,'+<'.$self->{'_datfile'}) or carp $!;
  77         binmode(FILE);
  78         seek(FILE,$pos,0);
  79         print FILE $val;
  80         close(FILE);
  81
  82         return ($pos,length($val));
  83 }
  84
  85 sub _addkey {
  86         my ($self,$key,@pos_and_siz_pair) = @_;
  87         local *FILE;
  88
  89         $self->{'_index'}->{$key} = \@pos_and_siz_pair;
  90
  91         open(FILE,'>>'.$self->{'_dirfile'}) or carp $!;
  92         print FILE "'$key', ($pos_and_siz_pair[0], $pos_and_siz_pair[1])\n";
  93         close(FILE);
  94 }
  95
  96 sub TIEHASH {
  97         my ($class,$file) = @_;
  98         local *FILE;
  99
 100         my $hash = { };
 101
 102         $hash->{'_dirfile'} = $file.'.dir';
 103         $hash->{'_datfile'} = $file.'.dat';
 104         $hash->{'_bakfile'} = $file.'.bak';
 105
 106         $hash->{'_index'}   = { };
 107
 108         sysopen(FILE,$hash->{'_datfile'},O_RDONLY | O_CREAT) or carp $!;
 109         close(FILE);
 110
 111         my $self = bless($hash,$class);
 112         $self->_update;
 113
 114         return $self;
 115 }
 116
 117 sub EXISTS {
 118         my ($self,$key) = @_;
 119         return exists($self->{'_index'}->{$key});
 120 }
 121
 122 sub FETCH {
 123         my ($self,$key) = @_;
 124         local *FILE;
 125
 126         my $pos = $self->{'_index'}->{$key}->[0];
 127         my $siz = $self->{'_index'}->{$key}->[1];
 128
 129         open(FILE,'<'.$self->{'_datfile'}) or carp $!;
 130         binmode(FILE);
 131         seek(FILE,$pos,0);
 132         read(FILE, my $dat, $siz);
 133         close(FILE);
 134
 135         return $dat;
 136 }
 137
 138 sub STORE {
 139         my ($self,$key,$val) = @_;
 140
 141         if(not exists($self->{'_index'}->{$key})) {
 142                 $self->_addkey($key,$self->_addval($val));
 143         }
 144         else {
 145                 my $pos = $self->{'_index'}->{$key}->[0];
 146                 my $siz = $self->{'_index'}->{$key}->[1];
 147
 148                 my $oldblocks = int(($siz + $_BLOCKSIZE -1) / $_BLOCKSIZE);
 149                 my $newblocks = int((length($val) + $_BLOCKSIZE -1) / $_BLOCKSIZE);
 150
 151                 if($newblocks <= $oldblocks) {
 152                         my @pos_and_siz_pair = $self->_setval($pos,$val);
 153                         $self->{'_index'}->{$key} = \@pos_and_siz_pair;
 154                 }
 155                 else {
 156                         my @pos_and_siz_pair = $self->_addval($val);
 157                         $self->{'_index'}->{$key} = \@pos_and_siz_pair;
 158                 }
 159         }
 160 }
 161
 162 sub FIRSTKEY {
 163         my $self = shift;
 164         my $a = keys(%{$self->{'_index'}});
 165         each %{$self->{'_index'}};
 166 }
 167
 168 sub DELETE {
 169         my ($self,$key) = @_;
 170         delete($self->{'_index'}->{$key});
 171         $self->_commit;
 172 }
 173
 174 sub NEXTKEY {
 175         my $self = shift;
 176         each %{$self->{'_index'}};
 177 }
 178
 179 sub UNTIE {
 180         my $self = shift;
 181         $self->_commit;
 182
 183         $self->{'_dirfile'} = undef;
 184         $self->{'_datfile'} = undef;
 185         $self->{'_bakfile'} = undef;
 186 }
 187
 188 # it's true, baby ;-)
 189
 190 1;
 191
 192 # Documentation
 193
 194 =pod
 195
 196 =head1 NAME
 197
 198 DumbDBM_File - Portable DBM implementation
 199
 200 =head1 SYNOPSIS
 201
 202  use DumbDBM_File;
 203
 204  # Opening a database file called "homer.db"
 205  # Creating it if necessary
 206
 207  my %db;
 208  tie(%db,'DumbDBM_File','homer.db');
 209
 210  # Assigning some values
 211
 212  $db{'name'} = 'Homer';
 213  $db{'wife'} = 'Marge';
 214  $db{'child'} = 'Bart';
 215  $db{'neighbor'} = 'Flanders';
 216
 217  # Print value of "name": Homer
 218
 219  print $db{'name'};
 220
 221  # Overwriting a value
 222
 223  $db{'child'} = 'Lisa';
 224
 225  # Remove a value
 226  # The value remains in the database file, just the index entry gets removed,
 227  # meaning you can't retrieve the value from the database file any more
 228
 229  delete($db{'neighbor'});
 230
 231  # Close the database file
 232
 233  untie %db;
 234
 235 =head1 DESCRIPTION
 236
 237 This is a Perl implementation of Python's C<dumbdbm> / C<dbm.dumb> module. It
 238 provides a simple DBM style database written entirely in Perl, requiring no
 239 external library.
 240
 241 Beware that this module is slow and should only be used as a last resort
 242 fallback when no more robust module like L<DB_File> is available.
 243
 244 This Perl implementation is fully compatible to the original Python one.
 245
 246 =head1 FILES
 247
 248 Consider having a database called example, you have up to three files:
 249
 250 =over 2
 251
 252 =item example.dir
 253
 254 This is an index file containing information for retrieving the values out of
 255 the database. It is a text file containing the key, the file offset and the
 256 size of each value.
 257
 258 =item example.dir.bak
 259
 260 This file B<may> containg a backup of the index file.
 261
 262 =item example.dat
 263
 264 This is the database file containing the values separated by zeros.
 265
 266 =back
 267
 268 =head1 BUGS AND PROBLEMS
 269
 270 This module is a direct port of the Python module containing the same bugs and
 271 problems.
 272
 273 - Seems to contain a bug when updating (this information was directly taken
 274 from a comment in C<dumbdbm>'s source code)
 275
 276 - Free space is not reclaimed
 277
 278 - No concurrent access is supported (if two processes access the database, they
 279 may mess up the index)
 280
 281 - This module always reads the whole index file and some updates the whole
 282 index
 283
 284 - No read-only mode
 285
 286 =head1 COPYRIGHT
 287
 288 =head1 AUTHOR
 289
 290 DumbDBM_File was written by Patrick Canterino
 291 L<patrick@patshaping.de|mailto:patrick@patshaping.de>.
 292
 293 L<http://www.patshaping.de/>
 294
 295 If you wonder why I wrote this: I felt boring ;)
 296
 297 =cut
 298
 299 #
 300 ### End ###