<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package DBM::Deep::Engine::DBI;

use 5.008_004;

use strict;
use warnings FATAL =&gt; 'all';
no warnings 'recursion';

use base 'DBM::Deep::Engine';

use DBM::Deep::Sector::DBI ();
use DBM::Deep::Storage::DBI ();

sub sector_type { 'DBM::Deep::Sector::DBI' }
sub iterator_class { 'DBM::Deep::Iterator::DBI' }

sub new {
    my $class = shift;
    my ($args) = @_;

    $args-&gt;{storage} = DBM::Deep::Storage::DBI-&gt;new( $args )
        unless exists $args-&gt;{storage};

    my $self = bless {
        storage =&gt; undef,
        external_refs =&gt; undef,
    }, $class;

    # Grab the parameters we want to use
    foreach my $param ( keys %$self ) {
        next unless exists $args-&gt;{$param};
        $self-&gt;{$param} = $args-&gt;{$param};
    }

    return $self;
}

sub setup {
    my $self = shift;
    my ($obj) = @_;

    # Default the id to 1. This means that we will be creating a row if there
    # isn't one. The assumption is that the row_id=1 cannot never be deleted. I
    # don't know if this is a good assumption.
    $obj-&gt;{base_offset} ||= 1;

    my ($rows) = $self-&gt;storage-&gt;read_from(
        refs =&gt; $obj-&gt;_base_offset,
        qw( ref_type ),
    );

    # We don't have a row yet.
    unless ( @$rows ) {
        $self-&gt;storage-&gt;write_to(
            refs =&gt; $obj-&gt;_base_offset,
            ref_type =&gt; $obj-&gt;_type,
        );
    }

    my $sector = DBM::Deep::Sector::DBI::Reference-&gt;new({
        engine =&gt; $self,
        offset =&gt; $obj-&gt;_base_offset,
    });
}

sub read_value {
    my $self = shift;
    my ($obj, $key) = @_;

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or return;

#    if ( $sector-&gt;staleness != $obj-&gt;_staleness ) {
#        return;
#    }

#    my $key_md5 = $self-&gt;_apply_digest( $key );

    my $value_sector = $sector-&gt;get_data_for({
        key =&gt; $key,
#        key_md5    =&gt; $key_md5,
        allow_head =&gt; 1,
    });

    unless ( $value_sector ) {
        return undef
    }

    return $value_sector-&gt;data;
}

sub get_classname {
    my $self = shift;
    my ($obj) = @_;

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or return;

    return $sector-&gt;get_classname;
}

sub make_reference {
    my $self = shift;
    my ($obj, $old_key, $new_key) = @_;

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or return;

#    if ( $sector-&gt;staleness != $obj-&gt;_staleness ) {
#        return;
#    }

    my $value_sector = $sector-&gt;get_data_for({
        key        =&gt; $old_key,
        allow_head =&gt; 1,
    });

    unless ( $value_sector ) {
        $value_sector = DBM::Deep::Sector::DBI::Scalar-&gt;new({
            engine =&gt; $self,
            data   =&gt; undef,
        });

        $sector-&gt;write_data({
            key     =&gt; $old_key,
            value   =&gt; $value_sector,
        });
    }

    if ( $value_sector-&gt;isa( 'DBM::Deep::Sector::DBI::Reference' ) ) {
        $sector-&gt;write_data({
            key     =&gt; $new_key,
            value   =&gt; $value_sector,
        });
        $value_sector-&gt;increment_refcount;
    }
    else {
        $sector-&gt;write_data({
            key     =&gt; $new_key,
            value   =&gt; $value_sector-&gt;clone,
        });
    }

    return;
}

# exists returns '', not undefined.
sub key_exists {
    my $self = shift;
    my ($obj, $key) = @_;

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or return '';

#    if ( $sector-&gt;staleness != $obj-&gt;_staleness ) {
#        return '';
#    }

    my $data = $sector-&gt;get_data_for({
#        key_md5    =&gt; $self-&gt;_apply_digest( $key ),
        key        =&gt; $key,
        allow_head =&gt; 1,
    });

    # exists() returns 1 or '' for true/false.
    return $data ? 1 : '';
}

sub delete_key {
    my $self = shift;
    my ($obj, $key) = @_;

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or return '';

#    if ( $sector-&gt;staleness != $obj-&gt;_staleness ) {
#        return '';
#    }

    return $sector-&gt;delete_key({
#        key_md5    =&gt; $self-&gt;_apply_digest( $key ),
        key        =&gt; $key,
        allow_head =&gt; 0,
    });
}

