File Coverage

blib/lib/SQL/TwoWay.pm

Criterion	Covered	Total	%
statement	95	103	92.2
branch	26	34	76.4
condition	6	9	66.6
subroutine	16	17	94.1
pod	0	5	0.0
total	143	168	85.1

package SQL::TwoWay;
use strict;
use warnings FATAL => 'recursion';
use 5.010001; # Named capture
our $VERSION = "0.05";
use Carp ();
use Scalar::Util qw(reftype);

use parent qw(Exporter);

our @EXPORT = qw(two_way_sql);

our ($TOKEN_STR2ID, $TOKEN_ID2STR);
BEGIN {
    $TOKEN_STR2ID = +{
        VARIABLE => 1,
        SQL      => 2,
        IF       => 3,
        ELSE     => 4,
        END_     => 5,
    };
    $TOKEN_ID2STR = +{ reverse %$TOKEN_STR2ID };
}
use constant $TOKEN_STR2ID;

sub token2str {
    $TOKEN_ID2STR->{+shift}
}

sub two_way_sql {
    my ($sql, $params) = @_;

    my $tokens = tokenize_two_way_sql($sql);
    my $ast = parse_two_way_sql($tokens);
    my ($generated_sql, @binds) = process_two_way_sql($ast, $params);
    return ($generated_sql, @binds);
}

sub process_two_way_sql {
    my ($ast, $params) = @_;
    my ($sql, @binds);
    for my $node (@$ast) {
        if ($node->[0] eq IF) {
            my $name = $node->[1];
            unless (exists $params->{$name}) {
                Carp::croak("Unknown parameter for IF stmt: $name");
            }
            if ($params->{$name}) {
                my ($is, @ib) = process_two_way_sql($node->[2], $params);
                $sql .= $is;
                push @binds, @ib;
            } else {
                my ($is, @ib) = process_two_way_sql($node->[3], $params);
                $sql .= $is;
                push @binds, @ib;
            }
        } elsif ($node->[0] eq VARIABLE) {
            my $name = $node->[1];
            unless (exists $params->{$name}) {
                Carp::croak("Unknown parameter: $name");
            }

            if (reftype($params->{$name}) eq 'ARRAY') {
                $sql .= '('. join(',', ('?')x@{$params->{$name}}) .')';
                push @binds, @{$params->{$name}};
            } else {
                $sql .= '?';
                push @binds, $params->{$name};
            }
        } elsif ($node->[0] eq SQL) {
            $sql .= $node->[1];
        } else {
            Carp::croak("Unknown node: " . token2str($node->[0]));
        }
    }
    return ($sql, @binds);
}

sub parse_two_way_sql {
    my ($tokens) = @_;
    my @ast;
    while (@$tokens > 0) {
        push @ast, _parse_stmt($tokens);
    }
    return \@ast;
}

sub _parse_statements {
    my ($tokens) = @_;

    my @stmts;
    while (@$tokens && (
            $tokens->[0]->[0] == SQL
        ||  $tokens->[0]->[0] == VARIABLE
        ||  $tokens->[0]->[0] == IF
    )) {
        push @stmts, _parse_stmt($tokens);
    }
    return \@stmts;
}

sub _parse_stmt {
    my ($tokens) = @_;

    if ($tokens->[0]->[0] eq SQL || $tokens->[0]->[0] eq VARIABLE) {
        my $token = shift @$tokens;
        return [
            $token->[0],
            $token->[1]
        ];
    } elsif ($tokens->[0]->[0] eq IF) {
        return _parse_if_stmt($tokens);
    } else {
        Carp::croak("Unexpected token: " . token2str($tokens->[0]->[0]));
    }
}

sub _parse_if_stmt {
    my ($tokens) = @_;

    # IF
    my $if = shift @$tokens;

    # Parse statements
    my $if_block = _parse_statements($tokens);

    # ELSE block
    my $else_block = [];
    if ($tokens->[0]->[0] eq ELSE) {
        shift @$tokens; # remove ELSE
        $else_block = _parse_statements($tokens);
    }

    # And, there is END_
    unless ($tokens->[0]->[0] eq END_) {
        Carp::croak("Unexpected EOF in IF statement");
    }
    shift @$tokens; # remove END_

    return [
        IF, $if->[1], $if_block, $else_block
    ];
}

sub tokenize_two_way_sql {
    my $sql = shift;

    my @ret;
    my $NUMERIC_LITERAL = "-? [0-9.]+";
    my $STRING_LITERAL = q{ (?:
                                "
                                    (?:
                                        \\\\"
                                        | ""
                                        | [^"]
                                    )*
                                "
                                |
                                '
                                    (?:
                                        \\\\'
                                        | ''
                                        | [^']
                                    )*
                                '
                            ) };
    my $LITERAL = "(?: $STRING_LITERAL | $NUMERIC_LITERAL )";
    my $SINGLE_SLASH = '/ (?! \*)';
    $sql =~ s!
        # Variable /* $var */3
        (
            /\* \s+ \$ (? [A-Za-z0-9_-]+) \s+ \*/
            (?:
                # (3,2,4)
                $LITERAL | \(
                    (?: \s* $LITERAL \s* , \s* )*
                    $LITERAL
                \)
            )
        )
        |
        (?:
            /\* \s+ IF \s+ \$ (? [A-Za-z0-9_-]+) \s+ \*/
        )
        |
        (?
            /\* \s+ ELSE \s+ \*/
        )
        |
        (?
            /\* \s+ END \s+ \*/
        )
        |
        # Normal SQL strings
        (? [^/]+ )
        |
        # Single slash character
        (? $SINGLE_SLASH )
    !
        if (defined $+{variable}) {
            push @ret, [VARIABLE, $+{variable}]
        } elsif (defined $+{ifcond}) {
            push @ret, [IF, $+{ifcond}]
        } elsif (defined $+{else}) {
            push @ret, [ELSE]
        } elsif (defined $+{end}) {
            push @ret, [END_]
        } elsif (defined $+{sql1}) {
            push @ret, [SQL, $+{sql1}]
        } elsif (defined $+{sql2}) {
            push @ret, [SQL, $+{sql2}]
        } else {
            Carp::croak("Invalid sql: $sql");
        }
        ''
    !gex;

    return \@ret;
}

1;
__END__