File Coverage

blib/lib/SQL/DB/Expr.pm

Criterion	Covered	Total	%
statement	248	294	84.3
branch	72	110	65.4
condition	9	19	47.3
subroutine	59	65	90.7
pod	13	13	100.0
total	401	501	80.0

package SQL::DB::Expr;
use strict;
use warnings;
use DBI qw/looks_like_number :sql_types/;
use Moo;
use Carp qw/ carp croak confess/;
use Sub::Exporter -setup => {
    exports => [
        qw/
          AND
          OR
          _sql
          _quote
          _bval
          _expr_binary
          _expr_join
          _query
          /
    ],
    groups => { default => [qw/ /], },
};
use overload
  '""'     => '_as_string',
  '!'      => '_expr_not',
  '=='     => '_expr_eq',
  'eq'     => '_expr_eq',
  '!='     => '_expr_ne',
  'ne'     => '_expr_ne',
  '&'      => '_expr_bitand',
  '|'      => '_expr_bitor',
  '<'      => '_expr_lt',
  '>'      => '_expr_gt',
  '<='     => '_expr_lte',
  '>='     => '_expr_gte',
  '+'      => '_expr_add',
  '-'      => '_expr_sub',
  '*'      => '_expr_mult',
  '/'      => '_expr_divide',
  '.'      => '_expr_addstr',
  '.='     => '_expr_addstr',
  fallback => 1,
  ;

our $VERSION = '0.971.0';
our $tcount  = {};

# ########################################################################
# FUNCTIONS
# ########################################################################

sub AND {
    SQL::DB::Expr->new(
        _txt   => [' AND '],
        _logic => 1
    );
}

sub OR {
    SQL::DB::Expr->new(
        _txt   => [' OR '],
        _logic => 1
    );
}

sub _sql {
    my $val = shift;

    return $val if ( ref $val ) =~ m/^SQL::DB::Expr/;

    return SQL::DB::Expr::SQL->new( val => $val );
}

sub _quote {
    my $val = shift;

    return $val if ( ref $val ) =~ m/^SQL::DB::Expr/;

    return SQL::DB::Expr::Quote->new( val => $val );
}

sub _bval {
    my ( $val, $type ) = @_;

    return $val if ( ref $val ) =~ m/^SQL::DB::Expr/;

    return SQL::DB::Expr::BindValue->new( val => $val, type => $type );
}

sub _expr_join {
    my $sep  = shift;
    my $last = pop @_;

    my $e = SQL::DB::Expr->new(
        _txt => [
            (
                map {
                    eval { $_->isa('SQL::DB::Expr') }
                      ? ( $_->_txts, $sep )
                      : ( $_, $sep )
                } @_
            ),
            eval { $last->isa('SQL::DB::Expr') } ? $last->_txts : $last
        ]
    );
    return $e;
}

sub _query {
    return $_[0] if ( @_ == 1 and eval { $_[0]->isa('SQL::DB::Expr') } );
    my $e = SQL::DB::Expr->new;

    eval {
        while ( my ( $keyword, $item ) = splice( @_, 0, 2 ) )
        {
            if ( ref $keyword ) {
                $e .= $keyword . "\n";
            }
            else {
                ( my $tmp = uc($keyword) ) =~ s/_/ /g;
                $e .= $tmp . "\n";
            }

            next unless defined $item;
            if ( ref $item eq 'SQL::DB::Expr' ) {
                $e .= '    ' . $item . "\n";
            }
            elsif ( ref $item eq 'ARRAY' ) {
                my @new = map { ref $_ ? $_ : _bval($_) } @$item;
                $e .= '    ' . _expr_join( ",\n    ", @new ) . "\n";
            }
            elsif ( ref $item eq 'SCALAR' ) {
                $e .= '    ' . $$item . "\n";
            }
            else {
                $e .= '    ' . $item . "\n";
            }

            $e->_multi(0);
        }
    };

    confess "Bad Query: $@" if $@;
    return $e;
}

# ########################################################################
# OBJECT INTERFACE
# ########################################################################

has '_txt' => (
    is => 'rw',
    isa =>
      sub { confess "Must be ARRAY ref: $_[0]" unless ref $_[0] eq 'ARRAY' },
    default => sub { [] },
);

has '_alias' => ( is => 'rw', );

has '_type' => ( is => 'rw', );

has '_multi' => (
    is      => 'rw',
    default => sub { 0 },
);

