File Coverage

blib/lib/SQL/Interpolate.pm

Criterion	Covered	Total	%
statement	192	205	93.6
branch	77	102	75.4
condition	9	12	75.0
subroutine	29	32	90.6
pod	5	6	83.3
total	312	357	87.3

package SQL::Interpolate;

our $VERSION = '0.32';

use strict;
use warnings;
use Carp;
use base 'Exporter';

our @EXPORT;
our %EXPORT_TAGS = (all => [qw(
    make_sql_interp
    sql_interp
    sql_var
    sql
    sql_literal
)]); # note: sql_literal depreciated
our @EXPORT_OK = @{ $EXPORT_TAGS{all} };

# whether TRACE_SQL is enabled
my $trace_sql_enabled = 0;

# whether TRACE_FILTER is enabled
my $trace_filter_enabled = 0;

# whether macros are enabled
my $macros_enabled = 0;

sub import {
    my $class  = shift;
    my @params = @_;

    # process any special "use" parameters
    my $filter_enabled = 0;  # whether filtering enabled
    my $is_wrapped     = 0;  # whether module wrapped
                             #   (e.g. by DBIx::Interpolate)
    my %action_for = (
        FILTER       => sub { $filter_enabled = shift @params; },
        TRACE_SQL    => sub { $trace_sql_enabled = shift @params;
                              print STDERR "TRACE_SQL enabled\n"
                                  if $trace_sql_enabled; },
        TRACE_FILTER => sub { $trace_filter_enabled = shift @params;
                              print STDERR "TRACE_FILTER enabled\n"
                                  if $trace_filter_enabled; },
        __WRAP       => sub { $is_wrapped = shift @params; }
    );
    @_ = ($class);  # unprocessed params
    while (my $item = shift @params) {
        my $action = $action_for{$item};
        if ($action) { $action->(); }
        else         { push @_, $item; }
    }

    # handle exports
    my $level = $is_wrapped ? 2 : 1;
    __PACKAGE__->export_to_level($level, @_);

    # handle source filtering (if enabled)
    if ($filter_enabled) {
        require SQL::Interpolate::Filter;
        goto &SQL::Interpolate::Filter::import;  # @_
    }

    return;
}

sub new {
    my $class = shift;

    # process special params.
    my $dbh;
    my $filters = [];
    while (ref $_[0] ne '') {
        if (UNIVERSAL::isa($_[0], 'DBI::db')) {
            $dbh = shift;
        }
        elsif (UNIVERSAL::isa($_[0], 'SQL::Interpolate::SQLFilter')) {
            push @$filters, shift;
        }
    }
    my %params = @_;

    # build indicies on $filters for quick access
    my $filters_hash          = {};  # filter class name --> [filter]
    my $text_filters          = [];  # filter
    my $inits                 = [];  # filter
    my $text_fragment_filters = [];  # filter
    for my $filter (@$filters) {
        push @{$filters_hash->{ref $filter}}, $filter;
        push @$text_filters, $filter
            if $filter->can("filter_text");
        push @$inits, $filter
            if $filter->can("init");
        push @$text_fragment_filters, $filter
            if $filter->can("filter_text_fragment");
    }

    # build object
    my $self = bless {
        dbh                   => $dbh,
        filters               => $filters,
        filters_hash          => $filters_hash,
        text_filters          => $text_filters,
        inits                 => $inits,
        text_fragment_filters => $text_fragment_filters
    }, $class;
    return $self;
}

sub sql_interp {
    my @items = @_;

    # extract state item (if any)
    my $state;
    my $interp;
    if (UNIVERSAL::isa($items[0], 'SQL::Interpolate')) {
        $state = $interp = $items[0];
    }
    elsif (UNIVERSAL::isa($items[0], 'DBI::db')) {
        $state = $items[0];
    }

    # process macros (if enabled)
    if ($macros_enabled) {
        if ($interp) {
            for my $initer (@{$interp->{inits}}) { $initer->init(); }
        }
        @items = SQL::Interpolate::Macro::sql_flatten(@items);
    }
    else {
        shift @items if $state;
    }

    # interpolate!
    my $varobj_used = 0;  # whether typed sql_var() ever used (if so,
                          # format of @bind result is more complicated)
    my ($sql, @bind) = _sql_interp($state, \$varobj_used, @items);

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

    # process text filters (if any)
    if ($interp) {
        for my $text_filter (@{$interp->{text_filters}}) {
            $sql = $text_filter->filter_text($sql);
        }
    }

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

    return ($sql, @bind);
}

