File Coverage

blib/lib/DBIx/Query.pm

Criterion	Covered	Total	%
statement	277	392	70.6
branch	49	118	41.5
condition	20	41	48.7
subroutine	72	94	76.6
pod	2	2	100.0
total	420	647	64.9

package DBIx::Query;
# ABSTRACT: Simplified abstracted chained DBI subclass

use 5.010;
use strict;
use warnings;

our $VERSION = '1.17'; # VERSION

use DBI 1.40;
use parent 'DBI';

{
    no warnings 'once';
    *errstr = \*DBI::errstr;
}

sub _connect {
    my ( $self, $dsn, $user, $pass, $attr, $connect ) = @_;

    $attr = ($attr) ? \%$attr : {};
    $attr->{PrintError} = 0 unless ( exists $attr->{PrintError} );
    $attr->{RaiseError} = 1 unless ( exists $attr->{RaiseError} );

    return $self->SUPER::connect( $dsn, $user, $pass, {
        %$attr,
        dbi_connect_method => ( $DBI::connect_via eq 'Apache::DBI::connect' )
            ? 'Apache::DBI::connect' : $connect,
    } );
}

sub connect {
    my ( $self, $dsn, $user, $pass, $attr ) = @_;
    return $self->_connect( $dsn, $user, $pass, $attr, 'connect_cached' );
}

sub connect_uncached {
    my ( $self, $dsn, $user, $pass, $attr ) = @_;
    return $self->_connect( $dsn, $user, $pass, $attr, 'connect' );
}

#-----------------------------------------------------------------------------

{
    package DBIx::Query::_Common;
    use strict;
    use warnings;
    use Carp 'croak';

    sub _param {
        my $self = shift;
        my $name = shift;

        return unless ($name);
        $self->{'private_dq_stash'}{$name} = shift if (@_);
        return $self->{'private_dq_stash'}{$name};
    }

    sub _try {
        my ( $self, $cb ) = @_;

        local $@;
        eval { $cb->() };
        if ($@) {
            ( my $error = $@ ) =~ s/\s*at.+?line \d+\.\s*//;
            croak $error;
        }
    }
}

#-----------------------------------------------------------------------------

