package App::Queries;
use base 'Exporter';
our @EXPORT_OK = (qw( get_query_hash ));

sub get_query_hash {
    return \%queries;
}

my %queries = (
    get_reprocessing_list => {
        type => 'simple',
        source => q( SELECT typeID FROM typeAM; ),
    },
    get_blueprintTypeID => {
        type => 'complex',
        source => q( SELECT [% var $extract %], bpID FROM invBpT; ),
    }
);
[download]

package App;

use App::Queries qw( get_query_hash );
use SQL::Template qw( load_query_hash get_query );

load_query_hash( get_query_hash() );

my $simple_query = get_query( 'get_reprocessing_list' );

my $input = { extract => 'productTypeID' };
my $complex_query = get_query( 'get_blueprintTypeID', $input );

print "$simple_query\n$complex_query";
[download]

SELECT typeID FROM typeAM;
SELECT productTypeID, bpID FROM invBpT;
[download]

package SQL::Template;
use 5.010;
use strict;
use warnings;

use base 'Exporter';
our @EXPORT_OK = qw( load_query_hash get_query );

use Carp qw( cluck confess );

my $queries;

my $eval_methods = {
    simple  => \&eval_simple,
    complex => \&eval_complex,
};

sub load_query_hash {
    my ($import) = @_;

    for my $name ( keys %{$import} ) {
        cluck "Existing query template redefined: $name"
          if ( $queries->{$name} );

        $queries->{$name} = $import->{$name};
    }

    return;
}

sub get_query {
    my ( $name, $input ) = @_;

    my $error;
    my $query = $queries->{$name};

    $error = "Query template unknown for: $name" if ( !$query );
    $error = "Eval method $query->{type} unknown for: $name"
      if ( !$error and !$eval_methods->{ $query->{type} } );

    if ($error) {
        confess $error;
        return;
    }

    $eval_methods->{ $query->{type} }->( $query, $input );

    return $query->{target};
}

sub eval_simple {
    my ($query) = @_;

    return if ( $query->{target} );

    $query->{target} = $query->{source};

    return;
}

sub eval_complex {
    my ( $query, $input ) = @_;

    $query->{sub} = compile_template( $query->{source} ) if ( !$query-
+>{sub} );

    $query->{target} = $query->{sub}->( %{$input} );

    return;
}

sub compile_template {
    my ($str) = @_;
    my $code;

    local $SIG{__WARN__} = sub { confess "Template Error: ", @_; };

    $str =~ s/^\s+//;
    $str =~ s/\s+$//;

    while (
        $str =~
        m@(.*?)(\[% (/?)(var|const|if|loop)(?:|\s+(.*?[^\\])) %\]|$)@s
+g
    ) {
        my ( $content, $tag, $closing, $name, $args ) = ( $1, $2, $3, 
+$4, $5 );

        $content =~ s/(['\\])/\\$1/g;
        $code .= "\$res.='$content';" if ( length $content );
        $args =~ s/\\>/>/g if ( defined $args );

        if ($tag) {
            if ($closing) {
                if ( $name eq 'if' ) {
                    $code .= '}';
                }
                elsif ( $name eq 'loop' ) {
                    $code .= '$$_=$__ov{$_} for(keys %__ov);
                        }
                    }
                    }';
                }
            }
            else {
                if ( $name eq 'var' ) {
                    $code .= '$res.=eval{' . $args . '};';
                }
                elsif ( $name eq 'const' ) {
                    my $const = eval $args;
                    $const =~ s/(['\\])/\\$1/g;
                    $code .= '$res.=\'' . $const . '\';';
                }
                elsif ( $name eq 'if' ) {
                    $code .= 'if (eval{' . $args . '} ) {';
                }
                elsif ( $name eq 'loop' ) {
                    $code .= '{'
                      . 'my $__a=eval{ '
                      . $args . '}; '
                      . 'if ($__a) { '
                      . '   for (@$__a) { '
                      . '       my %__v=%{$_}; '
                      . '       my %__ov; '
                      . '       for (keys %__v) { '
                      . '           $__ov{$_}=$$_; '
                      . '           $$_=$__v{$_}; '
                      . '       }';
                }
            }
        }
    }

    $code =
        'no strict; ' 
      . 'sub { '
      . '   my %__v=@_; '
      . '   my %__ov; '
      . '   for (keys %__v) { '
      . '      $__ov{$_}=$$_; '
      . '      $$_=$__v{$_}; ' . '   }'
      . '   my $res = "";'
      . $code
      . '   $$_=$__ov{$_} for(keys %__ov);'
      . '   return $res; ' . '} ';

    my $sub = eval $code;

    confess "Template format error: $@" if ( !$sub );

    return $sub;
}

1;
[download]