From: rkinyon Date: Mon, 20 Feb 2006 03:10:46 +0000 (+0000) Subject: Removed unnecessary commented-out dependency on Carp X-Git-Tag: 0-97~38 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=596e957406a6efd0423d2b3afc9e93a43486fa0b;p=dbsrgits%2FDBM-Deep.git Removed unnecessary commented-out dependency on Carp --- diff --git a/Build.PL b/Build.PL index c6ca08d..d12f73d 100644 --- a/Build.PL +++ b/Build.PL @@ -6,7 +6,6 @@ my $build = Module::Build->new( module_name => 'DBM::Deep', license => 'perl', requires => { -# 'Carp' => '0.01', 'Digest::MD5' => '1.00', 'Scalar::Util' => '1.18', }, diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index e530665..8260a48 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -31,11 +31,11 @@ package DBM::Deep; use strict; -use Fcntl qw(:DEFAULT :flock :seek); +use Fcntl qw( :DEFAULT :flock :seek ); use Digest::MD5 (); use Scalar::Util (); -use vars qw/$VERSION/; +use vars qw( $VERSION ); $VERSION = "0.96"; ## @@ -102,6 +102,7 @@ sub SIG_SIZE () { 1 } sub TYPE_HASH () { return SIG_HASH; } sub TYPE_ARRAY () { return SIG_ARRAY; } +sub _get_self { $_[0] } sub new { ## # Class constructor method for Perl OO interface. @@ -162,10 +163,6 @@ sub new { } } -sub _get_self { - tied( %{$_[0]} ) || $_[0] -} - sub TIEHASH { shift; require DBM::Deep::Hash; @@ -182,36 +179,32 @@ sub TIEARRAY { #sub DESTROY { #} -my %translate_mode = ( - 'r' => '<', - 'r+' => '+<', - 'w' => '>', - 'w+' => '+>', - 'a' => '>>', - 'a+' => '+>>', -); sub _open { ## # Open a FileHandle to the database, create if nonexistent. # Make sure file signature matches DeepDB spec. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); if (defined($self->fh)) { $self->_close(); } eval { - my $filename = $self->root->{file}; + # Theoretically, adding O_BINARY should remove the need for the binmode + # Of course, testing it is going to be ... interesting. + my $flags = O_RDWR | O_CREAT | O_BINARY; + #XXX Can the mode be anything but r+, w+, or a+?? #XXX ie, it has to be in read-write mode - my $mode = $translate_mode{ $self->root->{mode} }; + #XXX So, should we verify that the mode is legitimate? - if (!(-e $filename) && $mode eq '+<') { - sysopen( FH, $filename, O_CREAT | O_WRONLY, 0666 ); - close FH; + #XXX Maybe the mode thingy should just go away. There's no good + #XXX reason for it ... + if ( $self->root->{mode} eq 'w+' ) { + $flags |= O_TRUNC; } my $fh; - sysopen( $fh, $filename, O_RDWR ) + sysopen( $fh, $self->root->{file}, $flags ) or $fh = undef; $self->root->{fh} = $fh; }; if ($@ ) { $self->_throw_error( "Received error: $@\n" ); } @@ -222,8 +215,7 @@ sub _open { my $fh = $self->fh; #XXX Can we remove this by using the right sysopen() flags? - #XXX I don't think so - there's an item in fopen(3) about rb+, but I'm not sure - #XXX That will work. + # Maybe ... q.v. above binmode $fh; # for win32 if ($self->root->{autoflush}) { @@ -232,8 +224,10 @@ sub _open { select $old; } - my $signature; + # Set the seek($fh, 0, SEEK_SET); + + my $signature; my $bytes_read = read( $fh, $signature, length(SIG_FILE)); ## @@ -290,7 +284,7 @@ sub _close { ## # Close database FileHandle ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); close $self->root->{fh}; } @@ -875,7 +869,7 @@ sub _get_next_key { ## # Locate next key, given digested previous one ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); $self->{prev_md5} = $_[1] ? $_[1] : undef; $self->{return_next} = 0; @@ -898,7 +892,7 @@ sub lock { # times before unlock(), then the same number of unlocks() must # be called before the lock is released. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $type = $_[1]; $type = LOCK_EX unless defined $type; @@ -917,7 +911,7 @@ sub unlock { # If db locking is set, unlock the db file. See note in lock() # regarding calling lock() multiple times. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); if ($self->root->{locking} && $self->root->{locked} > 0) { $self->root->{locked}--; @@ -935,7 +929,7 @@ sub _copy_node { # Copy single level of keys or elements to new DB handle. # Recurse for nested structures ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $db_temp = $_[1]; if ($self->type eq TYPE_HASH) { @@ -973,7 +967,7 @@ sub export { ## # Recursively export into standard Perl hashes and arrays. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $temp; if ($self->type eq TYPE_HASH) { $temp = {}; } @@ -993,7 +987,7 @@ sub import { #XXX This use of ref() seems to be ok if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $struct = $_[1]; #XXX This use of ref() seems to be ok @@ -1026,7 +1020,7 @@ sub optimize { # Rebuild entire database into new file, then move # it back on top of original. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); #XXX Need to create a new test for this # if ($self->root->{links} > 1) { @@ -1084,7 +1078,7 @@ sub clone { ## # Make copy of object and return ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); return DBM::Deep->new( type => $self->type, @@ -1105,7 +1099,7 @@ sub clone { ## # Setup filter function for storing or fetching the key or value ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $type = lc $_[1]; my $func = $_[2] ? $_[2] : undef; @@ -1126,7 +1120,7 @@ sub root { ## # Get access to the root structure ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); return $self->{root}; } @@ -1135,7 +1129,7 @@ sub fh { # Get access to the raw FileHandle ## #XXX It will be useful, though, when we split out HASH and ARRAY - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); return $self->root->{fh}; } @@ -1143,7 +1137,7 @@ sub type { ## # Get type of current node (TYPE_HASH or TYPE_ARRAY) ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); return $self->{type}; } @@ -1151,7 +1145,7 @@ sub base_offset { ## # Get base_offset of current node (TYPE_HASH or TYPE_ARRAY) ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); return $self->{base_offset}; } @@ -1160,7 +1154,8 @@ sub error { # Get last error string, or undef if no error ## return $_[0] - ? ( _get_self($_[0])->{root}->{error} or undef ) + #? ( _get_self($_[0])->{root}->{error} or undef ) + ? ( $_[0]->_get_self->{root}->{error} or undef ) : $@; } @@ -1172,7 +1167,7 @@ sub _throw_error { ## # Store error string in self ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $error_text = $_[1]; $self->root->{error} = $error_text; @@ -1189,7 +1184,7 @@ sub clear_error { ## # Clear error state ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); undef $self->root->{error}; } @@ -1242,7 +1237,7 @@ sub STORE { ## # Store single hash key/value or array element in database. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1]; #XXX What is ref() checking here? #YYY User may be storing a hash, in which case we do not want it run @@ -1329,7 +1324,7 @@ sub FETCH { ## # Fetch single value or element given plain key or array index ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $key = $_[1]; if ( $self->type eq TYPE_HASH ) { @@ -1376,7 +1371,7 @@ sub DELETE { ## # Delete single key/value pair or element given plain key or array index ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1]; my $unpacked_key = $key; @@ -1421,7 +1416,7 @@ sub EXISTS { ## # Check if a single key or element exists given plain key or array index ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1]; if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); } @@ -1461,7 +1456,7 @@ sub CLEAR { ## # Clear all keys from hash, or all elements from array. ## - my $self = _get_self($_[0]); + my $self = $_[0]->_get_self;#_get_self($_[0]); ## # Make sure file is open diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index b01f7b6..c15adfa 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -4,6 +4,10 @@ use strict; use base 'DBM::Deep'; +sub _get_self { + eval { tied( @{$_[0]} ) } || $_[0] +} + sub TIEARRAY { ## # Tied array constructor method, called by Perl's tie() function. @@ -28,7 +32,7 @@ sub FETCHSIZE { ## # Return the length of the array ## - my $self = DBM::Deep::_get_self($_[0]); + my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]); my $SAVE_FILTER = $self->root->{filter_fetch_value}; $self->root->{filter_fetch_value} = undef; @@ -45,7 +49,7 @@ sub STORESIZE { ## # Set the length of the array ## - my $self = DBM::Deep::_get_self($_[0]); + my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]); my $new_length = $_[1]; my $SAVE_FILTER = $self->root->{filter_store_value}; @@ -62,7 +66,7 @@ sub POP { ## # Remove and return the last element on the array ## - my $self = DBM::Deep::_get_self($_[0]); + my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]); my $length = $self->FETCHSIZE(); if ($length) { @@ -79,7 +83,7 @@ sub PUSH { ## # Add new element(s) to the end of the array ## - my $self = DBM::Deep::_get_self(shift); + my $self = (shift(@_))->_get_self;#DBM::Deep::_get_self(shift); my $length = $self->FETCHSIZE(); while (my $content = shift @_) { @@ -93,7 +97,7 @@ sub SHIFT { # Remove and return first element on the array. # Shift over remaining elements to take up space. ## - my $self = DBM::Deep::_get_self($_[0]); + my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]); my $length = $self->FETCHSIZE(); if ($length) { @@ -119,7 +123,7 @@ sub UNSHIFT { # Insert new element(s) at beginning of array. # Shift over other elements to make space. ## - my $self = DBM::Deep::_get_self($_[0]);shift @_; + my $self = $_[0]->_get_self;shift;#DBM::Deep::_get_self($_[0]);shift @_; my @new_elements = @_; my $length = $self->FETCHSIZE(); my $new_size = scalar @new_elements; @@ -140,7 +144,7 @@ sub SPLICE { # Splices section of array with optional new section. # Returns deleted section, or last element deleted in scalar context. ## - my $self = DBM::Deep::_get_self($_[0]);shift @_; + my $self = $_[0]->_get_self;shift;#DBM::Deep::_get_self($_[0]);shift @_; my $length = $self->FETCHSIZE(); ## diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index dcdb79f..eeeffab 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -4,6 +4,10 @@ use strict; use base 'DBM::Deep'; +sub _get_self { + tied( %{$_[0]} ) || $_[0] +} + sub TIEHASH { ## # Tied hash constructor method, called by Perl's tie() function. @@ -24,7 +28,7 @@ sub FIRSTKEY { ## # Locate and return first key (in no particular order) ## - my $self = DBM::Deep::_get_self($_[0]); + my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]); ## # Make sure file is open @@ -49,7 +53,7 @@ sub NEXTKEY { ## # Return next key (in no particular order), given previous one ## - my $self = DBM::Deep::_get_self($_[0]); + my $self = $_[0]->_get_self;#DBM::Deep::_get_self($_[0]); my $prev_key = ($self->root->{filter_store_key}) ? $self->root->{filter_store_key}->($_[1])