{
    package DBIx::Query::db;
    use strict;
    use warnings;
    use SQL::Parser;
    use SQL::Abstract::Complete;
    use Carp 'carp';

    use vars '@ISA';
    @ISA = qw( DBI::db DBIx::Query::_Common );

    sub connected {
        my $self = shift;

        my $connection = {};
        @{$connection}{qw( dsn user pass attr )} = @_;

        $self->_param( 'connection'   => $connection );
        $self->_param( 'sql_abstract' => SQL::Abstract::Complete->new );

        my $dialect = ( ref $connection eq 'HASH' and ref $connection->{attr} eq 'HASH' )
            ? $connection->{attr}{dq_dialect}
            : undef;

        my $sql_parser = SQL::Parser->new(
            ( $dialect || 'ANSI' ),
            { 'RaiseError' => 0, 'PrintError' => 0 },
        );

        unless ($dialect) {
            $sql_parser->feature( 'reserved_words', $_, 0 )
                for ( keys %{ $sql_parser->{opts}{reserved_words} } );
        }

        $self->_param( 'sql_parser'       => $sql_parser );
        $self->_param( '_dq_parser_cache' => {} );

        return;
    }

    sub connection {
        my $self = shift;

        return
            ( @_ == 0 and wantarray     ) ? @{ $self->_param('connection') }{ qw( dsn user pass attr ) } :
            ( @_ == 0 and not wantarray ) ? $self->_param('connection')                                  :
            ( @_ > 1 and wantarray      ) ? @{ $self->_param('connection') }{@_}                         :
            ( @_ > 1 and not wantarray  ) ? [ @{ $self->_param('connection') }{@_} ]                     :
            @{ $self->_param('connection') }{@_};
    }

    sub _sth_setup {
        my ( $self, $sql, $attr, $cache_type, $variables ) = @_;

        my $sth;
        $self->_try( sub {
            $sth = ( defined $cache_type and $cache_type == -1 )
                ? $self->SUPER::prepare( $sql, $attr )
                : $self->SUPER::prepare_cached( $sql, $attr, $cache_type );
        } );

        return $sth;
    }

    sub _query {
        my ( $self, $sql, $attr, $cache_type, $variables ) = @_;
        $cache_type //= 3;

        my $sth = $self->_sth_setup( $sql, $attr, $cache_type, $variables );

        $sql =~ s/(\r?\n|\s+)/ /g;
        $sql =~ s/^\s+|\s+$//g;

        $sth->_param( 'sql'       => $sql       );
        $sth->_param( 'dq'        => $self      );
        $sth->_param( 'variables' => $variables );

        return $sth;
    }

    sub sql {
        my ( $self, $sql, $attr, $cache_type, $variables ) = @_;
        $self->_croak('SQL input missing in sql() call') unless ( length $sql );
        return $self->_query( $sql, $attr, $cache_type, $variables );
    }

    sub get {
        my ( $self, $tables, $columns, $where, $meta, $attr, $cache_type ) = @_;
        my ( $sql, @variables ) = $self->_param('sql_abstract')->select( $tables, $columns, $where, $meta );
        my $sth = $self->_query( $sql, $attr, $cache_type, \@variables );

        $sth->_param( 'query' => {
            'tables'     => $tables,
            'columns'    => $columns,
            'where'      => $where,
            'meta'       => $meta,
            'attr'       => $attr,
            'cache_type' => $cache_type,
            'sql'        => $sql,
            'variables'  => \@variables,
        } );

        return $sth;
    }

    sub sql_uncached {
        my ( $self, $sql, $attr, $cache_type, $variables ) = @_;
        $cache_type = -1;
        return $self->sql( $sql, $attr, $cache_type, $variables );
    }

    sub get_uncached {
        my ( $self, $tables, $columns, $where, $meta, $attr, $cache_type ) = @_;
        $cache_type = -1;
        return $self->get( $tables, $columns, $where, $meta, $attr, $cache_type );
    }

    sub sql_fast {
        my $self = shift;
        carp('sql_fast() is deprecated in favor of sql()');
        return $self->sql(@_);
    }

    sub get_fast {
        my $self = shift;
        carp('get_fast() is deprecated in favor of get()');
        return $self->get(@_);
    }

    sub add {
        my ( $self, $table_name, $params, $attr, $cache_type ) = @_;
        my ( $sql, @variables ) = $self->_param('sql_abstract')->insert( $table_name, $params );

        $self->_try( sub {
            my $sth = $self->sql( $sql, $attr, $cache_type, \@variables );
            $sth->execute( @{ $sth->_param('variables') || [] } );
        } );

        my $pk;
        eval {
            $pk = $self->last_insert_id(
                undef,
                undef,
                delete $attr->{'last_insert_table'} || $table_name,
                undef,
                $attr,
            );
        };

        $self->_param( 'table' => $table_name );

        return $pk;
    }

    sub rm {
        my ( $self, $table_name, $params, $attr, $cache_type ) = @_;

        my ( $sql, @variables ) = $self->_param('sql_abstract')->delete( $table_name, $params );
        my $sth = $self->sql( $sql, $attr, $cache_type, \@variables );

        $sth->run;
        return $self;
    }

    sub update {
        my ( $self, $table_name, $params, $where, $attr, $cache_type ) = @_;

        my ( $sql, @variables ) = $self->_param('sql_abstract')->update( $table_name, $params, $where );
        my $sth = $self->sql( $sql, $attr, $cache_type, \@variables );

        $sth->run;
        return $self;
    }

    sub abstract {
        return $_[0]->_param('sql_abstract');
    }

    sub get_run {
        my $self = shift;
        my $sth = $self->get(@_);

        $self->_try( sub {
            $sth->execute( @{ $sth->_param('variables') || [] } );
        } );

        return $sth;
    }

    sub fetch_value {
        my $self = shift;
        my $sth  = $self->get_run(@_);
        my $value;

        $self->_try( sub {
            $value = ( $sth->fetchrow_array )[0];
            $sth->finish;
        } );

        return $value;
    }

    sub fetchall_arrayref {
        my $self = shift;
        my $sth  = $self->get_run(@_);
        my $value;

        $self->_try( sub {
            $value = $sth->fetchall_arrayref;
            $sth->finish;
        } );

        return $value;
    }

    sub fetchall_hashref {
        my $self = shift;
        my $sth  = $self->get_run(@_);
        my $value;

        $self->_try( sub {
            $value = $sth->fetchall_arrayref({});
            $sth->finish;
        } );

        return $value;
    }

    sub fetch_column_arrayref {
        my $self = shift;
        return [ map { $_->[0] } @{ $self->fetchall_arrayref(@_) } ];
    }

    sub fetchrow_hashref {
        my ( $self, $sql ) = ( shift, shift );
        $self->_croak('SQL input missing in sql() call') unless ( length $sql );

        my ( $variables, $attr, $cache_type );
        if ( not defined $_[0] or ref $_[0] eq 'HASH' ) {
            ( $variables, $attr, $cache_type ) = @_;
        }
        else {
            $variables = \@_;
        }
        $cache_type //= 3;

        my $row;
        $self->_try( sub {
            my $sth = $self->_sth_setup( $sql, $attr, $cache_type, $variables );
            $sth->execute(@$variables);
            $row = $sth->fetchrow_hashref;
            $sth->finish;
        } );

        return $row;
    }
}