# helper called by sql_interp()
# $state - SQL::Interpolate derived object, DBI handle, or undef
# $varobj_used_ref - reference to Boolean indicator of complex
#                    bind format [out]
# @items - interpolation list (no macros)
sub _sql_interp {
    my ($state, $varobj_used_ref, @items) = @_;

    my $sql = '';
    my @bind;
    my $id_match = qr/[a-zA-Z_\.]+/;
    my $idx = 0;

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

        if (ref $item eq 'SQL::Interpolate::SQL') {
            my ($sql2, @bind2) = _sql_interp($state, $varobj_used_ref, @$item);
            $sql .= " $sql2";
            push @bind, @bind2;
        }
        elsif (ref $item) {
            if ($sql =~ /\bIN\s*$/si) {
                $item = [ $$item ] if ref $item eq 'SCALAR';
                if (ref $item eq 'ARRAY') {
                    if (@$item == 0) {
                        $sql =~ s/$id_match\s+IN\s*$/1=0/si or croak 'ASSERT';
                    }
                    else {
                        $sql .= " (" . join(', ', map {
                            _sql_interp_data($state, \@bind,
                                $varobj_used_ref, $_);
                        } @$item) . ")";
                    }
                }
                else {
                    _error_item($idx, \@items);
                }
            }
            elsif ($sql =~ /\bSET\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($state, \@bind,
                                         $varobj_used_ref, $val);
                } keys %$item);
            }
            elsif ($sql =~ /\bINSERT[\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($state, \@bind,
                                         $varobj_used_ref, $_);
                    } @$item) . ")";
                }
                elsif (ref $item eq 'HASH') {
                    $sql .=
                        " (" . join(', ', keys %$item) . ")" .
                        " VALUES(" . join(', ', map {
                            _sql_interp_data($state, \@bind,
                                             $varobj_used_ref, $_);
                        } values %$item) . ")";
                }
                else { _error_item($idx, \@items); }
            }
            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 (ref $val eq 'ARRAY') {
                            _in_list($state, \@bind, $varobj_used_ref,
                                     $key, $val);
                        }
                        else {
                            "$key=" .
                            _sql_interp_data($state, \@bind,
                                             $varobj_used_ref, $val);
                        }
                    } keys %$item;
                    $s = "($s)" if keys %$item > 1;
                    $s = " $s";
                    $sql .= $s;
                }
            }
            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, @bind);
}

# sql_interp helper function.
# Interpolate data element in aggregate variable (hashref or arrayref).
# $state - (may be undef)
# $bindref - \@bind (is modified--appended to)
# $varobj_usedref - \$varobj_used (is modified)
# $ele - raw input element from aggregate.
# returns $sql
sub _sql_interp_data {
    my ($state, $bindref, $varobj_usedref, $ele) = @_;
    if (ref $ele) {
        my ($sql2, @bind2) = sql_interp($state || (), $ele);
        push @$bindref, @bind2;
        $$varobj_usedref = 1 if ref $bind2[0];
        return $sql2;
    }
    else {
        push @$bindref, $ele;
        return '?';
    }
}

# sql_interp helper function to interpolate "key IN list",
# assuming context ("WHERE", {key => $list, ...}).
sub _in_list {
    my ($state, $bindref, $varobj_usedref, $key, $list) = @_;
    if (@$list == 0) {
        return "1=0";
    }
    else {
        my @sqle;
        for my $ele (@$list) {
            my $sqle
                = _sql_interp_data($state, $bindref, $varobj_usedref, $ele);
            push @sqle, $sqle;
        }
        my $sql2 = $key . " IN (" . join(', ', @sqle) . ")";
        return $sql2;
    }
}

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

sub make_sql_interp {
    my (@params) = @_;
    my $interp = sub {
        return sql_interp(@params, @_);
    };
    return $interp;
}

sub sql_var {
    return SQL::Interpolate::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::Interpolate error: Unrecognized "
         . "'$cur'$prev_text in interpolation list.");
    return;
}

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

# This shall only be called by SQL::Interpolate::Macro.
sub _enable_macros {
    scalar(caller()) eq 'SQL::Interpolate::Macro' or die 'ASSERT';
    $macros_enabled = 1;  # enable macros
    return;
}

# This shall only be called by DBIx::Interpolate.
sub _use_params {
    scalar(caller()) eq 'DBIx::Interpolate' or die 'ASSERT';

    # supported use parameters.
    return qw(FILTER TRACE_SQL TRACE_FILTER);
}

# depreciated
sub sql_literal {
    print STDERR
        "SQL::Interpolate - WARNING: "
        . "sql_literal() is depreciated. use sql() instead.\n";
    return sql(@_);
}

1;

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

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

1;


package SQL::Interpolate::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.
# This is particularly useful to SQL::Interpolate::Filter.
sub concat {
    my ($a, $b, $inverted) = @_;

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

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

1;

__END__