use strict;
use warnings;
-use Fcntl qw( :DEFAULT :flock :seek );
+our $VERSION = q(0.99_03);
-our $VERSION = '0.01';
+use Fcntl qw( :DEFAULT :flock :seek );
sub new {
my $class = shift;
# $args. They are here for documentation purposes.
transaction_id => 0,
transaction_offset => 0,
+ transaction_audit => undef,
base_db_obj => undef,
}, $class;
}
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;
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;
+
+ 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 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;
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;
+}
+
+#sub release_space {
+# my $self = shift;
+# my ($size, $loc) = @_;
+#
+# local($/,$\);
+#
+# my $next_loc = 0;
+#
+# my $fh = $self->{fh};
+# seek( $fh, $loc + $self->{file_offset}, SEEK_SET );
+# print( $fh SIG_FREE
+# . pack($self->{long_pack}, $size )
+# . pack($self->{long_pack}, $next_loc )
+# );
+#
+# return;
+#}
+
##
# If db locking is set, flock() the db file. If called multiple
# times before unlock(), then the same number of unlocks() must
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; }
sub audit {
my $self = shift;
+ my ($string) = @_;
if ( my $afh = $self->{audit_fh} ) {
- my ($string) = @_;
-
flock( $afh, LOCK_EX );
if ( $string =~ /^#/ ) {
flock( $afh, LOCK_UN );
}
+ if ( $self->{transaction_audit} ) {
+ push @{$self->{transaction_audit}}, $string;
+ }
+
return 1;
}
$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 C C C C C C C C C C C C', $buffer );
- for ( 1 .. 32 ) {
- next if $buffer & (1 << ($_ - 1));
- $self->{transaction_id} = $_;
- $buffer |= (1 << $_-1 );
+ $self->{transaction_id} = ++$next;
+
+ 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 C C C C C C C C C C C C', $next, @trans),
+ );
$self->unlock;
+ $self->{transaction_audit} = [];
+
return $self->{transaction_id};
}
$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 C C C C C C C C C C C C', $buffer );
- # Unset $self->{transaction_id} bit
+ @trans = grep { $_ != $self->{transaction_id} } @trans;
- 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 C C C C C C C C C C C C', $next, @trans),
+ );
+
+ #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 {
$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 C C C C C C C C 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__
projects / dbsrgits/DBM-Deep.git / blobdiff