#-----------------------------------------------------------------------------

{
    package DBIx::Query::st;
    use strict;
    use warnings;
    use Carp qw( croak carp );

    use vars '@ISA';
    @ISA = qw( DBI::st DBIx::Query::_Common );

    sub where {
        my $self = shift;

        croak('Unable to call where() because upstream query not originated with get()')
            unless ( $self->_param('query') );

        croak('where() requires a hashref or an even number of items in a list')
            if ( ref( $_[0] ) ne 'HASH' and @_ % 2 );

        my $query = $self->_param('query');
        $query->{'where'} = { %{ $query->{'where'} || {} }, ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_ };

        return $self->up->get( @{$query}{ qw( tables columns where meta attr cache_type ) } );
    }

    sub run {
        my $self  = shift;
        my @input = @_;

        $self->_try( sub {
            $self->execute( (@input) ? @input : @{ $self->_param('variables') || [] } );
        } );

        return DBIx::Query::_Dq::RowSet->new($self);
    }

    sub sql {
        my ( $self, $sql ) = @_;
        return ($sql) ? $self->_param('dq')->sql($sql) : $self->_param('sql');
    }

    sub structure {
        my $self = shift;

        my $saved_structure = $self->_param('structure');
        return $saved_structure if ($saved_structure);
        return if ( $self->_param('no_structure') );

        my $sql             = $self->_param('sql');
        my $dq_parser_cache = $self->_param('dq')->_param('_dq_parser_cache');

        unless ( $dq_parser_cache->{$sql} ) {
            $self->_param('dq')->_param('sql_parser')->parse($sql);
            my $parsed_structure = $self->_param('dq')->_param('sql_parser')->structure;
            $dq_parser_cache->{$sql} = $parsed_structure;
            carp $parsed_structure->{'errstr'} if ( $parsed_structure->{errstr} );
        }

        $self->_param( 'wildcard_column' => 0 );

        if ( $dq_parser_cache->{$sql} ) {
            my $structure    = $dq_parser_cache->{$sql};
            my $column_index = 0;
            my %aliases;

            {
                no warnings;
                $structure->{'column_lookup'} = {
                    map {
                        my $index = $column_index++;
                        $aliases{ $_->{'alias'} } = $index if ( $_->{'alias'} );
                        $self->_param( 'wildcard_column' => 1 ) if ( $_->{'value'} eq '*' );
                        $_->{'value'} => $index;
                    } @{ $structure->{'column_defs'} }
                };
            };

            $structure->{'column_invert_lookup'} = {
                map { $structure->{'column_lookup'}->{$_} => $_ } keys %{ $structure->{'column_lookup'} }
            };
            foreach ( keys %aliases ) {
                $structure->{'column_lookup'}{$_}                    = $aliases{$_};
                $structure->{'column_invert_lookup'}{ $aliases{$_} } = $_;
            }

            $self->_param( 'structure' => $structure );
            return $structure;
        }
        else {
            $self->_param( 'no_structure' => 1 );
            return;
        }
    }

    sub table {
        return shift->structure->{'table_names'}[0];
    }

    sub _wildcard_column {
        my $self = shift;

        my $wildcard_column = $self->_param('wildcard_column');
        return $wildcard_column if ( defined $wildcard_column );

        $self->structure;
        return $self->_param('wildcard_column');
    }

    sub up {
        return shift->_param('dq');
    }
}

