SQL::Interpolate::Filter - Source filtering for SQL::Interpolate

  # This first line enables source filtering.
  use SQL::Interpolate FILTER => 1, qw(:all);

  ($sql, @bind) = sql_interp sql[
      SELECT * FROM mytable WHERE color IN @colors
      AND y = $x OR {z => 3, w => 2}
  ];

  ($sql, @bind) = sql_interp sql[
      INSERT INTO table {
          color  => $new_color,
          shape  => $new_shape
          width  => $width,
          height => $height,
          length => $length
      }
  ];

  # Each result above is suitable for passing to DBI:
  my $res = $dbh->selectall_arrayref($sql, undef, @bind);

  sql/SELECT * FROM mytable WHERE x = $x/;

  sql("SELECT * FROM mytable WHERE x = ", \$x);

  "SELECT * FROM mytable WHERE x = ?", ($x)

  use SQL::Interpolate  FILTER => 1, qw(:all);  # or
  use DBIx::Interpolate FILTER => 1, qw(:all);

  sql[SELECT * from mytable WHERE x = $x]
  sql(SELECT * from mytable WHERE x = $x)
  sql<SELECT * from mytable WHERE x = $x>
  sql/SELECT * from mytable WHERE x = $x/

  sql[
    SELECT partnum, desc, price, stock
    FROM inventory
  ] . $show_all ? sql[] : sql[WHERE price > $price AND stock IN $stocks]

  $dbx->do(sql[UPDATE mytable SET y = 0 WHERE x = ] . $name);  # not good

  $dbx->do(sql[UPDATE mytable SET y = 0 WHERE x = ] . sql[$name]);  # or
  $dbx->do(sql[UPDATE mytable SET y = 0 WHERE x = $name]);

 INPUT:  sql[WHERE one=$x AND $y]
 OUTPUT: sql("WHERE one=", \$x, " AND ", $y)

 INPUT:  sql[INSERT INTO mytable @x]
 OUTPUT: sql("INSERT INTO mytable ", \@x)

 INPUT:  sql[INSERT INTO mytable [1, 2]]
 OUTPUT: sql("INSERT INTO mytable ", [1, 2])

 INPUT   sql[INSERT INTO mytable %x]
 OUTPUT: sql("INSERT INTO mytable ", \%x)

 INPUT:  sql[INSERT INTO mytable {one => 1, two => 2}]
 OUTPUT: sql("INSERT INTO mytable ", {one => 1, two => 2})

 use SQL::Interpolate TRACE_FILTER => 1, FILTER => 1;

 ...
 SQL::Interpolate::Filter::_make_sql(qq[SELECT * FROM mytable WHERE x = ], \$x)
 ...

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.40';

# 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 "<sql:$sql>";
                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__