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