return $self;
}
+sub write_file_signature {
+ my $self = shift;
+ my ($obj) = @_;
+
+ my $fh = $obj->_fh;
+
+ my $loc = $self->_request_space(
+ $obj, length( SIG_FILE ) + $self->{data_size},
+ );
+ seek($fh, $loc + $obj->_root->{file_offset}, SEEK_SET);
+ print( $fh SIG_FILE, pack($self->{data_pack}, 0) );
+
+ return;
+}
+
+sub read_file_signature {
+ my $self = shift;
+ my ($obj) = @_;
+
+ my $fh = $obj->_fh;
+
+ seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
+ my $buffer;
+ my $bytes_read = read(
+ $fh, $buffer, length(SIG_FILE) + $self->{data_size},
+ );
+
+ if ( $bytes_read ) {
+ my ($signature, $version) = unpack( "A4 $self->{data_pack}", $buffer );
+ unless ($signature eq SIG_FILE) {
+ $self->close_fh( $obj );
+ $obj->_throw_error("Signature not found -- file is not a Deep DB");
+ }
+ }
+
+ return $bytes_read;
+}
+
sub setup_fh {
my $self = shift;
my ($obj) = @_;
$self->open( $obj ) if !defined $obj->_fh;
my $fh = $obj->_fh;
- print "1\n";
flock $fh, LOCK_EX;
- print "2\n";
unless ( $obj->{base_offset} ) {
- seek($fh, 0 + $obj->_root->{file_offset}, SEEK_SET);
- my $signature;
- my $bytes_read = read( $fh, $signature, length(SIG_FILE));
+ my $bytes_read = $self->read_file_signature( $obj );
##
# File is empty -- write signature and master index
##
if (!$bytes_read) {
- my $loc = $self->_request_space( $obj, length( SIG_FILE ) );
- seek($fh, $loc + $obj->_root->{file_offset}, SEEK_SET);
- print( $fh SIG_FILE);
+ $self->write_file_signature( $obj );
$obj->{base_offset} = $self->_request_space(
$obj, $self->tag_size( $self->{index_size} ),
$obj->{base_offset} = $bytes_read;
##
- # Check signature was valid
- ##
- unless ($signature eq SIG_FILE) {
- $self->close_fh( $obj );
- $obj->_throw_error("Signature not found -- file is not a Deep DB");
- }
-
- ##
# Get our type from master index signature
##
my $tag = $self->load_tag($obj, $obj->_base_offset)
or $obj->_throw_error("Cannot sysopen file '$filename': $!");
$obj->_root->{fh} = $fh;
- #XXX Can we remove this by using the right sysopen() flags?
- # Maybe ... q.v. above
- binmode $fh; # for win32
+ # Even though we use O_BINARY, better be safe than sorry.
+ binmode $fh;
if ($obj->_root->{autoflush}) {
my $old = select $fh;
return $result;
}
+sub _get_tied {
+ my $item = shift;
+ my $r = Scalar::Util::reftype( $item ) || return;
+ if ( $r eq 'HASH' ) {
+ return tied(%$item);
+ }
+ elsif ( $r eq 'ARRAY' ) {
+ return tied(@$item);
+ }
+ else {
+ return;
+ };
+}
+
+sub _get_dbm_object {
+ my $item = shift;
+
+ my $obj = eval {
+ local $SIG{__DIE__};
+ if ($item->isa( 'DBM::Deep' )) {
+ return $item;
+ }
+ return;
+ };
+ return $obj if $obj;
+
+ my $r = Scalar::Util::reftype( $item ) || '';
+ if ( $r eq 'HASH' ) {
+ my $obj = eval {
+ local $SIG{__DIE__};
+ my $obj = tied(%$item);
+ if ($obj->isa( 'DBM::Deep' )) {
+ return $obj;
+ }
+ return;
+ };
+ return $obj if $obj;
+ }
+ elsif ( $r eq 'ARRAY' ) {
+ my $obj = eval {
+ local $SIG{__DIE__};
+ my $obj = tied(@$item);
+ if ($obj->isa( 'DBM::Deep' )) {
+ return $obj;
+ }
+ return;
+ };
+ return $obj if $obj;
+ }
+
+ return;
+}
+
sub write_value {
my $self = shift;
my ($obj, $location, $key, $value) = @_;
my $fh = $obj->_fh;
my $root = $obj->_root;
- my $is_dbm_deep = eval {
- local $SIG{'__DIE__'};
- $value->isa( 'DBM::Deep' );
- };
-
- my $is_internal_ref = $is_dbm_deep && ($value->_root eq $root);
+ my $dbm_deep_obj = _get_dbm_object( $value );
+ if ( $dbm_deep_obj && $dbm_deep_obj->_root ne $obj->_root ) {
+ $obj->_throw_error( "Cannot cross-reference. Use export() instead" );
+ }
seek($fh, $location + $root->{file_offset}, SEEK_SET);
# Write signature based on content type, set content length and write
# actual value.
##
- my $r = Scalar::Util::reftype($value) || '';
- if ( $is_internal_ref ) {
- $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $value->_base_offset) );
+ my $r = Scalar::Util::reftype( $value ) || '';
+ if ( $dbm_deep_obj ) {
+ $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $dbm_deep_obj->_base_offset) );
}
elsif ($r eq 'HASH') {
+ if ( !$dbm_deep_obj && tied %{$value} ) {
+ $obj->_throw_error( "Cannot store something that is tied" );
+ }
$self->write_tag( $obj, undef, SIG_HASH, chr(0)x$self->{index_size} );
}
elsif ($r eq 'ARRAY') {
+ if ( !$dbm_deep_obj && tied @{$value} ) {
+ $obj->_throw_error( "Cannot store something that is tied" );
+ }
$self->write_tag( $obj, undef, SIG_ARRAY, chr(0)x$self->{index_size} );
}
elsif (!defined($value)) {
print( $fh pack($self->{data_pack}, length($key)) . $key );
# Internal references don't care about autobless
- return 1 if $is_internal_ref;
+ return 1 if $dbm_deep_obj;
##
# If value is blessed, preserve class name
##
if ( $root->{autobless} ) {
my $value_class = Scalar::Util::blessed($value);
- if ( defined $value_class && !$is_dbm_deep ) {
+ if ( defined $value_class && !$dbm_deep_obj ) {
print( $fh chr(1) );
print( $fh pack($self->{data_pack}, length($value_class)) . $value_class );
}
# If content is a hash or array, create new child DBM::Deep object and
# pass each key or element to it.
##
- if ( !$is_internal_ref ) {
- if ($r eq 'HASH') {
- my $branch = DBM::Deep->new(
- type => DBM::Deep->TYPE_HASH,
- base_offset => $location,
- root => $root,
- );
- foreach my $key (keys %{$value}) {
- $branch->STORE( $key, $value->{$key} );
- }
- }
- elsif ($r eq 'ARRAY') {
- my $branch = DBM::Deep->new(
- type => DBM::Deep->TYPE_ARRAY,
- base_offset => $location,
- root => $root,
- );
- my $index = 0;
- foreach my $element (@{$value}) {
- $branch->STORE( $index, $element );
- $index++;
- }
- }
+ if ($r eq 'HASH') {
+ my %x = %$value;
+ tie %$value, 'DBM::Deep', {
+ base_offset => $location,
+ root => $root,
+ };
+ %$value = %x;
+ }
+ elsif ($r eq 'ARRAY') {
+ my @x = @$value;
+ tie @$value, 'DBM::Deep', {
+ base_offset => $location,
+ root => $root,
+ };
+ @$value = @x;
}
return 1;
# If value is a hash or array, return new DBM::Deep object with correct offset
##
if (($signature eq SIG_HASH) || ($signature eq SIG_ARRAY)) {
- my $obj = DBM::Deep->new(
+ my $new_obj = DBM::Deep->new({
type => $signature,
base_offset => $subloc,
root => $obj->_root,
- );
+ });
- if ($obj->_root->{autobless}) {
+ if ($new_obj->_root->{autobless}) {
##
# Skip over value and plain key to see if object needs
# to be re-blessed
seek($fh, $self->{data_size} + $self->{index_size}, SEEK_CUR);
my $size;
- read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size);
+ read( $fh, $size, $self->{data_size});
+ $size = unpack($self->{data_pack}, $size);
if ($size) { seek($fh, $size, SEEK_CUR); }
my $bless_bit;
# Yes, object needs to be re-blessed
##
my $class_name;
- read( $fh, $size, $self->{data_size}); $size = unpack($self->{data_pack}, $size);
+ read( $fh, $size, $self->{data_size});
+ $size = unpack($self->{data_pack}, $size);
if ($size) { read( $fh, $class_name, $size); }
- if ($class_name) { $obj = bless( $obj, $class_name ); }
+ if ($class_name) { $new_obj = bless( $new_obj, $class_name ); }
}
}
- return $obj;
+ return $new_obj;
}
elsif ( $signature eq SIG_INTERNAL ) {
my $size;
projects / dbsrgits/DBM-Deep.git / blobdiff