has '_logic' => (
    is      => 'rw',
    default => sub { 0 },
);

sub BUILD {
    my $self = shift;

    if ( my $name = $self->_alias ) {
        $tcount->{$name} ||= [];
        my $i = 0;
        while ( $tcount->{$name}->[$i] ) {
            $i++;
        }
        $tcount->{$name}->[$i] = 1;
        $self->_alias( $name . $i );
        $self->_txt( [ $name . ' AS ' . $name . $i ] );
    }
}

sub _txts {
    return @{ shift->_txt };
}

sub _clone {
    my $self = shift;
    bless {%$self}, ref $self;
}

sub _as_string {
    my $self = shift;

    return join( '', map { defined $_ ? $_ : '*UNDEF*' } $self->_txts );
}

sub _as_pretty {
    my $self = shift;
    my $dbh  = shift;

    my $sql;

    foreach my $token ( $self->_txts ) {
        if ( ref $token eq 'SQL::DB::Expr::Quote' ) {
            $sql .= $dbh->quote( $token->val );
        }
        elsif ( ref $token eq 'SQL::DB::Expr::BindValue' ) {
            my $val  = $token->val;
            my $type = $token->type;

            if ( !defined $val ) {
                $sql .= $dbh->quote(undef);
                next;
            }
            elsif ( $val =~ /[\P{IsPrint}]/ ) {
                $sql .= '/*BINARY DATA*/';
            }
            elsif ( looks_like_number($val) ) {
                $sql .= $val;
            }
            else {
                ( my $x = $val ) =~ s/\n.*/\.\.\./s;
                $sql .= $dbh->quote($val);
            }
        }
        else {
            $sql .= $token;
        }
    }
    return $sql . ';';

}

my %type_map = (
    biginteger          => { TYPE => SQL_BIGINT },
    bigint              => { TYPE => SQL_BIGINT },
    binary              => { TYPE => SQL_BINARY },
    'binary varying'    => { TYPE => SQL_VARBINARY },
    bin                 => { TYPE => SQL_BINARY },
    bit                 => { TYPE => SQL_BIT },
    blob                => { TYPE => SQL_BLOB },
    character           => { TYPE => SQL_CHAR },
    'character varying' => { TYPE => SQL_VARCHAR },
    char                => { TYPE => SQL_CHAR },
    clob                => { TYPE => SQL_CLOB },
    datetime            => { TYPE => SQL_DATETIME },
    date                => { TYPE => SQL_DATE },
    decimal             => { TYPE => SQL_DECIMAL },
    double              => { TYPE => SQL_DOUBLE },
    float               => { TYPE => SQL_FLOAT },
    integer             => { TYPE => SQL_INTEGER },
    interval            => { TYPE => SQL_INTERVAL },
    int                 => { TYPE => SQL_INTEGER },
    numeric             => { TYPE => SQL_NUMERIC },
    real                => { TYPE => SQL_REAL },
    smallinteger        => { TYPE => SQL_SMALLINT },
    smallint            => { TYPE => SQL_SMALLINT },
    text                => { TYPE => SQL_VARCHAR },
    timestamp           => { TYPE => SQL_TIMESTAMP },
    varbin              => { TYPE => SQL_VARBINARY },
    varchar             => { TYPE => SQL_VARCHAR },
);

sub _sql_values_types {
    my $self = shift;
    my $dbh  = shift;

    my $sql;
    my @values;
    my @types;

    foreach my $token ( $self->_txts ) {

        if ( ref $token eq 'SQL::DB::Expr::Quote' ) {
            $sql .= $dbh->quote( $token->val );
        }
        elsif ( ref $token eq 'SQL::DB::Expr::BindValue' ) {
            my $val  = $token->val;
            my $type = $token->type;

            if ( !defined $val ) {
                $sql .= $dbh->quote(undef);
                next;
            }
            elsif ( defined $type ) {
                push( @values, $val );
                if ( $type_map{$type} ) {
                    push( @types, $type_map{$type} );
                }
                elsif ( $type eq 'bytea' ) {
                    push( @types, { pg_type => eval 'DBD::Pg::PG_BYTEA' } );
                }
                elsif ( $type eq 'inet' ) {
                    push( @types, { pg_type => eval 'DBD::Pg::PG_INET' } );
                }
                elsif ( $type eq 'cidr' ) {
                    push( @types, { pg_type => eval 'DBD::Pg::PG_CIDR' } );
                }
                elsif ( $type eq 'boolean' ) {
                    push( @types, { pg_type => eval 'DBD::Pg::PG_BOOL' } );
                }
                else {
                    warn "No mapping for type $type";
                    push( @types, undef );
                }

                $sql .= '?';

                # leave it undefined
            }
            else {
                $sql .= $dbh->quote($val);
            }
        }
        elsif ( !defined $token ) {
            warn 'undefined token received! SQL so far:' . $sql;
        }
        else {
            $sql .= $token;
        }
    }

    return ( $sql, \@values, \@types );
}