#-----------------------------------------------------------------------------

{
    package DBIx::Query::_Dq::RowSet;
    use strict;
    use warnings;
    use Carp 'croak';

    sub new {
        my ( $self, $sth ) = @_;
        return bless( { 'sth' => $sth }, $self );
    }

    sub next {
        my ( $self, $skip ) = @_;
        $skip ||= 0;

        my $method = ( $self->{'sth'}->_wildcard_column ) ? 'fetchrow_hashref' : 'fetchrow_arrayref';

        my $value;
        DBIx::Query::_Common::_try( $self, sub {
            $self->{'sth'}->fetchrow_arrayref while ( $skip-- );

            if ( my $row = $self->{'sth'}->$method ) {
                $value = DBIx::Query::_Dq::Row->new( $row, $self );
            }
        } );

        return $value if ($value);
    }

    sub all {
        my $self  = shift;
        my @input = @_;

        my $value;
        DBIx::Query::_Common::_try( $self, sub {
            $value = $self->{'sth'}->fetchall_arrayref(@input);
            $self->{'sth'}->finish;
        } );

        return $value;
    }

    sub each {
        my ( $self, $code ) = @_;
        my $method = ( $self->{'sth'}->_wildcard_column ) ? 'fetchrow_hashref' : 'fetchrow_arrayref';

        DBIx::Query::_Common::_try( $self, sub {
            $code->( DBIx::Query::_Dq::Row->new( $_, $self ) ) while ( $_ = $self->{'sth'}->$method );
            $self->{'sth'}->finish;
        } );

        return $self;
    }

    sub value {
        my $self  = shift;

        my @value;
        DBIx::Query::_Common::_try( $self, sub {
            @value = $self->{'sth'}->fetchrow_array;
            $self->{'sth'}->finish;
        } );

        my $wantarray = wantarray;
        if ( not defined $wantarray ) {
            croak('value() must not be called in void context');
        }
        elsif ( not wantarray ) {
            if ( @value < 2 ) {
                return $value[0];
            }
            else {
                croak('value() called in scalar context but multiple values fetched');
            }
        }
        else {
            return @value;
        }
    }

    sub first {
        my ( $self, $type ) = @_;
        my $method = ( ref $type eq 'HASH' ) ? 'fetchrow_hashref' : 'fetchrow_arrayref';

        my $value;
        DBIx::Query::_Common::_try( $self, sub {
            $value = $self->{'sth'}->$method;
            $self->{'sth'}->finish;
        } );

        return $value;
    }

    sub column {
        my $self   = shift;
        my @values = map { $_->[0] } @{ ( $self->all )[0] };

        return (wantarray) ? @values : \@values;
    }

    sub up {
        return shift->{'sth'};
    }
}

#-----------------------------------------------------------------------------

