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