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 sub new {
  16     my $class = shift;
  17     my ($args) = @_;
  18
  19     $args->{storage} = DBM::Deep::Storage::DBI->new( $args )
  20         unless exists $args->{storage};
  21
  22     my $self = bless {
  23         storage => undef,
  24     }, $class;
  25
  26     # Grab the parameters we want to use
  27     foreach my $param ( keys %$self ) {
  28         next unless exists $args->{$param};
  29         $self->{$param} = $args->{$param};
  30     }
  31
  32     return $self;
  33 }
  34
  35 sub setup {
  36     my $self = shift;
  37     my ($obj) = @_;
  38
  39     # Default the id to 1. This means that we will be creating a row if there
  40     # isn't one. The assumption is that the row_id=1 cannot never be deleted. I
  41     # don't know if this is a good assumption.
  42     $obj->{base_offset} ||= 1;
  43
  44     my ($rows) = $self->storage->read_from(
  45         refs => $obj->_base_offset,
  46         qw( ref_type ),
  47     );
  48
  49     # We don't have a row yet.
  50     unless ( @$rows ) {
  51         $self->storage->write_to(
  52             refs => $obj->_base_offset,
  53             ref_type => $obj->_type,
  54         );
  55     }
  56
  57     my $sector = DBM::Deep::Sector::DBI::Reference->new({
  58         engine => $self,
  59         offset => $obj->_base_offset,
  60     });
  61 }
  62
  63 sub read_value {
  64     my $self = shift;
  65     my ($obj, $key) = @_;
  66
  67     my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
  68         or return;
  69
  70 #    if ( $sector->staleness != $obj->_staleness ) {
  71 #        return;
  72 #    }
  73
  74 #    my $key_md5 = $self->_apply_digest( $key );
  75
  76     my $value_sector = $sector->get_data_for({
  77         key => $key,
  78 #        key_md5    => $key_md5,
  79         allow_head => 1,
  80     });
  81
  82     unless ( $value_sector ) {
  83         $value_sector = DBM::Deep::Sector::DBI::Scalar->new({
  84             engine => $self,
  85             data   => undef,
  86         });
  87
  88         $sector->write_data({
  89 #            key_md5 => $key_md5,
  90             key     => $key,
  91             value   => $value_sector,
  92         });
  93     }
  94
  95     return $value_sector->data;
  96 }
  97
  98 =pod
  99 sub get_classname {
 100     my $self = shift;
 101     my ($obj) = @_;
 102 }
 103
 104 sub make_reference {
 105     my $self = shift;
 106     my ($obj, $old_key, $new_key) = @_;
 107 }
 108 =cut
 109
 110 # exists returns '', not undefined.
 111 sub key_exists {
 112     my $self = shift;
 113     my ($obj, $key) = @_;
 114
 115     my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
 116         or return '';
 117
 118 #    if ( $sector->staleness != $obj->_staleness ) {
 119 #        return '';
 120 #    }
 121
 122     my $data = $sector->get_data_for({
 123 #        key_md5    => $self->_apply_digest( $key ),
 124         key        => $key,
 125         allow_head => 1,
 126     });
 127
 128     # exists() returns 1 or '' for true/false.
 129     return $data ? 1 : '';
 130 }
 131
 132 sub delete_key {
 133     my $self = shift;
 134     my ($obj, $key) = @_;
 135
 136     my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
 137         or return '';
 138
 139 #    if ( $sector->staleness != $obj->_staleness ) {
 140 #        return '';
 141 #    }
 142
 143     return $sector->delete_key({
 144 #        key_md5    => $self->_apply_digest( $key ),
 145         key        => $key,
 146         allow_head => 0,
 147     });
 148 }
 149
 150 sub write_value {
 151     my $self = shift;
 152     my ($obj, $key, $value) = @_;
 153
 154     my $r = Scalar::Util::reftype( $value ) || '';
 155     {
 156         last if $r eq '';
 157         last if $r eq 'HASH';
 158         last if $r eq 'ARRAY';
 159
 160         DBM::Deep->_throw_error(
 161             "Storage of references of type '$r' is not supported."
 162         );
 163     }
 164
 165     # Load the reference entry
 166     # Determine if the row was deleted under us
 167     #
 168
 169     my $sector = $self->load_sector( $obj->_base_offset, 'refs' )
 170         or die "Cannot load sector at '@{[$obj->_base_offset]}'\n";;
 171
 172     my ($type, $class);
 173     if ( $r eq 'ARRAY' || $r eq 'HASH' ) {
 174         my $tmpvar;
 175         if ( $r eq 'ARRAY' ) {
 176             $tmpvar = tied @$value;
 177         } elsif ( $r eq 'HASH' ) {
 178             $tmpvar = tied %$value;
 179         }
 180
 181         if ( $tmpvar ) {
 182             my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar->isa( 'DBM::Deep' ); };
 183
 184             unless ( $is_dbm_deep ) {
 185                 DBM::Deep->_throw_error( "Cannot store something that is tied." );
 186             }
 187
 188             unless ( $tmpvar->_engine->storage == $self->storage ) {
 189                 DBM::Deep->_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
 190             }
 191
 192             # Load $tmpvar's sector
 193
 194             # First, verify if we're storing the same thing to this spot. If we
 195             # are, then this should be a no-op. -EJS, 2008-05-19
 196
 197             # See whether or not we are storing ourselves to ourself.
 198             # Write the sector as data in this reference (keyed by $key)
 199             my $value_sector = $self->load_sector( $tmpvar->_base_offset );
 200             $sector->write_data({
 201                 key     => $key,
 202                 key_md5 => $self->_apply_digest( $key ),
 203                 value   => $value_sector,
 204             });
 205             $value_sector->increment_refcount;
 206
 207             return 1;
 208         }
 209
 210         $type = substr( $r, 0, 1 );
 211         $class = 'DBM::Deep::Sector::DBI::Reference';
 212     }
 213     else {
 214         if ( tied($value) ) {
 215             DBM::Deep->_throw_error( "Cannot store something that is tied." );
 216         }
 217
 218         $class = 'DBM::Deep::Sector::DBI::Scalar';
 219         $type  = 'S';
 220     }
 221
 222     # Create this after loading the reference sector in case something bad
 223     # happens. This way, we won't allocate value sector(s) needlessly.
 224     my $value_sector = $class->new({
 225         engine => $self,
 226         data   => $value,
 227         type   => $type,
 228     });
 229
 230     $sector->write_data({
 231         key     => $key,
 232 #        key_md5 => $self->_apply_digest( $key ),
 233         value   => $value_sector,
 234     });
 235
 236     # This code is to make sure we write all the values in the $value to the
 237     # disk and to make sure all changes to $value after the assignment are
 238     # reflected on disk. This may be counter-intuitive at first, but it is
 239     # correct dwimmery.
 240     #   NOTE - simply tying $value won't perform a STORE on each value. Hence,
 241     # the copy to a temp value.
 242     if ( $r eq 'ARRAY' ) {
 243         my @temp = @$value;
 244         tie @$value, 'DBM::Deep', {
 245             base_offset => $value_sector->offset,
 246 #            staleness   => $value_sector->staleness,
 247             storage     => $self->storage,
 248             engine      => $self,
 249         };
 250         @$value = @temp;
 251         bless $value, 'DBM::Deep::Array' unless Scalar::Util::blessed( $value );
 252     }
 253     elsif ( $r eq 'HASH' ) {
 254         my %temp = %$value;
 255         tie %$value, 'DBM::Deep', {
 256             base_offset => $value_sector->offset,
 257 #            staleness   => $value_sector->staleness,
 258             storage     => $self->storage,
 259             engine      => $self,
 260         };
 261
 262         %$value = %temp;
 263         bless $value, 'DBM::Deep::Hash' unless Scalar::Util::blessed( $value );
 264     }
 265
 266     return 1;
 267 }
 268
 269 sub begin_work {
 270     my $self = shift;
 271     my ($obj) = @_;
 272 }
 273
 274 sub rollback {
 275     my $self = shift;
 276     my ($obj) = @_;
 277 }
 278
 279 sub commit {
 280     my $self = shift;
 281     my ($obj) = @_;
 282 }
 283
 284
 285 1;
 286 __END__