File Coverage

blib/lib/SQL/Interpolate/Filter.pm

Criterion	Covered	Total	%
statement	44	45	97.7
branch	18	20	90.0
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	68	71	95.7

package SQL::Interpolate::Filter;

use strict;
use warnings;
use Filter::Simple;
use Text::Balanced qw/extract_quotelike
                      extract_bracketed
                      extract_multiple
                      extract_variable
                      extract_codeblock/;

our $VERSION = '0.32';

# Source filter.
# Note: this could be improved as done in the POD of the development 2.0 version of
# Text::Balanced.
FILTER {
    my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/;

    # This lexes the Perl source code, replacing quotelike sql//
    # operators with the result of _process_sql().
    while ($_ !~ /\G$/gc) {
        my $sql;
        my $last_pos = pos();
        if    (/\G\s+/gc) { }  # whitespace
        elsif (/\G#.*/gc) { }  # comments
        # sql// operators
        # FIX:should any other quote delimiters be added?
        elsif (/\G\bsql\b\s*(?=[\{\(\[\<\/])/gcs &&
            do {
                my $pos = pos();
                s/\G/ q/;  # convert to Perl quote-like
                pos() = $pos;
                $sql = (extract_quotelike())[5];
                #print "";
                if (!$sql) {  # restore
                    s/\G q//;
                    pos() = $pos;
                }
                !!$sql;
            }
        )
        {
            my $pos = pos();
            my $out = _process_sql($sql);
            pos() = $pos;
            substr($_, $last_pos, pos() - $last_pos) = $out;
            pos() = $last_pos + length($out);
        }
        # prevent things like $y = ... = from being interpreted as string.
        elsif (/\G(?<=[\$\@])\w+/gc) {
            #print "[DEBUG:var:$&]";
        }
        elsif (/\G$id/gc) {
            #print "[DEBUG:id:$&]";
        }
        elsif (my $next = (extract_quotelike())[0]) {
            #print "[DEBUG:q:$next]";
        }
        else {
            /\G./gc;
        }
    }
    print STDERR "DEBUG:filter[code=$_]" if $SQL::Interpolate::trace_filter;
};

# Convert the string inside a sql// quote-like operator into
# a list of SQL strings and variable references for interpolation.
sub _process_sql {
    local $_ = shift;

    my @parts;
    my $instr = 0;
    while ($_ !~ /\G$/gc) {
        my $tok;
        my $tok_type;
        my $pos_last = pos();
        if (/\G(\s+|\*)/gc) {
            $tok = $1;
            $tok_type = 's';
        }
        elsif ($tok = (extract_variable($_))[0]) {
            $tok_type = 'v';
        }
        elsif ($tok = (extract_codeblock($_, '{['))[0]) {
            $tok_type = 'c';
        }
        else {
            /\G(.)/gc;
            $tok = $1;
            $tok_type = 's';
        }

        if ($tok_type eq 's') {
            if ($instr) {
                $parts[-1] .= $tok
            }
            else {
                push @parts, $tok
            }
            $instr = 1;
        }
        else {
            $parts[-1] = 'qq[' . $parts[-1] . ']' if $instr;
            $instr = 0;
            if ($tok_type eq 'v') {
                push @parts, '\\' . $tok;
            }
            elsif ($tok_type eq 'c') {
                push @parts, $tok;
            }
            else { die 'assert'; }
        }

    }
    $parts[-1] = 'qq[' . $parts[-1] . ']' if $instr;

    my $out = 'SQL::Interpolate::Filter::_make_sql('
            . join(', ', @parts) . ')';

    return $out;
}

# Generated by the sql// operator when source filtering is enabled.
sub _make_sql {
    my (@list) = @_;

    # Note that sql[INSERT INTO mytable $x] gets translated to
    #   q[INSERT INTO mytable], \$x
    # regardless whether $x is a scalar or reference since it
    # would be difficult to know at source filtering time whether
    # $x is already a reference.  Therefore, we dereference any
    # double reference here (at run-time).
    do { $_ = $$_ if ref($_) eq 'REF' }
        for @list;

    my $o = SQL::Interpolate::SQL->new(@list);
    return $o;
}

1;

# Implementation Notes:
# Sub::Quotelike provides similar functionality to this module,
# but it is not exactly what I need.  Sub::Quotelike allows you to
# replace quote expressions with calls to your own custom function
# that can return itself and expression.  In Sub::Quotelike, the
# return expression is evaluated within the context of the called
# subroutine rather that in the scope of the caller as is typically
# the case with variable interpolation in strings.  Therefore, SQL
# variable interpolation will not work correctly.  Furthermore, the
# current version (0.03) performs fairly simple, and potentially
# error-prone, source filtering.

# We also do not utilize "FILTER_ONLY quotelike" in Filter::Simple
# since its parsing is fairly simplistic and recognizes things like $y
# = ... = as containing a quote (y=...=).

1;

__END__