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