All sectors now use a string to create themselves

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

diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index c62d81f..0a3096f 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.0003);
+use warnings FATAL => 'all';
 
 use Fcntl qw( :DEFAULT :flock :seek );
 
+use constant DEBUG => 0;
+
 sub new {
     my $class = shift;
     my ($args) = @_;
@@ -110,7 +110,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 +132,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);
 
@@ -163,8 +174,17 @@ sub lock {
 
     $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);
@@ -226,5 +246,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__