sub write_value {
    my $self = shift;
    my ($obj, $key, $value) = @_;

    my $r = Scalar::Util::reftype( $value ) || '';
    {
        last if $r eq '';
        last if $r eq 'HASH';
        last if $r eq 'ARRAY';

        DBM::Deep-&gt;_throw_error(
            "Storage of references of type '$r' is not supported."
        );
    }

    # Load the reference entry
    # Determine if the row was deleted under us
    # 

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or die "Cannot load sector at '@{[$obj-&gt;_base_offset]}'\n";;

    my ($type, $class);
    if (
     $r eq 'ARRAY' || $r eq 'HASH' and ref $value ne 'DBM::Deep::Null'
    ) {
        my $tmpvar;
        if ( $r eq 'ARRAY' ) {
            $tmpvar = tied @$value;
        } elsif ( $r eq 'HASH' ) {
            $tmpvar = tied %$value;
        }

        if ( $tmpvar ) {
            my $is_dbm_deep = eval { local $SIG{'__DIE__'}; $tmpvar-&gt;isa( 'DBM::Deep' ); };

            unless ( $is_dbm_deep ) {
                DBM::Deep-&gt;_throw_error( "Cannot store something that is tied." );
            }

            unless ( $tmpvar-&gt;_engine-&gt;storage == $self-&gt;storage ) {
                DBM::Deep-&gt;_throw_error( "Cannot store values across DBM::Deep files. Please use export() instead." );
            }

            # Load $tmpvar's sector

            # First, verify if we're storing the same thing to this spot. If we
            # are, then this should be a no-op. -EJS, 2008-05-19
            
            # See whether or not we are storing ourselves to ourself.
            # Write the sector as data in this reference (keyed by $key)
            my $value_sector = $self-&gt;load_sector( $tmpvar-&gt;_base_offset, 'refs' );
            $sector-&gt;write_data({
                key     =&gt; $key,
#                key_md5 =&gt; $self-&gt;_apply_digest( $key ),
                value   =&gt; $value_sector,
            });
            $value_sector-&gt;increment_refcount;

            return 1;
        }

        $type = substr( $r, 0, 1 );
        $class = 'DBM::Deep::Sector::DBI::Reference';
    }
    else {
        if ( tied($value) ) {
            DBM::Deep-&gt;_throw_error( "Cannot store something that is tied." );
        }

        if ( ref $value eq 'DBM::Deep::Null' ) {
            DBM::Deep::_warnif(
             'uninitialized', 'Assignment of stale reference'
            );
            $value = undef;
        }

        $class = 'DBM::Deep::Sector::DBI::Scalar';
        $type  = 'S';
    }

    # Create this after loading the reference sector in case something bad
    # happens. This way, we won't allocate value sector(s) needlessly.
    my $value_sector = $class-&gt;new({
        engine =&gt; $self,
        data   =&gt; $value,
        type   =&gt; $type,
    });

    $sector-&gt;write_data({
        key     =&gt; $key,
#        key_md5 =&gt; $self-&gt;_apply_digest( $key ),
        value   =&gt; $value_sector,
    });

    $self-&gt;_descend( $value, $value_sector );

    return 1;
}

#sub begin_work {
#    my $self = shift;
#    die "Transactions are not supported by this engine"
#        unless $self-&gt;supports('transactions');
#
#    if ( $self-&gt;in_txn ) {
#        DBM::Deep-&gt;_throw_error( "Cannot begin_work within an active transaction" );
#    }
#
#    $self-&gt;storage-&gt;begin_work;
#
#    $self-&gt;in_txn( 1 );
#
#    return 1;
#} 
#
#sub rollback {
#    my $self = shift;
#    die "Transactions are not supported by this engine"
#        unless $self-&gt;supports('transactions');
#
#    if ( !$self-&gt;in_txn ) {
#        DBM::Deep-&gt;_throw_error( "Cannot rollback without an active transaction" );
#    }
#
#    $self-&gt;storage-&gt;rollback;
#
#    $self-&gt;in_txn( 0 );
#
#    return 1;
#} 
#
#sub commit {
#    my $self = shift;
#    die "Transactions are not supported by this engine"
#        unless $self-&gt;supports('transactions');
#
#    if ( !$self-&gt;in_txn ) {
#        DBM::Deep-&gt;_throw_error( "Cannot commit without an active transaction" );
#    }
#
#    $self-&gt;storage-&gt;commit;
#
#    $self-&gt;in_txn( 0 );
#
#    return 1;
#}
#
#sub in_txn {
#    my $self = shift;
#    $self-&gt;{in_txn} = shift if @_;
#    $self-&gt;{in_txn};
#}

sub supports {
    my $self = shift;
    my ($feature) = @_;

    return if $feature eq 'transactions';
    return 1 if $feature eq 'singletons';
    return;
}

sub db_version {
    return '1.0020'
}

sub clear {
    my $self = shift;
    my $obj = shift;

    my $sector = $self-&gt;load_sector( $obj-&gt;_base_offset, 'refs' )
        or return;

    $sector-&gt;clear;

    return;
}

1;
__END__
</pre></body></html>