File Coverage

blib/lib/SQL/Interp.pm

Criterion	Covered	Total	%
statement	194	215	90.2
branch	103	128	80.4
condition	19	23	82.6
subroutine	22	25	88.0
pod	3	5	60.0
total	341	396	86.1

package SQL::Interp;

our $VERSION = '1.27';

use strict;
use warnings;
use Carp;


# Custom import magic to support Sub::Exporter '-as' style function renaming.
# (for backwards compatibility with older versions without adding an additional dependency)
sub import {
    my $pkg = shift;
    my $caller = caller;
    my %export = qw/sql_interp 1 sql_interp_strict 1 sql_type 1 sql 1/;
    while(my $fn = shift) {
        if($fn eq ':all') {
            push @_, keys %export;
            next;
        }
        croak "Symbol '$fn' is not exported by $pkg" if !$export{$fn};
        my $as = $fn;
        if(ref $_[0] eq 'HASH') {
            my $arg = shift;
            $as = $arg->{'-as'} if defined $arg->{'-as'};
        }
        no strict 'refs';
        *{$caller.'::'.$as} = *{$pkg.'::'.$fn};
    }
}


# whether TRACE_SQL is enabled
my $trace_sql_enabled = $ENV{TRACE_SQL} || 0;

# regexes
my $id_match = qr/(?:[a-zA-Z_][a-zA-Z0-9_\$\.]*|"[^"]+"|`[^`]+`)/;


# next ID to use for table alias
# [local to sql_interp functions]
my $alias_id = 0;

# current index in interpolation list
# [local to sql_interp functions]
my $idx = 0;

# current interpolation list
# [local to sql_interp functions]
my $items_ref = undef;

# whether typed sql_type() ever used (if so,
# format of @bind result is more complicated)
# [local to sql_interp functions]
my $is_var_used = 0;

# bind elements in interpolation
# [local to sql_interp functions]
my @bind;

# only used by DBIx::Interp, so not further documented here.
# Doesn't do anything, but may accept options to influence sql_interp()'s behavior in the future.
sub new {
    bless {}, shift;
}


# note: sql_interp is not reentrant.
sub sql_interp {
    my @items = @_;

    # clear call state
    $alias_id = 0;
    $idx = 0;
    $items_ref = undef;
    $is_var_used = 0;
    @bind = ();

    # Legacy: We may be called with an object as first argument; it's unused so throw it away
    shift @items if UNIVERSAL::isa($items[0], 'SQL::Interp') || UNIVERSAL::isa($items[0], 'DBI::db');

    $items_ref = \@items;

    # interpolate!
    my $sql = _sql_interp(@items);

    # convert bind values to complex format (if needed)
    if ($is_var_used) {
        for my $val (@bind) {
            my $valcopy = $val;
            ! ref $val and $val = [$val, sql_type(\$valcopy)];
        }
    }

    $trace_sql_enabled
        and print STDERR "DEBUG:interp[sql=$sql,bind="
                         . join(':', @bind) . "]\n";

    return ($sql, @bind);
}

# Prevent accidental SQL injection holes
# By enforcing the rule that two non-references cannot be used
# in a row. If you really mean that, concatanate the strings instead.
sub sql_interp_strict {
    my @items = @_;

    my $adjacent_string_cnt = 0;
    for my $item (@items) {
        # If we have a reference, reset the counter and move to the next element.
        if (ref $item) {
            $adjacent_string_cnt = 0;
        }
        else {
            $adjacent_string_cnt++;
            if ($adjacent_string_cnt == 2) {
                croak "failed sql_interp_strict check. Refactor to concatenate adjacent strings in sql_interp array";
            }
        }

    }

    return sql_interp(@_);
}

