r12194@rob-kinyons-computer-2 (orig r10513): rkinyon | 2008-01-10 23:43:55 -0500

[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / File.pm

diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index be202c7..5216eaf 100644 (file)
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -1,27 +1,28 @@
 package DBM::Deep::File;
 
-use 5.6.0;
+use 5.006_000;
 
 use strict;
 use warnings;
 
-use Fcntl qw( :DEFAULT :flock :seek );
+our $VERSION = q(1.0007);
 
-our $VERSION = '0.01';
+use Fcntl qw( :DEFAULT :flock :seek );
 
 sub new {
     my $class = shift;
     my ($args) = @_;
 
     my $self = bless {
-        autobless          => undef,
-        autoflush          => undef,
+        autobless          => 1,
+        autoflush          => 1,
         end                => 0,
         fh                 => undef,
         file               => undef,
         file_offset        => 0,
-        locking            => undef,
+        locking            => 1,
         locked             => 0,
+#XXX Migrate this to the engine, where it really belongs.
         filter_store_key   => undef,
         filter_store_value => undef,
         filter_fetch_key   => undef,
@@ -46,10 +47,17 @@ sub new {
 sub open {
     my $self = shift;
 
-    # Adding O_BINARY does remove the need for the binmode below. However,
+    # Adding O_BINARY should remove the need for the binmode below. However,
     # I'm not going to remove it because I don't have the Win32 chops to be
     # absolutely certain everything will be ok.
-    my $flags = O_RDWR | O_CREAT | O_BINARY;
+    my $flags = O_CREAT | O_BINARY;
+
+    if ( !-e $self->{file} || -w _ ) {
+      $flags |= O_RDWR;
+    }
+    else {
+      $flags |= O_RDONLY;
+    }
 
     my $fh;
     sysopen( $fh, $self->{file}, $flags )
@@ -79,6 +87,51 @@ sub close {
     return 1;
 }
 
+sub set_inode {
+    my $self = shift;
+
+    unless ( defined $self->{inode} ) {
+        my @stats = stat($self->{fh});
+        $self->{inode} = $stats[1];
+        $self->{end} = $stats[7];
+    }
+
+    return 1;
+}
+
+sub print_at {
+    my $self = shift;
+    my $loc  = shift;
+
+    local ($/,$\);
+
+    my $fh = $self->{fh};
+    if ( defined $loc ) {
+        seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
+    }
+
+    print( $fh @_ );
+
+    return 1;
+}
+
+sub read_at {
+    my $self = shift;
+    my ($loc, $size) = @_;
+
+    local ($/,$\);
+
+    my $fh = $self->{fh};
+    if ( defined $loc ) {
+        seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
+    }
+
+    my $buffer;
+    read( $fh, $buffer, $size);
+
+    return $buffer;
+}
+
 sub DESTROY {
     my $self = shift;
     return unless $self;
@@ -88,6 +141,90 @@ sub DESTROY {
     return;
 }
 
+sub request_space {
+    my $self = shift;
+    my ($size) = @_;
+
+    #XXX Do I need to reset $self->{end} here? I need a testcase
+    my $loc = $self->{end};
+    $self->{end} += $size;
+
+    return $loc;
+}
+
+##
+# If db locking is set, flock() the db file.  If called multiple
+# times before unlock(), then the same number of unlocks() must
+# be called before the lock is released.
+##
+sub lock {
+    my $self = shift;
+    my ($obj, $type) = @_;
+
+    $type = LOCK_EX unless defined $type;
+
+    if (!defined($self->{fh})) { return; }
+
+    if ($self->{locking}) {
+        if (!$self->{locked}) {
+            flock($self->{fh}, $type);
+
+            # refresh end counter in case file has changed size
+            my @stats = stat($self->{fh});
+            $self->{end} = $stats[7];
+
+            # double-check file inode, in case another process
+            # has optimize()d our file while we were waiting.
+            if (defined($self->{inode}) && $stats[1] != $self->{inode}) {
+                $self->close;
+                $self->open;
+
+                #XXX This needs work
+                $obj->{engine}->setup_fh( $obj );
+
+                flock($self->{fh}, $type); # re-lock
+
+                # This may not be necessary after re-opening
+                $self->{end} = (stat($self->{fh}))[7]; # re-end
+            }
+        }
+        $self->{locked}++;
+
+        return 1;
+    }
+
+    return;
+}
+
+##
+# If db locking is set, unlock the db file.  See note in lock()
+# regarding calling lock() multiple times.
+##
+sub unlock {
+    my $self = shift;
+
+    if (!defined($self->{fh})) { return; }
+
+    if ($self->{locking} && $self->{locked} > 0) {
+        $self->{locked}--;
+        if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
+
+        return 1;
+    }
+
+    return;
+}
+
+sub flush {
+    my $self = shift;
+
+    # Flush the filehandle
+    my $old_fh = select $self->{fh};
+    my $old_af = $|; $| = 1; $| = $old_af;
+    select $old_fh;
+
+    return 1;
+}
+
 1;
 __END__
-