view release on metacpan or  search on metacpan

lib/DBIx/Abstract.pm  view on Meta::CPAN

# ABSTRACT: DBI SQL abstraction
package DBIx::Abstract;
$DBIx::Abstract::VERSION = '1.04';
use DBI;
use Scalar::Util 'weaken';
use Check::ISA qw( obj_does );
use strict;
use warnings;

our $AUTOLOAD;

sub ___drivers {
    my ( $driver, $config ) = @_;
    my %drivers = (

        # Feel free to add new drivers... note that some DBD data_sources
        # do not translate well (eg Oracle).
        mysql => "dbi:mysql:$config->{dbname}:$config->{host}:$config->{port}",
        msql  => "dbi:msql:$config->{dbname}:$config->{host}:$config->{port}",

        # According to DBI, drivers should use the below if they have no
        # other preference.  It is ODBC style.
        DEFAULT => "dbi:$driver:"
    );

    # Make Oracle look a little bit like other DBs.
    # Right now we only have one hack, but I can imagine there being
    # more...
    if ( $driver eq 'Oracle' ) {
        $config->{'sid'} ||= delete( $config->{'dbname'} );
    }

    my @keys;
    foreach ( sort keys %$config ) {
        next if /^user$/;
        next if /^password$/;
        next if /^driver$/;
        push( @keys, "$_=$config->{$_}" );
    }
    $drivers{'DEFAULT'} .= join( ';', @keys );
    if ( $drivers{$driver} ) {
        return $drivers{$driver};
    }
    else {
        return $drivers{'DEFAULT'};
    }
}

sub connect {
    my $class = shift;
    my ( $config, $options ) = @_;
    my ( $dbh, $data_source, $user, $pass, $driver, $dbname, $host, $port );
    my $self = {};

    if ( !defined($config) ) {
        require Carp;
        Carp::croak( "DBIx::Abstract->connect A connection configuration must be provided." );
    }
    elsif ( ref($config) eq 'HASH' ) {
        if ( $config->{'dbh'} ) {
            $dbh = $config->{'dbh'};
        }
        else {
            $user = $config->{'user'}     || $config->{'username'};
            $pass = $config->{'password'} || $config->{'pass'};

lib/DBIx/Abstract.pm  view on Meta::CPAN

            foreach ( @{ $self->{'CLONES'} } ) {
                if ( ref($_) ) {
                    if ( $_->DESTROY == -1 ) {
                        warn
"Error: DBIx::Abstract tried to recurse into $_ from $self during DESTROY \n";
                    }
                }
                else {

                # Shouldn't be possible to get here... but Perl's destruction is
                # a bit weird.  I guess I wouldn't expect less from the
                # apocalypse.
                #          warn "Error: DBIx::Abstract clone not object\n";
                }
                $_ = undef;
            }
        }
        $self->{'sth'}->finish if ref( $self->{'sth'} );

        # Close our handle if we opened it and its still around
        if ( !$self->{'connect'}{'dbh'} and defined( $self->{'dbh'} ) ) {
            $self->{'dbh'}->disconnect;
        }
    }
    else {
        my $new = [];
        foreach ( @{ $self->{'ORIG'}->{'CLONES'} } ) {
            if ( defined($_) and ref($_) and $self ne $_ ) {
                push( @$new, $_ );
            }
        }
        $self->{'ORIG'}->{'CLONES'} = $new;
    }
    $self->{'sth'}->finish if ref( $self->{'sth'} );
## Apparently this can cause $self->{'dbh'} to be deleted prior to
## disconnect being called.  Bleah.
    #  delete($self->{'dbh'});
    delete( $self->{'sth'} );

    #  delete($self->{'connect'});
    delete( $self->{'options'} );
    delete( $self->{'MODQUERY'} );
    delete( $self->{'ORIG'} );
    delete( $self->{'CLONES'} );
    return 0;
}

sub clone {
    my $self    = shift;
    my $class   = ref($self);
    my $newself = {%$self};
    delete( $newself->{'CLONES'} );
    delete( $newself->{'ORIG'} );
    bless $newself, $class;
    if ( !$self->{'ORIG'} ) {
        $newself->{'ORIG'} = $self;
    }
    else {
        $newself->{'ORIG'} = $self->{'ORIG'};
    }
    weaken( $newself->{'ORIG'} );

    push( @{ $newself->{'ORIG'}->{'CLONES'} }, $newself );
    weaken(
        $newself->{'ORIG'}->{'CLONES'}[ $#{ $newself->{'ORIG'}->{'CLONES'} } ]
    );

    $self->__logwrite( 5, 'Cloned' );
    return $newself;
}

my %valid_opts = map( { $_ => 1 } qw(
      loglevel logfile saveSQL useCached delaymods
      ) );

sub opt {
    my $self = shift;
    my ( $key, $value ) = @_;
    if ( ref($key) ) {
        $value = $key->{'value'};
        $key   = $key->{'key'};
    }
    my $ret;
    if ( $valid_opts{$key} ) {
        $ret = $self->{'options'}{$key};
    }
    elsif ( exists( $self->{'dbh'}{$key} ) ) {
        $ret = $self->{'dbh'}{$key};
    }
    else {
        die "DBIx::Abstract->opt Unknown option $key\n";
    }
    if ( defined($value) ) {
        if ( $valid_opts{$key} ) {
            $self->{'options'}{$key} = $value;
        }
        else {
            eval { $self->{'dbh'}->{$key} = $value };
            if ($@) {
                warn $@;
                return $ret;
            }
        }
        $self->__logwrite(
            5,
            'Option change',
            $key   ? $key   : '',
            $ret   ? $ret   : '',
            $value ? $value : ''
        );
    }
    return $ret;
}

sub __literal_query {
    my $self = shift;
    # This actually makes a query
    # All of the other related query functions (eventually) call this
    my ( $sql, @bind_values ) = @_;
    my $sth;
    if ( $self->opt('saveSQL') ) {
        my @bind_copy = @bind_values;
        $self->{'lastsql'} = $sql;
        $self->{'lastsql'} =~ s/\?/$self->quote(shift(@bind_copy))/eg;