# helper called by sql_interp()
# @items - interpolation list
sub _sql_interp {
    my (@items) = @_;

    my $sql = '';

    foreach my $item (@items) {
        my $varobj;
        my $bind_size = @bind;
        if (ref $item eq 'SQL::Interp::Variable') {
            unless (keys %$item == 1 && defined($item->{value})) {
                $varobj = $item;
                $is_var_used = 1;
            }
            $item = $item->{value};
        }

        if (ref $item eq 'SQL::Interp::SQL') {
            my ($sql2, @bind2) = _sql_interp(@$item);
            $sql .= ' ' if $sql ne '';
            $sql .= $sql2;
            push @bind, @bind2;
        }
        elsif (ref $item) {
            if ($sql =~ /\b(NOT\s+)?IN\s*$/si) {
                my $not = quotemeta($1 || '');

                $item = [ $$item ] if ref $item eq 'SCALAR';

                # allow double references
                $item = $$item if ref $item eq 'REF' ;

                if (ref $item eq 'ARRAY') {
                    if (@$item == 0) {
                        my $dummy_expr = $not ? '1=1' : '1=0';
                        $sql =~ s/$id_match\s+${not}IN\s*$/$dummy_expr/si or croak 'ASSERT';
                    }
                    else {
                        $sql .= " (" . join(', ', map {
                            _sql_interp_data($_);
                        } @$item) . ")";
                    }
                }
                else {
                    _error_item($idx, \@items);
                }
            }
            elsif ($sql =~ /\bARRAY\s*$/si) {
                $item = [ $$item ] if ref $item eq 'SCALAR';

                # allow double references
                $item = $$item if ref $item eq 'REF' ;

                if (ref $item eq 'ARRAY') {
                    $sql .= '[' . join(', ', map {
                        _sql_interp_data($_);
                    } @$item) . ']';
                }
                else {
                    _error_item($idx, \@items);
                }
            }
            elsif ($sql =~ /\b(?:ON\s+DUPLICATE\s+KEY\s+UPDATE|SET)\s*$/si && ref $item eq 'HASH') {
                _error('Hash has zero elements.') if keys %$item == 0;
                $sql .= " " . join(', ', map {
                    my $key = $_;
                    my $val = $item->{$key};
                    "$key=" .
                        _sql_interp_data($val);
                } (sort keys %$item));
            }
            elsif ($sql =~ /\b(REPLACE|INSERT)[\w\s]*\sINTO\s*$id_match\s*$/si) {
                $item = [ $$item ] if ref $item eq 'SCALAR';
                if (ref $item eq 'ARRAY') {
                    $sql .= " VALUES(" . join(', ', map {
                        _sql_interp_data($_);
                    } @$item) . ")";
                }
                elsif (ref $item eq 'HASH') {
                    my @keyseq = sort keys %$item;
                    $sql .=
                        " (" . join(', ', @keyseq) . ")" .
                        " VALUES(" . join(', ', map {
                            _sql_interp_data($item->{$_});
                        } @keyseq) . ")";
                }
                else { _error_item($idx, \@items); }
            }
            elsif ($sql =~ /(?:\bFROM|JOIN)\s*$/si && $sql !~ /DISTINCT\s+FROM\s*$/) {
                # table reference

                # get alias for table
                my $table_alias = undef; # alias given to table
                my $next_item = $items[$idx + 1];
                if(defined $next_item && ref $next_item eq '' &&
                   $next_item =~ /\s*AS\b/is)
                {
                    $table_alias = undef;  # provided by client
                }
                else {
                    $table_alias = 'tbl' . $alias_id++;
                }

                $sql .= ' ' unless $sql eq '';
                $sql .= _sql_interp_resultset($item);
                $sql .= " AS $table_alias" if defined $table_alias;
            }
            elsif (ref $item eq 'SCALAR') {
                push @bind, $$item;
                $sql .= ' ?';
            }
            elsif (ref $item eq 'HASH') {  # e.g. WHERE {x = 3, y = 4}
                if (keys %$item == 0) {
                    $sql .= ' 1=1';
                }
                else {
                    my $s = join ' AND ', map {
                        my $key = $_;
                        my $val = $item->{$key};
                        if (! defined $val) {
                            "$key IS NULL";
                        }
                        elsif (ref $val eq 'ARRAY') {
                            _sql_interp_list($key, $val);
                        }
                        else {
                            "$key=" .
                            _sql_interp_data($val);
                        }
                    } (sort keys %$item);
                    $s = "($s)" if keys %$item > 1;
                    $s = " $s";
                    $sql .= $s;
                }
            }
            elsif (ref $item eq 'ARRAY') {  # result set
                $sql .= ' ' unless $sql eq '';
                $sql .= _sql_interp_resultset($item);
            }
            else { _error_item($idx, \@items); }
        }
        else {
            $sql .= ' ' unless $sql =~ /(^|\s)$/ || $item =~ /^\s/;  # style
            $sql .= $item;
        }

        # attach $varobj to any bind values it generates
        if ($varobj) {
            my $num_pushed = @bind - $bind_size;
            for my $val (@bind[-$num_pushed..-1]) {
                $val = [$val, $varobj];
            }
        }
        $idx++;
    }

    return $sql;
}

