CLEAR now works ... all that's left before 0.99_01 is documentation

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

diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm
index 46d3403..72c2540 100644 (file)
--- a/lib/DBM/Deep/File.pm
+++ b/lib/DBM/Deep/File.pm
@@ -5,9 +5,9 @@ use 5.6.0;
 use strict;
 use warnings;
 
-use Fcntl qw( :DEFAULT :flock :seek );
+our $VERSION = q(0.99_01);
 
-our $VERSION = '0.01';
+use Fcntl qw( :DEFAULT :flock :seek );
 
 sub new {
     my $class = shift;
@@ -33,6 +33,7 @@ sub new {
         # $args. They are here for documentation purposes.
         transaction_id     => 0,
         transaction_offset => 0,
+        transaction_audit  => undef,
         base_db_obj        => undef,
     }, $class;
 
@@ -68,16 +69,20 @@ sub new {
 }
 
 sub set_db {
-    unless ( $_[0]{base_db_obj} ) {
-        $_[0]{base_db_obj} = $_[1];
-        Scalar::Util::weaken( $_[0]{base_db_obj} );
+    my $self = shift;
+
+    unless ( $self->{base_db_obj} ) {
+        $self->{base_db_obj} = shift;
+        Scalar::Util::weaken( $self->{base_db_obj} );
     }
+
+    return;
 }
 
 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;
@@ -110,6 +115,18 @@ sub close {
     return 1;
 }
 
+sub set_inode {
+    my $self = shift;
+
+    unless ( $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;
@@ -117,12 +134,43 @@ sub print_at {
     local ($/,$\);
 
     my $fh = $self->{fh};
-    seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
+    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 increment_pointer {
+    my $self = shift;
+    my ($size) = @_;
+
+    if ( defined $size ) {
+        seek( $self->{fh}, $size, SEEK_CUR );
+    }
+
+    return 1;
+}
+
 sub DESTROY {
     my $self = shift;
     return unless $self;
@@ -136,6 +184,7 @@ 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;
 
@@ -168,6 +217,10 @@ sub request_space {
 sub lock {
     my $self = shift;
     my ($obj, $type) = @_;
+
+    #XXX This may not always be the correct thing to do
+    $obj = $self->{base_db_obj} unless defined $obj;
+
     $type = LOCK_EX unless defined $type;
 
     if (!defined($self->{fh})) { return; }
@@ -229,10 +282,9 @@ sub set_transaction_offset {
 
 sub audit {
     my $self = shift;
+    my ($string) = @_;
 
     if ( my $afh = $self->{audit_fh} ) {
-        my ($string) = @_;
-
         flock( $afh, LOCK_EX );
 
         if ( $string =~ /^#/ ) {
@@ -245,6 +297,10 @@ sub audit {
         flock( $afh, LOCK_UN );
     }
 
+    if ( $self->{transaction_audit} ) {
+        push @{$self->{transaction_audit}}, $string;
+    }
+
     return 1;
 }
 
@@ -255,23 +311,28 @@ sub begin_transaction {
 
     $self->lock;
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    my $buffer;
-    read( $fh, $buffer, 4 );
-    $buffer = unpack( 'N', $buffer );
+    my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
+    my ($next, @trans) = unpack( 'C C C C', $buffer );
+
+    $self->{transaction_id} = ++$next;
 
-    for ( 1 .. 32 ) {
-        next if $buffer & (1 << ($_ - 1));
-        $self->{transaction_id} = $_;
-        $buffer |= (1 << $_-1 );
+    die if $trans[-1] != 0;
+
+    for ( my $i = 0; $i <= $#trans; $i++ ) {
+        next if $trans[$i] != 0;
+        $trans[$i] = $next;
         last;
     }
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    print( $fh pack( 'N', $buffer ) );
+    $self->print_at(
+        $self->{transaction_offset},
+        pack( 'C C C C', $next, @trans),
+    );
 
     $self->unlock;
 
+    $self->{transaction_audit} = [];
+
     return $self->{transaction_id};
 }
 
@@ -282,19 +343,28 @@ sub end_transaction {
 
     $self->lock;
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    my $buffer;
-    read( $fh, $buffer, 4 );
-    $buffer = unpack( 'N', $buffer );
+    my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
+    my ($next, @trans) = unpack( 'C C C C', $buffer );
+
+    @trans = grep { $_ != $self->{transaction_id} } @trans;
 
-    # Unset $self->{transaction_id} bit
+    $self->print_at(
+        $self->{transaction_offset},
+        pack( 'C C C C', $next, @trans),
+    );
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    print( $fh pack( 'N', $buffer ) );
+    #XXX Need to free the space used by the current transaction
 
     $self->unlock;
 
     $self->{transaction_id} = 0;
+    $self->{transaction_audit} = undef;
+
+#    $self->{base_db_obj}->optimize;
+#    $self->{inode} = undef;
+#    $self->set_inode;
+
+    return 1;
 }
 
 sub current_transactions {
@@ -304,27 +374,33 @@ sub current_transactions {
 
     $self->lock;
 
-    seek( $fh, $self->{transaction_offset} + $self->{file_offset}, SEEK_SET );
-    my $buffer;
-    read( $fh, $buffer, 4 );
-    $buffer = unpack( 'N', $buffer );
+    my $buffer = $self->read_at( $self->{transaction_offset}, 4 );
+    my ($next, @trans) = unpack( 'C C C C', $buffer );
 
     $self->unlock;
 
-    my @transactions;
-    for ( 1 .. 32 ) {
-        if ( $buffer & (1 << ($_ - 1)) ) {
-            push @transactions, $_;
-        }
-    }
-
-    return grep { $_ != $self->{transaction_id} } @transactions;
+    return grep { $_ && $_ != $self->{transaction_id} } @trans;
 }
 
 sub transaction_id { return $_[0]->{transaction_id} }
 
-#sub commit {
-#}
+sub commit_transaction {
+    my $self = shift;
+
+    my @audit = @{$self->{transaction_audit}};
+
+    $self->end_transaction;
+
+    {
+        my $db = $self->{base_db_obj};
+        for ( @audit ) {
+            eval "$_;";
+            warn "$_: $@\n" if $@;
+        }
+    }
+
+    return 1;
+}
 
 1;
 __END__