# A true internal function - don't use outside this package
sub _push {
    my $self = shift;
    push( @{ $self->_txt }, @_ );
}

# A true internal function - don't use outside this package
sub _unshift {
    my $self = shift;
    unshift( @{ $self->_txt }, @_ );
}

sub _expr_addstr {
    my ( $e1, $e2, $swap ) = @_;

    # The argument is undef
    if ( !defined $e2 ) {
        Carp::carp('Use of uninitialized value in concatenation (. or .=)');
        return $e1;
    }

    my $res;

    my $multi = $e1->_multi + ( eval { $e2->_multi } || 0 );

    # $e2 . $e1 (or $e2 .= $e1)
    if ($swap) {
        if ( eval { $e2->isa(__PACKAGE__) } ) {
            $res = __PACKAGE__->new(
                _txt   => [ $e2->_txts, $e1->_txts ],
                _multi => $multi,
                _logic => $e1->_logic,
            );
        }
        else {
            $res = __PACKAGE__->new(
                _txt   => [ $e2, $e1->_txts ],
                _multi => $multi,
                _logic => $e1->_logic,
            );
        }
    }

    # $e1 . $e2
    elsif ( defined $swap ) {

        my $logic = 0;
        my $multi = 0;
        if ( eval { $e2->_logic } ) {
            if ( $e1->_multi ) {
                $e1->_unshift('(');
                $e1->_push(')');
            }
            $logic = 1;
        }
        elsif ( $e1->_logic ) {
            if ( eval { $e2->_multi } ) {
                $e2->_unshift('(');
                $e2->_push(')');
            }
            $multi = 0;
        }

        if ( eval { $e2->isa(__PACKAGE__) } ) {
            $res = __PACKAGE__->new(
                _txt   => [ $e1->_txts, $e2->_txts ],
                _multi => $multi,
                _logic => $logic,
            );
        }
        else {
            $res = __PACKAGE__->new(
                _txt   => [ $e1->_txts, $e2 ],
                _multi => $multi,
                _logic => $logic,
            );
        }
    }

    # $e1 .= $e2
    else {
        my $logic = 0;
        my $multi = 0;
        if ( eval { $e2->_logic } ) {
            if ( $e1->_multi ) {
                $e1->_unshift('(');
                $e1->_push(')');
            }
            $logic = 1;
        }
        elsif ( $e1->_logic ) {
            if ( eval { $e2->_multi } ) {
                $e2->_unshift('(');
                $e2->_push(')');
            }
            $multi = 1;
        }

        if ( eval { $e2->isa(__PACKAGE__) } ) {
            $e1->_push( $e2->_txts );
            $e1->_multi($multi);
            $e1->_logic($logic);
        }
        else {
            $e1->_push($e2);
            $e1->_multi($multi);
            $e1->_logic($logic);
        }
        $res = $e1;
    }

    return $res;
}

sub _expr_not {
    my $e1   = shift;
    my $expr = SQL::DB::Expr->new . $e1;

    if ( $e1->_multi > 0 ) {
        $expr->_unshift('(');
        $expr->_push(')');
    }
    $expr->_unshift('NOT ');
    $expr->_multi(0);
    return $expr;
}

sub _expr_binary {
    my ( $op, $e1, $e2, $swap, $_multi ) = @_;

    my $e = SQL::DB::Expr->new;

    # TODO add ( ) bracketing for multi expressions?
    if ($swap) {
        $e .= _bval( $e2, $e1->_type );
        $e .= ( ' ' . $op . ' ' ) . $e1;
    }
    else {
        $e .= $e1 . ( ' ' . $op . ' ' );
        $e .= _bval( $e2, $e1->_type );
    }

    $e->_multi(1);
    return $e;
}