{
    package DBIx::Query::_Dq::Row;
    use strict;
    use warnings;
    use Carp 'croak';

    sub new {
        my ( $self, $row, $set ) = @_;
        return bless(
            {
                'row' => $row,
                'set' => $set,
            },
            $self,
        );
    }

    sub cell {
        my ( $self, $index, $new_value ) = @_;
        my ( $name, $structure, $value ) = ( $index, $self->up->up->structure, undef );

        croak('Query used earlier in chain failed to parse, so cell() cannot be called')
            unless ( ref($structure) eq 'HASH' );

        if ( ref( $self->{'row'} ) eq 'ARRAY' ) {
            unless ( $index =~ /^\d+$/ ) {
                $name  = $index;
                $index = $structure->{'column_lookup'}{$index};
            }
            return undef unless ( defined $index and $index < @{ $self->{'row'} } );
            $value = $self->{'row'}[$index];
        }
        else {
            croak('cell() called with integer index but query does not support integer indexing')
                if ( $index =~ /^\d+$/ );

            return undef unless ( exists $self->{'row'}{$index} );
            $value = $self->{'row'}{$index};
        }

        if ( defined $new_value ) {
            if ( ref( $self->{'row'} ) eq 'ARRAY' ) {
                $self->{'row'}[$index] = $new_value;
            }
            else {
                $self->{'row'}{$name} = $new_value;
            }
            $value = $new_value;
        }

        return DBIx::Query::_Dq::Cell->new( $name, $value, $index, $self );
    }

    sub each {
        my ( $self, $code ) = @_;

        croak('each() called on a row object that does not have columns defined')
            if ( ref( $self->{'row'} ) ne 'ARRAY' );

        for ( my $i = 0 ; $i < @{ $self->{'row'} } ; $i++ ) {
            $code->(
                DBIx::Query::_Dq::Cell->new(
                    $self->up->up->structure->{'column_lookup'}{$i},
                    $self->{'row'}[$i],
                    $i, $self,
                )
            );
        }

        return $self;
    }

    sub data {
        my ($self) = @_;

        if ( ref( $self->{'row'} ) eq 'ARRAY' ) {
            my $structure = $self->up->up->structure;
            if ( ref($structure) eq 'HASH' and $structure->{'column_invert_lookup'} ) {
                return {
                    map {
                        $structure->{'column_invert_lookup'}->{$_} => $self->{'row'}[$_]
                    } ( 0 .. scalar( @{ $self->{'row'} } ) - 1 )
                };
            }
            else {
                croak('Unable to parse SQL, therefore data() unavailable; use row() instead');
            }
        }
        else {
            return $self->{'row'};
        }
    }

    sub row {
        my ($self) = @_;
        croak('For this particular query, use data() instead')
            unless ( ref( $self->{'row'} ) eq 'ARRAY' );
        return $self->{'row'};
    }

    sub save {
        my ( $self, $key, $params, $cache_type ) = @_;

        croak('save() called without a key or set of keys') unless ($key);

        my $data = $self->data;
        if ( ref($params) eq 'HASH' ) {
            $data->{$_} = $params->{$_} foreach ( keys %{$params} );
        }

        my $dq = $self->up->up->up;

        my ( $sql, @variables ) = $dq->_param('sql_abstract')->update(
            $self->up->up->table,
            $data,
            { map { $_ => delete $data->{$_} } ( ref($key) ? @{$key} : $key ) },
        );
        my $sth = $dq->sql( $sql, undef, $cache_type, \@variables );

        $sth->run;
        return $self;
    }

    sub up {
        return shift->{'set'};
    }
}

#-----------------------------------------------------------------------------

{
    package DBIx::Query::_Dq::Cell;
    use strict;
    use warnings;

    sub new {
        my ( $self, $name, $value, $index, $row ) = @_;
        return bless(
            {
                'name'  => $name,
                'value' => $value,
                'index' => $index,
                'row'   => $row,
            },
            $self,
        );
    }

    sub name {
        return shift->{'name'};
    }

    sub value {
        my ( $self, $new_value ) = @_;
        return ( defined $new_value ) ? $self->up->cell( $self->name, $new_value ) : $self->{'value'};
    }

    sub index {
        return shift->{'index'};
    }

    sub save {
        return shift->up->save(@_);
    }

    sub up {
        return shift->{'row'};
    }
}

1;

__END__