The header now has its own sector. A lot needs to be moved over to it, but it's there.

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

diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index 83835d9..aa1ea32 100644 (file)
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -3,12 +3,12 @@ package DBM::Deep::File;
 use 5.006_000;
 
 use strict;
-use warnings;
-
-our $VERSION = q(1.0006);
+use warnings FATAL => 'all';
 
 use Fcntl qw( :DEFAULT :flock :seek );
 
+use constant DEBUG => 0;
+
 sub new {
     my $class = shift;
     my ($args) = @_;
@@ -87,6 +87,13 @@ sub close {
     return 1;
 }
 
+sub size {
+    my $self = shift;
+
+    return 0 unless $self->{fh};
+    return -s $self->{fh};
+}
+
 sub set_inode {
     my $self = shift;
 
@@ -110,7 +117,13 @@ sub print_at {
         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
     }
 
-    print( $fh @_ );
+    if ( DEBUG ) {
+        my $caller = join ':', (caller)[0,2];
+        my $len = length( join '', @_ );
+        warn "($caller) print_at( " . (defined $loc ? $loc : '<undef>') . ", $len )\n";
+    }
+
+    print( $fh @_ ) or die "Internal Error (print_at($loc)): $!\n";
 
     return 1;
 }
@@ -126,6 +139,11 @@ sub read_at {
         seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
     }
 
+    if ( DEBUG ) {
+        my $caller = join ':', (caller)[0,2];
+        warn "($caller) read_at( " . (defined $loc ? $loc : '<undef>') . ", $size )\n";
+    }
+
     my $buffer;
     read( $fh, $buffer, $size);
 
@@ -157,14 +175,35 @@ sub request_space {
 # times before unlock(), then the same number of unlocks() must
 # be called before the lock is released.
 ##
+sub lock_exclusive {
+    my $self = shift;
+    my ($obj) = @_;
+    return $self->lock( $obj, LOCK_EX );
+}
+
+sub lock_shared {
+    my $self = shift;
+    my ($obj) = @_;
+    return $self->lock( $obj, LOCK_SH );
+}
+
 sub lock {
     my $self = shift;
     my ($obj, $type) = @_;
 
     $type = LOCK_EX unless defined $type;
 
+    #XXX This is a temporary fix for Win32 and autovivification. It
+    # needs to improve somehow. -RobK, 2008-03-09
+    if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
+        $type = LOCK_EX;
+    }
+
     if (!defined($self->{fh})) { return; }
 
+    #XXX This either needs to allow for upgrading a shared lock to an
+    # exclusive lock or something else with autovivification.
+    # -RobK, 2008-03-09
     if ($self->{locking}) {
         if (!$self->{locked}) {
             flock($self->{fh}, $type);
@@ -207,9 +246,13 @@ sub unlock {
 
     if ($self->{locking} && $self->{locked} > 0) {
         $self->{locked}--;
-        if (!$self->{locked}) { flock($self->{fh}, LOCK_UN); }
 
-        return 1;
+        if (!$self->{locked}) {
+            flock($self->{fh}, LOCK_UN);
+            return 1;
+        }
+
+        return;
     }
 
     return;
@@ -226,5 +269,30 @@ sub flush {
     return 1;
 }
 
+# Taken from http://www.perlmonks.org/?node_id=691054
+sub is_writable {
+    my $self = shift;
+
+    my $fh = $self->{fh};
+    return unless defined $fh;
+    return unless defined fileno $fh;
+    local $\ = '';  # just in case
+    no warnings;    # temporarily disable warnings
+    local $^W;      # temporarily disable warnings
+    return print $fh '';
+}
+
+sub copy_stats {
+    my $self = shift;
+    my ($temp_filename) = @_;
+
+    my @stats = stat( $self->{fh} );
+    my $perms = $stats[2] & 07777;
+    my $uid = $stats[4];
+    my $gid = $stats[5];
+    chown( $uid, $gid, $temp_filename );
+    chmod( $perms, $temp_filename );
+}
+
 1;
 __END__