lib/DBM/Deep/Engine.pm

   1 package DBM::Deep::Engine;
   2
   3 use strict;
   4
   5 use Fcntl qw( :DEFAULT :flock :seek );
   6
   7 sub open {
   8         ##
   9         # Open a fh to the database, create if nonexistent.
  10         # Make sure file signature matches DBM::Deep spec.
  11         ##
  12     my $self = shift;
  13     my $obj = shift;
  14
  15         if (defined($obj->_fh)) { $self->close( $obj ); }
  16
  17     eval {
  18         local $SIG{'__DIE__'};
  19         # Theoretically, adding O_BINARY should remove the need for the binmode
  20         # Of course, testing it is going to be ... interesting.
  21         my $flags = O_RDWR | O_CREAT | O_BINARY;
  22
  23         my $fh;
  24         sysopen( $fh, $obj->_root->{file}, $flags )
  25             or $fh = undef;
  26         $obj->_root->{fh} = $fh;
  27     }; if ($@ ) { $obj->_throw_error( "Received error: $@\n" ); }
  28         if (! defined($obj->_fh)) {
  29                 return $obj->_throw_error("Cannot sysopen file: " . $obj->_root->{file} . ": $!");
  30         }
  31
  32     my $fh = $obj->_fh;
  33
  34     #XXX Can we remove this by using the right sysopen() flags?
  35     # Maybe ... q.v. above
  36     binmode $fh; # for win32
  37
  38     if ($obj->_root->{autoflush}) {
  39         my $old = select $fh;
  40         $|=1;
  41         select $old;
  42     }
  43
  44     seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
  45
  46     my $signature;
  47     my $bytes_read = read( $fh, $signature, length(DBM::Deep->SIG_FILE));
  48
  49     ##
  50     # File is empty -- write signature and master index
  51     ##
  52     if (!$bytes_read) {
  53         seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
  54         print( $fh DBM::Deep->SIG_FILE);
  55         $self->create_tag($obj, $obj->_base_offset, $obj->_type, chr(0) x $DBM::Deep::INDEX_SIZE);
  56
  57         my $plain_key = "[base]";
  58         print( $fh pack($DBM::Deep::DATA_LENGTH_PACK, length($plain_key)) . $plain_key );
  59
  60         # Flush the filehandle
  61         my $old_fh = select $fh;
  62         my $old_af = $|; $| = 1; $| = $old_af;
  63         select $old_fh;
  64
  65         my @stats = stat($fh);
  66         $obj->_root->{inode} = $stats[1];
  67         $obj->_root->{end} = $stats[7];
  68
  69         return 1;
  70     }
  71
  72     ##
  73     # Check signature was valid
  74     ##
  75     unless ($signature eq DBM::Deep->SIG_FILE) {
  76         $self->close( $obj );
  77         return $obj->_throw_error("Signature not found -- file is not a Deep DB");
  78     }
  79
  80         my @stats = stat($fh);
  81         $obj->_root->{inode} = $stats[1];
  82     $obj->_root->{end} = $stats[7];
  83
  84     ##
  85     # Get our type from master index signature
  86     ##
  87     my $tag = $self->load_tag($obj, $obj->_base_offset);
  88
  89 #XXX We probably also want to store the hash algorithm name and not assume anything
  90 #XXX The cool thing would be to allow a different hashing algorithm at every level
  91
  92     if (!$tag) {
  93         return $obj->_throw_error("Corrupted file, no master index record");
  94     }
  95     if ($obj->{type} ne $tag->{signature}) {
  96         return $obj->_throw_error("File type mismatch");
  97     }
  98
  99     return 1;
 100 }
 101
 102 sub close {
 103     my $self = shift;
 104     my $obj = shift;
 105
 106     if ( my $fh = $obj->_root->{fh} ) {
 107         close $fh;
 108     }
 109     $obj->_root->{fh} = undef;
 110
 111     return 1;
 112 }
 113
 114 sub create_tag {
 115         ##
 116         # Given offset, signature and content, create tag and write to disk
 117         ##
 118     my $self = shift;
 119         my ($obj, $offset, $sig, $content) = @_;
 120         my $size = length($content);
 121
 122     my $fh = $obj->_fh;
 123
 124         seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
 125         print( $fh $sig . pack($DBM::Deep::DATA_LENGTH_PACK, $size) . $content );
 126
 127         if ($offset == $obj->_root->{end}) {
 128                 $obj->_root->{end} += DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE + $size;
 129         }
 130
 131         return {
 132                 signature => $sig,
 133                 size => $size,
 134                 offset => $offset + DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE,
 135                 content => $content
 136         };
 137 }
 138
 139 sub load_tag {
 140         ##
 141         # Given offset, load single tag and return signature, size and data
 142         ##
 143     my $self = shift;
 144         my ($obj, $offset) = @_;
 145
 146     my $fh = $obj->_fh;
 147
 148         seek($fh, $offset + $obj->_root->{file_offset}, SEEK_SET);
 149         if (eof $fh) { return undef; }
 150
 151     my $b;
 152     read( $fh, $b, DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE );
 153     my ($sig, $size) = unpack( "A $DBM::Deep::DATA_LENGTH_PACK", $b );
 154
 155         my $buffer;
 156         read( $fh, $buffer, $size);
 157
 158         return {
 159                 signature => $sig,
 160                 size => $size,
 161                 offset => $offset + DBM::Deep->SIG_SIZE + $DBM::Deep::DATA_LENGTH_SIZE,
 162                 content => $buffer
 163         };
 164 }
 165
 166 sub index_lookup {
 167         ##
 168         # Given index tag, lookup single entry in index and return .
 169         ##
 170     my $self = shift;
 171         my ($obj, $tag, $index) = @_;
 172
 173         my $location = unpack($DBM::Deep::LONG_PACK, substr($tag->{content}, $index * $DBM::Deep::LONG_SIZE, $DBM::Deep::LONG_SIZE) );
 174         if (!$location) { return; }
 175
 176         return $self->load_tag( $obj, $location );
 177 }
 178
 179 1;
 180 __END__