# sql_interp helper function.
# Interpolate data element in aggregate variable (hashref or arrayref).
# $ele - raw input element from aggregate.
# returns $sql
sub _sql_interp_data {
    my ($ele) = @_;
    if (ref $ele) {  # e.g. sql()
        my ($sql2, @bind2) = _sql_interp($ele);
        push @bind, @bind2;
        $is_var_used = 1 if ref $bind2[0];
        return $sql2;
    }
    else {
        push @bind, $ele;
        return '?';
    }
}

# sql_interp helper function to interpolate "key IN list",
# assuming context ("WHERE", {key => $list, ...}).
sub _sql_interp_list {
    my ($key, $list) = @_;
    if (@$list == 0) {
        return "1=0";
    }
    else {
        my @sqle;
        for my $ele (@$list) {
            my $sqle
                = _sql_interp_data($ele);
            push @sqle, $sqle;
        }
        my $sql2 = $key . " IN (" . join(', ', @sqle) . ")";
        return $sql2;
    }
}
# sql_interp helper function to interpolate result set,
#   e.g. [[1,2],[3,4]] or [{a=>1,b=>2},{a=>3,b=>4}].
sub _sql_interp_resultset {
    my($item) = @_;
    my $sql = '';
    if (ref $item eq 'ARRAY') {
        _error("table reference has zero rows")  # improve?
            if @$item == 0;
        my $sql2 = '';
        if(ref $item->[0] eq 'ARRAY') {
            _error("table reference has zero columns")  # improve?
                if @{ $item->[0] } == 0;
            for my $row ( @$item ) {
                my $is_first_row = ($sql2 eq '');
                $sql2 .= ' UNION ALL ' unless $is_first_row;
                $sql2 .=
                    "SELECT " .
                    join(', ', map {
                        _sql_interp_data($_)
                    } @$row);
            }
        }
        elsif(ref $item->[0] eq 'HASH') {
            _error("table reference has zero columns")  # improve?
                if keys %{ $item->[0] } == 0;
            my $first_row = $item->[0];
            for my $row ( @$item ) {
                my $is_first_row = ($sql2 eq '');
                $sql2 .= ' UNION ALL ' unless $is_first_row;
                $sql2 .=
                    "SELECT " .
                    join(', ', map {
                        my($key, $val) = ($_, $row->{$_});
                        my $sql3 = _sql_interp_data($val);
                        $sql3 .= " AS $key" if $is_first_row;
                        $sql3;
                    } (sort keys %$first_row));
             }
        }
        else {
            _error_item($idx, $items_ref);
        }
        $sql .= ' ' unless $sql eq '';
        $sql .= "($sql2)";
    }
    else { _error_item($idx, $items_ref); }
    return $sql;
}

sub sql {
    return SQL::Interp::SQL->new(@_);
}

sub sql_type {
    return SQL::Interp::Variable->new(@_);
}

# helper function to throw error
sub _error_item {
    my ($idx, $items_ref) = @_;
    my $prev      = $idx > 0       ? $items_ref->[$idx-1] : undef;
    my $prev_text = defined($prev) ? " following '$prev'" : "";
    my $cur  = $items_ref->[$idx];
    _error("SQL::Interp error: Unrecognized "
         . "'$cur'$prev_text in interpolation list.");
    return;
}

sub _error {
    croak "SQL::Interp error: $_[0]";
}

1;

package SQL::Interp::Variable;
use strict;
use Carp;

sub new {
    my ($class, $value, %params) = @_;
    SQL::Interp::_error(
        "Value '$value' in sql_type constructor is not a reference")
        if ! ref $value;
    my $self = bless {value => $value, %params}, $class;
    return $self;
}

1;


package SQL::Interp::SQL;
use strict;
use Carp;
use overload '.' => \&concat, '""' => \&stringify;

sub new {
    my ($class, @list) = @_;

    my $self = \@list;
    bless $self, $class;
    return $self;
}

# Concatenate SQL object with another expression.
# An SQL object can be concatenated with another SQL object,
# variable reference, or an SQL string.
sub concat {
    my ($a, $b, $inverted) = @_;

    my @params = ( @$a, ref $b eq __PACKAGE__ ? @$b : $b );
    @params = reverse @params if $inverted;
    my $o = SQL::Interp::SQL->new(@params);
    return $o;
}

sub stringify {
    my ($a) = @_;
    return $a;
}

1;

__END__