lib/DBM/Deep/Engine/DBI.pm

   1 package DBM::Deep::Engine::DBI;
   2
   3 use 5.006_000;
   4
   5 use strict;
   6 use warnings FATAL => 'all';
   7
   8 use base 'DBM::Deep::Engine';
   9
  10 sub read_value {
  11     my $self = shift;
  12     my ($obj, $key) = @_;
  13 }
  14
  15 sub get_classname {
  16     my $self = shift;
  17     my ($obj) = @_;
  18 }
  19
  20 sub make_reference {
  21     my $self = shift;
  22     my ($obj, $old_key, $new_key) = @_;
  23 }
  24
  25 sub key_exists {
  26     my $self = shift;
  27     my ($obj, $key) = @_;
  28 }
  29
  30 sub delete_key {
  31     my $self = shift;
  32     my ($obj, $key) = @_;
  33 }
  34
  35 sub write_value {
  36     my $self = shift;
  37     my ($obj, $key, $value) = @_;
  38
  39     my $r = Scalar::Util::reftype( $value ) || '';
  40     {
  41         last if $r eq '';
  42         last if $r eq 'HASH';
  43         last if $r eq 'ARRAY';
  44
  45         DBM::Deep->_throw_error(
  46             "Storage of references of type '$r' is not supported."
  47         );
  48     }
  49
  50     # Load the reference entry
  51     # Determine if the row was deleted under us
  52     #
  53
  54     my ($type);
  55     if ( $r eq 'ARRAY' || $r eq 'HASH' ) {
  56         my $tmpvar;
  57         if ( $r eq 'ARRAY' ) {
  58             $tmpvar = tied @$value;
  59         } elsif ( $r eq 'HASH' ) {
  60             $tmpvar = tied %$value;
  61         }
  62
  63         if ( $tmpvar ) {
  64             my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
  65
  66             unless ( $is_dbm_deep ) {
  67                 DBM::Deep->_throw_error( "Cannot store something that is tied." );
  68             }
  69
  70             unless ( $tmpvar->_engine->storage == $self->storage ) {
  71                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
  72             }
  73
  74             # Load $tmpvar's sector
  75
  76             # First, verify if we're storing the same thing to this spot. If we
  77             # are, then this should be a no-op. -EJS, 2008-05-19
  78
  79             # See whether or not we are storing ourselves to ourself.
  80             # Write the sector as data in this reference (keyed by $key)
  81             $value_sector->increment_refcount;
  82
  83             return 1;
  84         }
  85
  86         $type = substr( $r, 0, 1 );
  87     }
  88     else {
  89         if ( tied($value) ) {
  90             DBM::Deep->_throw_error( "Cannot store something that is tied." );
  91         }
  92     }
  93
  94     # This code is to make sure we write all the values in the $value to the
  95     # disk and to make sure all changes to $value after the assignment are
  96     # reflected on disk. This may be counter-intuitive at first, but it is
  97     # correct dwimmery.
  98     #   NOTE - simply tying $value won't perform a STORE on each value. Hence,
  99     # the copy to a temp value.
 100     if ( $r eq 'ARRAY' ) {
 101         my @temp = @$value;
 102         tie @$value, 'DBM::Deep', {
 103             base_offset => $value_sector->offset,
 104             staleness   => $value_sector->staleness,
 105             storage     => $self->storage,
 106             engine      => $self,
 107         };
 108         @$value = @temp;
 109         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 110     }
 111     elsif ( $r eq 'HASH' ) {
 112         my %temp = %$value;
 113         tie %$value, 'DBM::Deep', {
 114             base_offset => $value_sector->offset,
 115             staleness   => $value_sector->staleness,
 116             storage     => $self->storage,
 117             engine      => $self,
 118         };
 119
 120         %$value = %temp;
 121         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 122     }
 123
 124     return 1;
 125 }
 126
 127 sub setup {
 128     my $self = shift;
 129     my ($obj) = @_;
 130 }
 131
 132 sub begin_work {
 133     my $self = shift;
 134     my ($obj) = @_;
 135 }
 136
 137 sub rollback {
 138     my $self = shift;
 139     my ($obj) = @_;
 140 }
 141
 142 sub commit {
 143     my $self = shift;
 144     my ($obj) = @_;
 145 }
 146
 147
 148 1;
 149 __END__