sub _expr_eq { _expr_binary( '=', @_ ) }

sub _expr_ne { _expr_binary( '!=', @_ ) }

sub _expr_bitand { _expr_binary( '&', @_ ) }

sub _expr_bitor { _expr_binary( '|', @_ ) }

sub _expr_lt { _expr_binary( '<', @_ ) }

sub _expr_gt { _expr_binary( '>', @_ ) }

sub _expr_lte { _expr_binary( '<=', @_ ) }

sub _expr_gte { _expr_binary( '>=', @_ ) }

sub _expr_add { _expr_binary( '+', @_ ) }

sub _expr_sub { _expr_binary( '-', @_ ) }

sub _expr_mult { _expr_binary( '*', @_ ) }

sub _expr_divide { _expr_binary( '/', @_ ) }

sub is_null { $_[0] . ' IS NULL' }

sub is_not_null { $_[0] . ' IS NOT NULL' }

sub in {
    my $e1 = shift;
    if ( @_ >= 2 && $_[0] =~ m/^select/i ) {
        return $e1 . " IN (\n" . _query(@_) . ')';
    }
    return
      $e1 . ' IN ('
      . _expr_join( ', ', map { _bval( $_, $e1->_type ) } @_ ) . ')';
}

sub not_in {
    my $e1 = shift;
    if ( @_ >= 2 && $_[0] =~ m/^select/i ) {
        return $e1 . " NOT IN (\n" . _query(@_) . ')';
    }
    return
        $e1
      . ' NOT IN ('
      . _expr_join( ', ', map { _bval( $_, $e1->_type ) } @_ ) . ')';
}

sub between {
    my $e1 = shift;
    croak 'between($a,$b)' unless @_ == 2;

    my $e = SQL::DB::Expr->new(
        _txt => [
            $e1->_txts,
            ' BETWEEN ',
            _bval( $_[0], $e1->_type ),
            ' AND ',
            _bval( $_[1], $e1->_type )
        ],
    );
    return $e;
}

sub not_between {
    my $e1 = shift;
    croak 'not_between($a,$b)' unless @_ == 2;

    my $e = SQL::DB::Expr->new(
        _txt => [
            $e1->_txts,
            ' NOT BETWEEN ',
            _bval( $_[0], $e1->_type ),
            ' AND ',
            _bval( $_[1], $e1->_type )
        ],
    );
    return $e;
}

sub as {
    my $e1 = shift;
    my $as = shift || croak 'as($value)';

    if ( $e1->_multi > 0 ) {
        my $expr = SQL::DB::Expr->new( _txt => ['('] );
        $expr .= $e1;
        $expr .= ') AS "' . $as . '"';
        return $expr;
    }

    return $e1 . ' AS "' . $as . '"';
}

sub like {
    my $e1   = shift;
    my $like = shift || croak 'like($value)';
    my $expr = $e1 . ' LIKE ';
    $expr .= _bval( $like, $e1->_type );
    $expr->_multi(0);
    return $expr;
}

sub asc {
    my $e1 = shift;
    return $e1 . ' ASC';
}

sub desc {
    my $e1 = shift;
    return $e1 . ' DESC';
}

DESTROY {
    my $self = shift;
    if ( my $alias = $self->_alias ) {
        $alias =~ m/^(.*?)(\d+)$/;
        delete $tcount->{$1}->[$2];
    }
}

package SQL::DB::Expr::SQL;
use strict;
use warnings;
use Moo;
use overload '""' => sub {
    my $self = shift;
    $self->val;
  },
  fallback => 1;

has val => (
    is       => 'ro',
    required => 1,
);

package SQL::DB::Expr::Quote;
use strict;
use warnings;
use Moo;
use overload '""' => sub {
    my $self = shift;
    return 'q{' . ( defined $self->val ? $self->val : 'undef' ) . '}';
  },
  fallback => 1;

has val => (
    is       => 'ro',
    required => 1,
);

package SQL::DB::Expr::BindValue;
use strict;
use warnings;
use Moo;
use Carp qw/confess/;
use overload '""' => sub {
    my $self = shift;
    return
        'bv{'
      . ( defined $self->val  ? $self->val  : 'undef' ) . '}::'
      . ( defined $self->type ? $self->type : '(none)' );
  },
  fallback => 1;

has val => (
    is       => 'ro',
    required => 1,
);

has type => ( is => 'rw', );

1;