view release on metacpan or  search on metacpan

lib/DBD/DBM.pm  view on Meta::CPAN

    # define valid private attributes
    #
    # attempts to set non-valid attrs in connect() or
    # with $dbh->{attr} will throw errors
    #
    # the attrs here *must* start with dbm_ or foo_
    #
    # see the STORE methods below for how to check these attrs
    #
    $dbh->{dbm_valid_attrs} = {
                                dbm_type           => 1,    # the global DBM type e.g. SDBM_File
                                dbm_mldbm          => 1,    # the global MLDBM serializer
                                dbm_cols           => 1,    # the global column names
                                dbm_version        => 1,    # verbose DBD::DBM version
                                dbm_store_metadata => 1,    # column names, etc.
                                dbm_berkeley_flags => 1,    # for BerkeleyDB
                                dbm_valid_attrs    => 1,    # DBD::DBM::db valid attrs
                                dbm_readonly_attrs => 1,    # DBD::DBM::db r/o attrs
                                dbm_meta           => 1,    # DBD::DBM public access for f_meta
                                dbm_tables         => 1,    # DBD::DBM public access for f_meta
                              };
    $dbh->{dbm_readonly_attrs} = {
                                   dbm_version        => 1,    # verbose DBD::DBM version
                                   dbm_valid_attrs    => 1,    # DBD::DBM::db valid attrs
                                   dbm_readonly_attrs => 1,    # DBD::DBM::db r/o attrs
                                   dbm_meta           => 1,    # DBD::DBM public access for f_meta
                                 };

    $dbh->{dbm_meta} = "dbm_tables";

    return $dbh->SUPER::init_valid_attributes();
}

sub init_default_attributes
{
    my ( $dbh, $phase ) = @_;

    $dbh->SUPER::init_default_attributes($phase);
    $dbh->{f_lockfile} = '.lck';

    return $dbh;
}

sub get_dbm_versions
{
    my ( $dbh, $table ) = @_;
    $table ||= '';

    my $meta;
    my $class = $dbh->{ImplementorClass};
    $class =~ s/::db$/::Table/;
    $table and ( undef, $meta ) = $class->get_table_meta( $dbh, $table, 1 );
    $meta or ( $meta = {} and $class->bootstrap_table_meta( $dbh, $meta, $table ) );

    my $dver;
    my $dtype = $meta->{dbm_type};
    eval {
        $dver = $meta->{dbm_type}->VERSION();

        # *) when we're still alive here, everything went ok - no need to check for $@
        $dtype .= " ($dver)";
    };
    if ( $meta->{dbm_mldbm} )
    {
        $dtype .= ' + MLDBM';
        eval {
            $dver = MLDBM->VERSION();
            $dtype .= " ($dver)";    # (*)
        };
        eval {
            my $ser_class = "MLDBM::Serializer::" . $meta->{dbm_mldbm};
            my $ser_mod   = $ser_class;
            $ser_mod =~ s|::|/|g;
            $ser_mod .= ".pm";
            require $ser_mod;
            $dver = $ser_class->VERSION();
            $dtype .= ' + ' . $ser_class;    # (*)
            $dver and $dtype .= " ($dver)";  # (*)
        };
    }
    return sprintf( "%s using %s", $dbh->{dbm_version}, $dtype );
}

# you may need to over-ride some DBD::File::db methods here
# but you can probably get away with just letting it do the work
# in most cases

#####################
package DBD::DBM::st;
#####################
our $imp_data_size = 0;
our @ISA           = qw(DBD::File::st);

sub FETCH
{
    my ( $sth, $attr ) = @_;

    if ( $attr eq "NULLABLE" )
    {
        my @colnames = $sth->sql_get_colnames();

        # XXX only BerkeleyDB fails having NULL values for non-MLDBM databases,
        #     none accept it for key - but it requires more knowledge between
        #     queries and tables storage to return fully correct information
        $attr eq "NULLABLE" and return [ map { 0 } @colnames ];
    }

    return $sth->SUPER::FETCH($attr);
}    # FETCH

sub dbm_schema
{
    my ( $sth, $tname ) = @_;
    return $sth->set_err( $DBI::stderr, 'No table name supplied!' ) unless $tname;
    my $tbl_meta = $sth->{Database}->func( $tname, "f_schema", "get_sql_engine_meta" )
      or return $sth->set_err( $sth->{Database}->err(), $sth->{Database}->errstr() );
    return $tbl_meta->{$tname}->{f_schema};
}
# you could put some :st private methods here