X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep.pm;h=d34e67513e651ae661bead39dec381e0c8354791;hb=4301e8795213becc8854d413062d49746cdf5a31;hp=7a6bbcd28b95f17be9aff93f682820e97ad142a6;hpb=f72b2dfb916d7e3695bbd0c3161557180b137e65;p=dbsrgits%2FDBM-Deep.git

diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm
index 7a6bbcd..d34e675 100644
--- a/lib/DBM/Deep.pm
+++ b/lib/DBM/Deep.pm
@@ -5,11 +5,10 @@ use 5.006_000;
 use strict;
 use warnings;
 
-our $VERSION = q(1.0000);
+our $VERSION = q(1.0006);
 
 use Fcntl qw( :flock );
 
-use Clone ();
 use Digest::MD5 ();
 use FileHandle::Fmode ();
 use Scalar::Util ();
@@ -17,6 +16,10 @@ use Scalar::Util ();
 use DBM::Deep::Engine;
 use DBM::Deep::File;
 
+use overload
+    '""' => sub { overload::StrVal( $_[0] ) },
+    fallback => 1;
+
 ##
 # Setup constants for users to pass to new()
 ##
@@ -198,29 +201,85 @@ sub export {
     return $temp;
 }
 
+sub _check_legality {
+    my $self = shift;
+    my ($val) = @_;
+
+    my $r = Scalar::Util::reftype( $val );
+
+    return $r if !defined $r || '' eq $r;
+    return $r if 'HASH' eq $r;
+    return $r if 'ARRAY' eq $r;
+
+    DBM::Deep->_throw_error(
+        "Storage of references of type '$r' is not supported."
+    );
+}
+
 sub import {
-    ##
-    # Recursively import Perl hash/array structure
-    ##
-    if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
+    # Perl calls import() on use -- ignore
+    return if !ref $_[0];
 
     my $self = shift->_get_self;
     my ($struct) = @_;
 
-    # struct is not a reference, so just import based on our type
-    if (!ref($struct)) {
-        $struct = $self->_repr( @_ );
+    my $type = $self->_check_legality( $struct );
+    if ( !$type ) {
+        DBM::Deep->_throw_error( "Cannot import a scalar" );
     }
 
-    #XXX This isn't the best solution. Better would be to use Data::Walker,
-    #XXX but that's a lot more thinking than I want to do right now.
-    eval {
-        local $SIG{'__DIE__'};
-        $self->_import( Clone::clone( $struct ) );
-    }; if ( my $e = $@ ) {
-        die $e;
+    if ( substr( $type, 0, 1 ) ne $self->_type ) {
+        DBM::Deep->_throw_error(
+            "Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array')
+            . " into " . ('HASH' eq $type ? 'an array' : 'a hash')
+        );
     }
 
+    my %seen;
+    my $recurse;
+    $recurse = sub {
+        my ($db, $val) = @_;
+
+        my $obj = 'HASH' eq Scalar::Util::reftype( $db ) ? tied(%$db) : tied(@$db);
+        $obj ||= $db;
+
+        my $r = $self->_check_legality( $val );
+        if ( 'HASH' eq $r ) {
+            while ( my ($k, $v) = each %$val ) {
+                my $r = $self->_check_legality( $v );
+                if ( $r ) {
+                    my $temp = 'HASH' eq $r ? {} : [];
+                    if ( my $c = Scalar::Util::blessed( $v ) ) {
+                        bless $temp, $c;
+                    }
+                    $obj->put( $k, $temp );
+                    $recurse->( $temp, $v );
+                }
+                else {
+                    $obj->put( $k, $v );
+                }
+            }
+        }
+        elsif ( 'ARRAY' eq $r ) {
+            foreach my $k ( 0 .. $#$val ) {
+                my $v = $val->[$k];
+                my $r = $self->_check_legality( $v );
+                if ( $r ) {
+                    my $temp = 'HASH' eq $r ? {} : [];
+                    if ( my $c = Scalar::Util::blessed( $v ) ) {
+                        bless $temp, $c;
+                    }
+                    $obj->put( $k, $temp );
+                    $recurse->( $temp, $v );
+                }
+                else {
+                    $obj->put( $k, $v );
+                }
+            }
+        }
+    };
+    $recurse->( $self, $struct );
+
     return 1;
 }
 
@@ -240,17 +299,19 @@ sub optimize {
 
     #XXX Do we have to lock the tempfile?
 
+    #XXX Should we use tempfile() here instead of a hard-coded name?
     my $db_temp = DBM::Deep->new(
         file => $self->_storage->{file} . '.tmp',
         type => $self->_type,
 
         # Bring over all the parameters that we need to bring over
-        num_txns => $self->_engine->num_txns,
-        byte_size => $self->_engine->byte_size,
-        max_buckets => $self->_engine->max_buckets,
+        ( map { $_ => $self->_engine->$_ } qw(
+            byte_size max_buckets data_sector_size num_txns
+        )),
     );
 
     $self->lock();
+    $self->_engine->clear_cache;
     $self->_copy_node( $db_temp );
     undef $db_temp;
 
@@ -319,9 +380,6 @@ sub clone {
     );
 
     sub set_filter {
-        ##
-        # Setup filter function for storing or fetching the key or value
-        ##
         my $self = shift->_get_self;
         my $type = lc shift;
         my $func = shift;
@@ -333,6 +391,11 @@ sub clone {
 
         return;
     }
+
+    sub filter_store_key   { $_[0]->set_filter( store_key   => $_[1] ); }
+    sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); }
+    sub filter_fetch_key   { $_[0]->set_filter( fetch_key   => $_[1] ); }
+    sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); }
 }
 
 sub begin_work {
@@ -389,7 +452,13 @@ sub _fh {
 ##
 
 sub _throw_error {
-    die "DBM::Deep: $_[1]\n";
+    my $n = 0;
+    while( 1 ) {
+        my @caller = caller( ++$n );
+        next if $caller[0] =~ m/^DBM::Deep/;
+
+        die "DBM::Deep: $_[1] at $0 line $caller[2]\n";
+    }
 }
 
 sub STORE {
@@ -544,5 +613,7 @@ sub delete { (shift)->DELETE( @_ ) }
 sub exists { (shift)->EXISTS( @_ ) }
 sub clear { (shift)->CLEAR( @_ ) }
 
+sub _dump_file {shift->_get_self->_engine->_dump_file;}
+
 1;
 __END__