File Coverage

blib/lib/SQL/Interpol.pm

Criterion	Covered	Total	%
statement	98	102	96.0
branch	60	68	88.2
condition	9	12	75.0
subroutine	13	14	92.8
pod	2	2	100.0
total	182	198	91.9

use 5.006;
use warnings;

package SQL::Interpol;
$SQL::Interpol::VERSION = '1.102';
# ABSTRACT: interpolate Perl variables into SQL statements

use Exporter::Tidy all => [ qw( sql_interp sql ) ];

sub sql { bless [ @_ ], __PACKAGE__ }

sub sql_interp {
    my $p = SQL::Interpol::Parser->new;
    my $sql = $p->parse( @_ );
    my $bind = $p->bind;
    return ( $sql, @$bind );
}


package SQL::Interpol::Parser;
$SQL::Interpol::Parser::VERSION = '1.102';
use Object::Tiny::Lvalue qw( alias_id bind );

use Carp ();

use constant IDENT_RX => qr/[a-zA-Z_][a-zA-Z0-9_\$\.]*/;
use constant VALID => { ARRAY => 1, SCALAR => 1, 'SQL::Interpol' => 1, '' => 1 };

sub _error { Carp::croak 'SQL::Interpol error: ', @_ }

sub new {
    my $class = shift;
    $class->SUPER::new( alias_id => 0, bind => [] );
}

sub parse {
    my $self = shift;

    my $sql = '';
    my $bind = $self->bind;

    my ( $item, $prev );
    my $error = sub {
        my $where = defined $prev ? " following '$prev'" : '';
        _error "Unrecognized element '$item'$where";
    };

    while ( @_ ) {
        $item = shift @_;
        my $type = ref $item;
        my $append;

        if ( 'SQL::Interpol' eq $type ) {
            unshift @_, @$item;
            next;
        }

        if ( not $type ) {
            $prev = $append = $item;
        }
        elsif ( $sql =~ s/(\s*${(IDENT_RX)}\s+(NOT\s+)?IN)\s*$//oi ) {
            my @value
                = 'SCALAR' eq $type ? $$item
                : 'ARRAY'  eq $type ? @$item
                : 'REF'    eq $type && 'ARRAY' eq ref $$item ? @$$item
                : $error->();
            my $list = @value && join ', ', $self->bind_or_parse_values( @value );
            $append = @value ? "$1 ($list)" : $2 ? '1=1' : '1=0';
        }
        elsif ( $sql =~ /\b(REPLACE|INSERT)[\w\s]*\sINTO\s*${(IDENT_RX)}\s*$/oi ) {
            my @value
                = 'SCALAR' eq $type ? $$item
                : 'ARRAY'  eq $type ? @$item
                : 'HASH'   eq $type ? do {
                    my @key = sort keys %$item;
                    my $list = join ', ', @key;
                    $append = "($list) ";
                    @$item{ @key };
                }
                : $error->();
            my $list = @value ? join ', ', $self->bind_or_parse_values( @value ) : '';
            $append .= "VALUES($list)";
        }
        elsif ( 'SCALAR' eq $type ) {
            push @$bind, $$item;
            $append = '?';
        }
        elsif ( 'HASH' eq $type ) {  # e.g. WHERE {x = 3, y = 4}
            if ( $sql =~ /\b(?:ON\s+DUPLICATE\s+KEY\s+UPDATE|SET)\s*$/i ) {
                _error 'Hash has zero elements.' if not keys %$item;
                my @k = sort keys %$item;
                my @v = $self->bind_or_parse_values( @$item{ @k } );
                $append = join ', ', map "$k[$_]=$v[$_]", 0 .. $#k;
            }
            elsif ( not keys %$item ) {
                $append = '1=1';
            }
            else {
                my $cond = join ' AND ', map {
                    my $expr = $_;
                    my $eval = $item->{ $expr };
                    ( not defined $eval )  ? "$expr IS NULL"
                    : 'ARRAY' ne ref $eval ? map { "$expr=$_" } $self->bind_or_parse_values( $eval )
                    : do {
                        @$eval ? do {
                            my $list = join ', ', $self->bind_or_parse_values( @$eval );
                            "$expr IN ($list)";
                        } : '1=0';
                    }
                } sort keys %$item;
                $cond = "($cond)" if keys %$item > 1;
                $append = $cond;
            }
        }
        elsif ( 'ARRAY' eq $type ) {  # result set
            _error 'table reference has zero rows' if not @$item; # improve?

            # e.g. [[1,2],[3,4]] or [{a=>1,b=>2},{a=>3,b=>4}].
            my $do_alias = $sql =~ /(?:\bFROM|JOIN)\s*$/i && ( $_[0] || '' ) !~ /\s*AS\b/i;

            my $row0  = $item->[0];
            my $type0 = ref $row0;

            if ( 'ARRAY' eq $type0 ) {
                _error 'table reference has zero columns' if not @$row0; # improve?
                $append = join ' UNION ALL ', map {
                    'SELECT ' . join ', ', $self->bind_or_parse_values( @$_ );
                } @$item;
            }
            elsif ( 'HASH' eq $type0 ) {
                _error 'table reference has zero columns' if not keys %$row0; # improve?
                my @k = sort keys %$row0;
                $append = join ' UNION ALL ', do {
                    my @v = $self->bind_or_parse_values( @$row0{ @k } );
                    'SELECT ' . join ', ', map "$v[$_] AS $k[$_]", 0 .. $#k;
                }, map {
                    'SELECT ' . join ', ', $self->bind_or_parse_values( @$_{ @k } );
                } @$item[ 1 .. $#$item ];
            }
            else { $error->() }

            $append  = "($append)";
            $append .= ' AS tbl' . $self->alias_id++ if $do_alias;
        }
        else { $error->() }

        next if not defined $append;
        $sql .= ' ' if $sql =~ /\S/ and $append !~ /\A\s/;
        $sql .= $append;
    }

    return $sql;
}

# interpolate values from aggregate variable (hashref or arrayref)
sub bind_or_parse_values {
    my $self = shift;
    map {
        my $type = ref;
        _error "unrecognized $type value in aggregate" unless VALID->{ $type };
        $type ? $self->parse( $_ ) : ( '?', push @{ $self->bind }, $_ )[0];
    } @_;
}

undef *VALID;
undef *IDENT_RX;

1;

__END__