Author: spadkins
Date: Thu Nov 6 10:42:45 2008
New Revision: 12052
Added:
p5ee/trunk/App-Repository/lib/App/SessionObject/SQLTranslator.pm
Log:
New file
Added: p5ee/trunk/App-Repository/lib/App/SessionObject/SQLTranslator.pm
==============================================================================
--- (empty file)
+++ p5ee/trunk/App-Repository/lib/App/SessionObject/SQLTranslator.pm Thu Nov
6 10:42:45 2008
@@ -0,0 +1,210 @@
+
+#############################################################################
+## $Id: SQLTranslator.pm 9934 2007-09-11 18:04:00Z spadkins $
+#############################################################################
+
+package App::SessionObject::SQLTranslator;
+$VERSION = (q$Revision: 9934 $ =~ /(\d[\d\.]*)/)[0]; # VERSION numbers
generated by svn
+
+use App;
+use App::SessionObject;
+
[EMAIL PROTECTED] = ( "App::SessionObject" );
+
+use strict;
+use warnings;
+use Parse::RecDescent;
+
+sub _init {
+ &App::sub_entry if ($App::trace);
+ my ($self, $args) = @_;
+ $self->SUPER::_init();
+ my $grammar = <<'EOF';
+sqlstatement: expression(s) #{ ['EXPR', map {$_->[0]} @item[1..$#item] ] }
+
+expression : '{' sub_var '}' { ['EXPR', $item[2] ]}
+ | '{' function '}' { ['EXPR', $item[2] ]}
+ | '{' group '}' { ['EXPR', $item[2] ]}
+ | freetext {['FREETEXT', $item[1]]}
+ | '{' subex '}' {['EXPR', $item[2] ] }
+ | '{' freetext {['FREETEXT', [$item[1].$item[2][0]] ]}
+ | '{' {['FREETEXT', $item[1]]}
+
+sub1 : <leftop: group multop group> {['SUBEX', $item[1]]}
+
+sub2 : <leftop: sub1 addop sub1> {['SUBEX', $item[1]]}
+sub3 : <leftop: sub2 boolop sub2> {['SUBEX', $item[1]]}
+sub4 : <leftop: sub3 setop list> {['SUBEX', $item[1]]}
+
+subex : case | sub4
+
+function : identifier '(' args ')' {['FUNCTION', $item[1], $item[3]]}
+ | identifier '(' ')' {['FUNCTION', $item[1] ]}
+
+case : /case/i subex (when)(s) /else/i subex /end/i
+ {['CASE', $item[2], $item[3], $item[5]]}
+ | /case/i (when)(s) /else/i subex /end/i
+ {['CASE', [SUBEX => [[LITERAL => '']]], $item[2], $item[4]]}
+
+when : /when/i subex /then/i subex {[WHEN => [$item[2], $item[4]]]}
+
+list : '(' args ')' {['LIST', $item[2]]}
+
+group : '(' flit ')' {['GROUP', $item[2]]}
+ | '(' subex ')' {['GROUP', $item[2]]}
+ | '(' args ')' {['GROUP', $item[2]]}
+ | flit {$item[1]}
+ | '(' group ')' {['GROUP', $item[2]]}
+
+addop : /[-+]/ { ['OP', $item[1]] }
+multop : /[\/*%]/ { ['OP', $item[1]] }
+boolop : /!=|==?|>=?|<=?|is|or|and|regexp|like/i {['OP', $item[1]]}
+setop : /in/i { ['OP', $item[1]]}
+
+freetext :<skip: qr//> (/[^\{]+/)(s)
+
+args : <leftop: subex ',' subex>
+
+flit : function | literal | expression
+
+sub_var : variable ':' literal {['SUBSTITUTION', $item[1], $item[3]]}
+ | variable {['SUBSTITUTION', $item[1]]}
+
+literal : /-?\d*\.\d+/ {['LITERAL', $item[1]]}
+ | /-?\d+/ {['LITERAL', $item[1]]}
+ | <perl_quotelike>
+ {['LITERAL', $item[1][0].$item[1][1].$item[1][2].$item[1][3]]}
+ | /[[:alnum:]\._]+/ {['LITERAL', $item[1]]}
+
+variable : /[_[:alpha:]][[:alnum:]_]*/ {['VAR', $item[1]]}
+
+identifier : /[_[:alpha:]][[:alnum:]_]*/ {['IDENTIFIER', $item[1] ]}
+
+EOF
+
+ $self->{parser} = Parse::RecDescent->new($grammar);
+ $self->_init_operator_table();
+ $self->_init_function_table();
+ &App::sub_exit() if ($App::trace);
+}
+
+sub _init_operator_table {
+ my ($self) = @_;
+ $self->{operator_table} = {
+ };
+}
+
+sub _init_function_table {
+ my ($self) = @_;
+ $self->{function_table} = {
+ };
+}
+
+sub translate {
+ my ($self, $expr) = @_;
+ return $self->evaluate($self->{parser}->sqlstatement($expr));
+}
+
+sub evaluate {
+ my ($self, $tree) = @_;
+ my (@args, $ret, @ret);
+
+ my %jump_table = (
+ FUNCTION => sub { shift->function(@{$_[0]}[1,2]) },
+ LITERAL => sub {shift; $_[0]->[1]},
+ OP => sub {shift; $_[0]->[1]},
+ IDENTIFIER => sub {shift; $_[0]->[1]},
+ EXPR => sub {$_[1] = $_[1]->[1];goto &evaluate},
+ SUBSTITUTION => sub { shift->substitution(@{$_[0]}[1,2]) },
+ SUBEX => sub { shift->subex(@[EMAIL PROTECTED]) },
+ GROUP => sub { shift->group($_[0][1]) },
+ LIST => sub { shift->list($_[0][1]) },
+ FREETEXT => sub {shift; $_[0]->[1][0] },
+ VAR => sub {shift; $_[0]->[1] },
+ WHEN => sub { $self = shift;
+ join "", ' WHEN ', $self->evaluate($_[0][1][0]),
+ ' THEN ', $self->evaluate($_[0][1][1])
+ },
+ CASE => sub { my $self = shift; join "",
+ ' CASE ', $self->evaluate($_[0][1]),
+ $self->evaluate($_[0][2]),
+ ' ELSE ', $self->evaluate( $_[0][3]),
+ ' END'
+ },
+ );
+
+ if (ref($tree->[0]) eq 'ARRAY') {
+ for my $tre (@{$tree}) {
+ push (@ret, $jump_table{$tre->[0]}->($self,$tre));
+ #print STDERR "evaluate(): tree : [EMAIL PROTECTED] =>
$ret[$#ret]\n";
+ }
+ }
+ else {
+ push (@ret, $jump_table{$tree->[0]}->($self, $tree));
+ #print STDERR "evaluate(): tree : [EMAIL PROTECTED] => $ret[$#ret]\n";
+ }
+ return join("", @ret);
+}
+
+sub function {
+ my ($self, $name, $args) = @_;
+ my @fargs = map { $self->evaluate( $_) } @{$args || []};
+
+ my $function_table = $self->{function_table};
+ return(defined $function_table->{lc($name->[1])} ?
+ $function_table->{lc($name->[1])}->(@fargs) :
+ $name->[1]."(".(join ",", @fargs).")");
+}
+
+sub substitution {
+ my ($self, $var, $value) = @_;
+
+ my $name = $var->[1];
+ my $default = defined $value->[1] ? $value->[1] : '';
+
+ return qq{$default};
+}
+
+sub subex {
+ my $self = shift;
+
+ my @arr = @_;
+
+ my $operator_table = $self->{operator_table};
+ for my $op (split /\|/, q(in|!=|==|=|>|<|>=|<=|is|or|and|regexp)) {
+ $operator_table->{$op} = sub {my @arg = @_;return "$arg[0] $op
$arg[1]"};
+ }
+ return $self->evaluate( $arr[0]) if !$arr[1];
+ my @ret;
+ push @ret, $self->evaluate(shift @arr);
+ while (my $op = shift @arr) {
+ if (exists($operator_table->{$op->[1]})) {
+ push (@ret, $operator_table->{$op->[1]}->(pop @ret,
$self->evaluate( shift @arr)));
+ } else {
+ push (@ret, $op->[1], $self->evaluate(shift @arr));
+ }
+ }
+ return @ret;
+}
+
+sub group {
+ my ($self, $first, $op, $second) = @_;
+
+ my @group = $self->evaluate($first);
+
+ # If the number of elements were not reduced to 1. Add () and stringify as
+ # an element. Otherwise return our element. () not needed for single value.
+ if (@group > 1) {
+ return "(". (join "",@group). ")";
+ }
+ return @group;
+}
+
+sub list {
+ my ($self, $subex) = @_;
+ my @list = $self->evaluate($subex);
+ return "(". (join ",",@list). ")";
+}
+
+1;
+
