#!/usr/bin/perl
#
# $Header: /Users/claude/fuzz/lib/Genezzo/Plan/RCS/TypeCheck.pm,v 7.17 2006/08/26 06:58:03 claude Exp claude $
#
# copyright (c) 2005,2006 Jeffrey I Cohen, all rights reserved, worldwide
#
#
package Genezzo::Plan::TypeCheck;
use Genezzo::Util;
use strict;
use warnings;
use warnings::register;
use Carp;
our $VERSION;
BEGIN {
$VERSION = do { my @r = (q$Revision: 7.17 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
}
our $GZERR = sub {
my %args = (@_);
return
unless (exists($args{msg}));
if (exists($args{self}))
{
my $self = $args{self};
if (defined($self) && exists($self->{GZERR}))
{
my $err_cb = $self->{GZERR};
return &$err_cb(%args);
}
}
carp $args{msg}
if warnings::enabled();
};
sub _init
{
my $self = shift;
my %args = @_;
return 0
unless (exists($args{plan_ctx})
&& defined($args{plan_ctx}));
$self->{plan_ctx} = $args{plan_ctx};
my %valid_aggs =
qw(
MIN 1
MAX 1
AVG 1
SUM 1
MEAN 1
STDDEV 1
COUNT 1
ECOUNT 1
);
$self->{aggregate_functions} = \%valid_aggs;
return 1;
}
sub new
{
# whoami;
my $invocant = shift;
my $class = ref($invocant) || $invocant ;
my $self = { };
my %args = (@_);
if ((exists($args{GZERR}))
&& (defined($args{GZERR}))
&& (length($args{GZERR})))
{
# NOTE: don't supply our GZERR here - will get
# recursive failure...
$self->{GZERR} = $args{GZERR};
my $err_cb = $self->{GZERR};
# capture all standard error messages
$Genezzo::Util::UTIL_EPRINT =
sub {
&$err_cb(self => $self,
severity => 'error',
msg => @_); };
$Genezzo::Util::WHISPER_PRINT =
sub {
&$err_cb(self => $self,
# severity => 'error',
msg => @_); };
}
return undef
unless (_init($self, %args));
return bless $self, $class;
} # end new
sub TypeCheck
{
my $self = shift;
my %required = (
algebra => "no algebra !",
statement => "no sql statement !",
dict => "no dictionary !"
);
my %args = ( # %optional,
@_);
return undef
unless (Validate(\%args, \%required));
my $algebra = $args{algebra};
my $err_status;
# build a special "statement handle" to hold error and context info
my $tc_sth = {};
$tc_sth->{statement} = $args{statement};
$algebra = $self->TableCheck(algebra => $algebra,
dict => $args{dict},
tc_sth => $tc_sth
);
return ($algebra, 1)
unless (defined($algebra)); # if error
greet $tc_sth->{tc1}->{tc_err};
unless (scalar(@{$tc_sth->{tc1}->{tc_err}->{nosuch_table}}))
{
$algebra = $self->ColumnCheck(algebra => $algebra,
dict => $args{dict},
statement => $args{statement},
tc_sth => $tc_sth
);
}
unless (exists($tc_sth->{tc1}) &&
exists($tc_sth->{tc2}) &&
exists($tc_sth->{tc3}))
{
greet "incomplete tc";
$err_status = 1;
}
if (!defined($err_status))
{
for my $kk (keys(%{$tc_sth->{tc1}->{tc_err}}))
{
if (scalar(@{$tc_sth->{tc1}->{tc_err}->{$kk}}))
{
$err_status = 1;
last;
}
}
if (!defined($err_status))
{
for my $kk (keys(%{$tc_sth->{tc3}->{tc_err}}))
{
next # only case of hash vs array
if ($kk eq "duplicate_alias");
if (scalar(@{$tc_sth->{tc3}->{tc_err}->{$kk}}))
{
$err_status = 1;
last;
}
}
}
greet "tc errors"
if (defined($err_status));
}
# NOTE: attach the "statement handle" to the algebra -- it contains
# useful information for code generation
$algebra->{tc_sth} = $tc_sth;
return ($algebra, $err_status);
}
sub TableCheck
{
my $self = shift;
my %required = (
algebra => "no algebra !",
dict => "no dictionary !",
tc_sth => "no statement handle !"
);
my %args = ( # %optional,
@_);
return undef
unless (Validate(\%args, \%required));
my $algebra = $args{algebra};
# XXX XXX: maybe break the type check phases into separate packages
# first, fetch table info from dictionary
my $tc1 = {}; # type check tree context for tree walker
my $tc_sth = $args{tc_sth};
$tc_sth->{tc1} = $tc1;
# local tree walk state
$tc1->{tpos} = 0; # mark each table
# save bad tables for error reporting...
$tc1->{tc_err}->{nosuch_table} = [];
$tc1->{tc_err}->{duplicate_table} = [];
$algebra = $self->_get_table_info($algebra, $args{dict}, $tc_sth);
# next, cross reference table info with query blocks
my $tc2 = {}; # type check tree context for tree walker
$tc_sth->{tc2} = $tc2;
# local tree walk state
$tc2->{qb_list} = []; # build an arr starting with current query block num
$tc2->{qb_dependency} = []; # save qb parent dependency
# save table definition/query block info for later type check phases...
$tc2->{tablist} = []; # arr by qb num of table information
$algebra = $self->_check_table_info($algebra, $args{dict}, $tc_sth);
if (0)
{
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
print Data::Dumper->Dump([$tc2],['tc2']);
}
return $algebra;
}
# convert an array of quoted strings/barewords into an array
# of normalized strings
sub _process_name_pieces
{
my @pieces = @_;
my @full_name;
# turn array of name "pieces" back into full names
for my $name_piece (@pieces)
{
# may need to distinguish between bareword and
# quoted strings
if (exists($name_piece->{quoted_string}))
{
my $p1 = $name_piece->{quoted_string};
# strip leading/trailing quotes
my @p2 = $p1 =~ m/^\"(.*)\"$/;
push @full_name, @p2;
}
else
{
# XXX XXX: may need to uc or lc here...
if (exists($name_piece->{bareword}))
{
my $p1 = $name_piece->{bareword};
push @full_name, lc($p1);
}
# while ( my ($kk,$p1) = (each(%{$name_piece})))
# {
# next if ($kk =~ m/^(p1|p2)$/);
# push @full_name, lc($p1);
# }
}
}
# NOTE: issue of handling quoted name pieces with
# embedded "." (dot) if wish to construct full_name_str
# as join('.', @full_name) -- need to avoid ambiguity
return @full_name;
}
sub _process_name_position
{
my @pieces = @_;
my @full_pos;
for my $name_piece (@pieces)
{
my ($p1, $p2);
$p1 = undef;
$p2 = undef;
$p1 = ($name_piece->{p1})
if (exists($name_piece->{p1}));
$p2 = ($name_piece->{p2})
if (exists($name_piece->{p2}));
# build array of positions of each piece of name...
push @full_pos, [$p1, $p2];
}
return @full_pos;
}
# recursive function to decorate table info
#
# get table information from the dictionary
# number each table uniquely
#
sub _get_table_info # private
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc1};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# recursively convert all elements of hash, but treat
# table name specially
if (exists($genTree->{table_name}))
{
# uniquely number each table reference
# Note: use for join order to select STAR expansion
$genTree->{tc_table_position} = $treeCtx->{tpos};
$treeCtx->{tpos}++;
my @full_name = _process_name_pieces(@{$genTree->{table_name}});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
$genTree->{tc_table_fullname} = $full_name_str;
# look it up in the dictionary
if (! ($dict->DictTableExists (
tname => $full_name_str,
silent_exists => 1,
silent_notexists => 0
)
)
)
{
push @{$treeCtx->{tc_err}->{nosuch_table}},
["table", $full_name_str];
# return undef; # XXX XXX XXX XXX
}
else
{
# XXX XXX: temporary?
# get hash by column name
$genTree->{tc_table_colhsh} =
$dict->DictTableGetCols (tname => $full_name_str);
my @colarr;
(keys(%{$genTree->{tc_table_colhsh}}));
# build array by column position
while ( my ($chkk, $chvv)
= each ( %{$genTree->{tc_table_colhsh}}))
{
my %nh = (colname => $chkk, coltype => $chvv->[1]);
$colarr[$chvv->[0]] = \%nh;
}
shift @colarr;
$genTree->{tc_table_colarr} = \@colarr;
}
} # end if tablename
if (exists($genTree->{new_table_name}))
{
my @full_name = _process_name_pieces(@{$genTree->{new_table_name}});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
$genTree->{tc_newtable_fullname} = $full_name_str;
# look it up in the dictionary
if ($dict->DictTableExists (
tname => $full_name_str,
silent_exists => 0,
silent_notexists => 1
)
)
{
push @{$treeCtx->{tc_err}->{duplicate_table}},
["table", $full_name_str];
# return undef; # XXX XXX XXX XXX
}
} # end if new table name
if (exists($genTree->{new_index_name}))
{
my @full_name = _process_name_pieces(@{$genTree->{new_index_name}});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
$genTree->{tc_newindex_fullname} = $full_name_str;
# look it up in the dictionary
if ($dict->DictTableExists (
tname => $full_name_str,
silent_exists => 0,
silent_notexists => 1
)
)
{
# XXX XXX: should be "duplicate index"...
push @{$treeCtx->{tc_err}->{duplicate_table}},
["index", $full_name_str];
# return undef; # XXX XXX XXX XXX
}
} # end if new index name
if (exists($genTree->{tablespace_name}))
{
my @full_name = _process_name_pieces(@{$genTree->{tablespace_name}});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
$genTree->{tc_tablespace_fullname} = $full_name_str;
# look it up in the dictionary
if (! ($dict->DictObjectExists (
object_type => "tablespace",
object_name => $full_name_str,
silent_exists => 1,
silent_notexists => 0
)
)
)
{
push @{$treeCtx->{tc_err}->{nosuch_table}},
["tablespace", $full_name_str];
# return undef; # XXX XXX XXX XXX
}
}
if (exists($genTree->{new_tablespace_name}))
{
my @full_name = _process_name_pieces(@{$genTree->{new_tablespace_name}});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
$genTree->{tc_newtablespace_fullname} = $full_name_str;
# look it up in the dictionary
if ($dict->DictObjectExists (
object_type => "tablespace",
object_name => $full_name_str,
silent_exists => 0,
silent_notexists => 1
)
)
{
push @{$treeCtx->{tc_err}->{duplicate_table}},
["tablespace", $full_name_str];
greet $treeCtx->{tc_err}->{duplicate_table};
# return undef; # XXX XXX XXX XXX
}
else
{
greet "no dup found";
}
} # end if new tablespace name
if (exists($genTree->{table_alias}))
{
if (scalar(@{$genTree->{table_alias}}))
{
# don't build an alias unless we really have one
my @full_name =
_process_name_pieces(@{$genTree->{table_alias}});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
$genTree->{tc_table_fullalias} = $full_name_str;
}
# XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
# detect FROM clause subquery -- need to build
# tc_table_colhsh, tc_table_colarr later
# XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
unless (exists($genTree->{table_name}))
{
# uniquely number each table reference
# Note: use for join order to select STAR expansion
$genTree->{tc_table_position} = $treeCtx->{tpos};
if (exists($genTree->{tc_table_fullalias}))
{
$genTree->{tc_FROM_SUBQ} = { alias => "USER_ALIAS" };
}
else
{
# build a unique alias
# XXX XXX: need a better unique function
$genTree->{tc_table_fullalias} =
"_SYS_ALIAS_" . $treeCtx->{tpos};
$genTree->{tc_FROM_SUBQ} = { alias => "SYSTEM_ALIAS" };
}
$genTree->{tc_FROM_SUBQ}->{subq_schema} = "UNKNOWN" ;
$treeCtx->{tpos}++;
# setup the "table fullname" for check table...
$genTree->{tc_table_fullname} = $genTree->{tc_table_fullalias};
} # end if FROM subq
} # end if table alias
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
if ($kk !~ m/^(table_name|table_alias)$/)
{
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
} # end big while
}
return $genTree;
}
# check the validity of results of _get_table_info
#
# determine proper table/alias name
# find duplicates
# associate table info with appropriate query block
# build list of query block dependency information for correlated subqueries
#
sub _check_table_info # private
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc2};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
unless (defined($treeCtx->{tablist}->[$current_qb]))
{
# build a hash to hold the table info associated with
# the current query block
$treeCtx->{tablist}->[$current_qb] = {
tables => {},
# reserve space for select list column aliases
select_list_aliases => {},
select_col_num => 0
};
}
if (exists($genTree->{query_block_parent}))
{
# save the query block dependency information
my @foo = @{$genTree->{query_block_parent}};
$treeCtx->{qb_dependency}->[$current_qb] = \@foo;
}
}
# NOTE: build an alias if we don't have one. Do it outside the
# loop in order to avoid updating the hash as we traverse it.
if (exists($genTree->{tc_table_fullname}))
{
unless (exists($genTree->{tc_table_fullalias}))
{
my $tab_alias = $genTree->{tc_table_fullname};
$genTree->{tc_table_fullalias} = $tab_alias;
}
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
if ($kk !~ m/^tc_table_fullname$/)
{
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
else # table name
{
my $tab_alias;
if (exists($genTree->{tc_table_fullalias}))
{
$tab_alias = $genTree->{tc_table_fullalias};
}
else
{
# NOTE: should never get here - should always
# define an alias outside this loop...
$tab_alias = $vv;
}
# store table info in the table list for the current
# query block
my $current_qb = $treeCtx->{qb_list}->[0];
my $tablist = $treeCtx->{tablist}->[$current_qb]->{tables};
# use the alias, rather than the tablename -- this is
# ok since the alias points to the base table info.
if (exists($tablist->{$tab_alias}))
{
my $msg = "Found duplicate table name: " .
"\'$tab_alias\'\n";
my %earg = (self => $self, msg => $msg,
statement => $tc_sth->{statement},
severity => 'warn');
&$GZERR(%earg)
if (defined($GZERR));
# return undef # XXX XXX XXX
}
else
{
# save a reference to current hash
$tablist->{$tab_alias} = $genTree;
}
} # end table name
} # end big while
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
}
sub ColumnCheck
{
my $self = shift;
my %required = (
algebra => "no algebra !",
statement => "no sql statement !",
dict => "no dictionary !",
tc_sth => "no statement handle !"
);
my %args = ( # %optional,
@_);
return undef
unless (Validate(\%args, \%required));
my $algebra = $args{algebra};
my $tc3 = {}; # type check tree context for tree walker
my $tc_sth = $args{tc_sth};
$tc_sth->{tc3} = $tc3;
# local tree walk state
$tc3->{qb_list} = []; # build an arr starting with current query block num
$tc3->{statement} = $args{statement};
# save bad columns for error reporting
$tc3->{tc_err}->{duplicate_alias} = {};
$tc3->{tc_err}->{nosuch_column} = [];
# use the table information from table typecheck phase
$tc3->{tablist} = $tc_sth->{tc2}->{tablist};
# convert "select * " to "select <column_list> "
$algebra = $self->_get_star_cols($algebra, $args{dict}, $tc_sth);
# setup select list column aliases and column headers
$algebra = $self->_get_col_alias($algebra, $args{dict}, $tc_sth);
# map columns to FROM clause tables
$algebra = $self->_get_col_info($algebra, $args{dict}, $tc_sth);
# use type information to map sql comparison operations to their
# perl equivalents
$algebra = $self->_fixup_comp_op($algebra, $args{dict}, $tc_sth);
$tc3->{tc_err}->{invalid_args} = [];
# mark aggregates and check for invalid args
$algebra = $self->_find_aggregate_functions($algebra,
$args{dict},
$tc_sth);
$tc3->{tc_agg_check} = [];
# check for aggregates in WHERE clause
$algebra = $self->_check_aggregate_functions($algebra,
$args{dict},
$tc_sth);
# check for GROUPing/aggregates
# check for final select list columns vs all projected columns in
# all clauses
# check args for all functions
$tc3->{AndPurity} = 1; # false if find OR's
# XXX XXX: moved this to XEVal::Prepare
# $algebra = $self->_sql_where($algebra, $args{dict}, $tc_sth);
if (0) # XXX XXX XXX XXX
{
my $tc2 = $tc_sth->{tc2};
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
print Data::Dumper->Dump([$tc2],['tc2']);
}
# NOTE: need to build the select list column aliases *first*,
# then type check all columns.
#
# Different standards (SQL92, SQL99) and different products have
# different scoping and precedence rules on the select list column
# aliases. In general, the WHERE clause is processed before the
# select list defines the column aliases, so it can only use table
# and table alias information. (Which makes sense -- you can have
# a column alias on an aggregate operator like COUNT(*), which
# can't be completely evaluated until the WHERE clause processes
# the final row.)
#
# ORDER BY is the last operation, so it can evaluate expressions
# using the column aliases. GROUP BY and HAVING behavior seems to
# be a bit of a tossup. We'll try to maintain some flexibility --
# the tablist has separate entries column alias info and table
# definitions in each query block. In case of ambiguity of column
# alias which matches an existing column name, use rule where
# column names take precedence over column aliases in GROUP
# BY/HAVING, *but* reverse precendence in ORDER BY.
#
# What is scope of column aliasing in select list itself? left to
# right (ie, col2 can utilize the col1 alias) or "simultaneous"?
#
#
# Note that select list column aliases are allowed to mask table
# columns, but all other table column references should not be
# ambiguous.
# XXX XXX XXX: _get_col_alias to only build up alias info in
# tablist, then _get_col_info to resolve column names against
# aliases, then tables if necessary
return $algebra;
}
sub _FROM_subq_star_fixup
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
return
unless (exists($genTree->{tc_FROM_SUBQ})
&& exists($genTree->{tc_FROM_SUBQ}->{subq_schema})
&& ($genTree->{tc_FROM_SUBQ}->{subq_schema} eq 'UNKNOWN'));
return
if (exists($genTree->{tc_table_colarr})
&& scalar($genTree->{tc_table_colarr}));
if (exists($genTree->{sql_query})
&& exists($genTree->{sql_query}->{operands})
&& scalar($genTree->{sql_query}->{operands}))
{
# select list of 1st sql query takes precedence for set operations...
my $first_op = $genTree->{sql_query}->{operands}->[0];
while (!exists($first_op->{sql_select})
&& exists($first_op->{operands})
&& scalar(@{$first_op->{operands}}))
{
# XXX XXX: this needs to be recursive for nested set operations!!
$first_op = $first_op->{operands}->[0];
}
if (exists($first_op->{sql_select})
&& exists($first_op->{sql_select}->{select_list})
&& scalar(@{$first_op->{sql_select}->{select_list}}))
{
my $sel_list1 = $first_op->{sql_select}->{select_list};
$genTree->{tc_table_colarr} = [];
$genTree->{tc_table_colhsh} = {};
my $sel_index = 0;
for my $sel_item (@{$sel_list1})
{
$sel_index++;
# greet $sel_item;
# XXX XXX: is there some way to streamline handling of
# literals here?
my ($hnam, $htyp);
if (scalar(@{$sel_item->{col_alias}}))
{
# XXX XXX: eliminate this duplicate code
my @full_name =
_process_name_pieces(
@{$sel_item->{col_alias}});
$hnam = join('.',@full_name);
# greet 1, $hnam;
}
else
{
my $col_hd;
if (exists($sel_item->{p1}))
{
$col_hd = substr($treeCtx->{statement},
$sel_item->{p1},
($sel_item->{p2} - $sel_item->{p1}) + 1
);
$col_hd =~ s/^\s*//; # trim leading spaces
# greet 2, $col_hd;
}
else
{
# XXX XXX: generated col for STAR - fake it
# XXX XXX: assume have a column name
my $npa = $sel_item->{value_expression}->{column_name};
my @col_name = _process_name_pieces(@{$npa});
$col_hd = join(".", @col_name);
# greet 3, $col_hd;
}
$hnam = $col_hd;
} # end no alias
$htyp = $sel_item->{value_expression}->{tc_expr_type};
my $h1 = { colname => $hnam,
coltype => $htyp };
push @{$genTree->{tc_table_colarr}}, $h1;
# XXX XXX: need duplicate col name check
# or type mismatch here!!
$genTree->{tc_table_colhsh}->{$hnam} =
[$sel_index, $htyp];
} # end for
}
}
$genTree->{tc_FROM_SUBQ}->{subq_schema} = 'OK';
}
# expand STAR select lists...
#
#
sub _get_star_cols
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# convert subtree first, then process local select list
{
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
# convert subtree first...
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
# fixup star select lists for FROM subqueries
$self->_FROM_subq_star_fixup($genTree, $dict, $tc_sth);
if (exists($genTree->{select_list}))
{
# if the select list is STAR (not an array)
unless (ref($genTree->{select_list}) eq 'ARRAY')
{
# start in current query block
# find our tablist
my $current_qb = $treeCtx->{qb_list}->[0];
my $curr_tablist = $treeCtx->{tablist}->[$current_qb];
my $table_cnt = keys( %{$curr_tablist->{tables}} ); # reset
my @tab_cols;
while ( my ($hkk, $hvv) =
each (%{$curr_tablist->{tables}}))
{
my $tpos = $hvv->{tc_table_position};
my $col_list = [];
# get all the column names
for my $colh (@{$hvv->{tc_table_colarr}})
{
push @{$col_list}, $colh->{colname};
}
# convert to array of value expressions
for my $colcnt (0..(scalar(@{$col_list})-1))
{
my $old_colname = $col_list->[$colcnt];
# quote the strings to preserve case
my $cv =
{quoted_string => '"' . $col_list->[$colcnt] . '"'};
# table name doesn't change, but building a
# new one each time gives a nicer Data::Dumper
# output...
my $table_name =
{quoted_string => '"' . $hkk .'"' };
my $foo = [];
if ($table_cnt > 1)
{
# don't use table name if only one table
push @{$foo}, $table_name;
}
push @{$foo}, $cv;
# build the value expression
my $nx = {
col_alias => [],
value_expression => {
column_name => $foo
}
};
$col_list->[$colcnt] = $nx;
# FROM SUBQUERY type fixup...
if (exists($hvv->{tc_table_colhsh})
&& exists($hvv->{tc_table_colhsh}->{$old_colname}))
{
$nx->{value_expression}->{tc_expr_type} =
$hvv->{tc_table_colhsh}->{$old_colname}->[1];
}
}
# store tables in tpos order
$tab_cols[$tpos] = $col_list;
} # end each tablist table
my $sel_list = [];
for my $tabi (@tab_cols)
{
if (defined($tabi) && scalar(@{$tabi}))
{
push @{$sel_list}, @{$tabi};
}
}
$genTree->{select_list} = $sel_list;
}
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
}
# get column aliases and column "headers"
#
#
sub _get_col_alias # private
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
if ($kk =~ m/^(column_list)$/)
{
$genTree->{tc_column_list} = [];
for my $all_cols (@{$genTree->{$kk}})
{
my @full_name = _process_name_pieces(@{$all_cols});
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
push @{$genTree->{tc_column_list}}, $full_name_str;
}
}
elsif ($kk !~ m/^(new_column_name|column_name|col_alias)$/)
{
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
else # column name or alias
{
my $isColumnName = ($kk =~ m/column_name$/);
my @full_name = _process_name_pieces(@{$vv});
my @full_pos = _process_name_position(@{$vv});
my $stat_pos = [];
if (scalar(@full_pos))
{
$stat_pos->[0] = $full_pos[0]->[0];
$stat_pos->[1] = $full_pos[-1]->[1];
}
# last portion should be column name (if not an alias)
my $column_name;
$column_name = pop @full_name
if ($isColumnName);
# build a "dot" separated string
my $full_name_str = join('.', @full_name);
if ($isColumnName)
{
# just build the names here -- lookup in dictionary later
$genTree->{tc_col_tablename} = $full_name_str
if (scalar(@full_name));
if ($kk =~ m/^new_column_name$/)
{
$genTree->{tc_newcolumn_name} = $column_name;
}
else
{
$genTree->{tc_column_name} = $column_name;
$genTree->{tc_column_name_stat_pos} = $stat_pos;
}
}
else # column alias
{
# don't build an alias unless we really have one
if (scalar(@full_name))
{
# alias for later reference
$genTree->{tc_col_fullalias} = $full_name_str;
# column "header" for formatting output is the
# same as the alias
$genTree->{tc_col_header} = $full_name_str;
# start in current query block
# find our tablist
# add our new select list column alias
my $current_qb = $treeCtx->{qb_list}->[0];
my $curr_tablist = $treeCtx->{tablist}->[$current_qb];
my $qb_aliases =
$curr_tablist->{select_list_aliases};
my $select_col_num =
$curr_tablist->{select_col_num};
$curr_tablist->{select_col_num} += 1;
if (exists($qb_aliases->{$full_name_str}))
{
# error: duplicate alias
my $dupa =
$treeCtx->{tc_err}->{duplicate_alias};
if (exists($dupa->{$full_name_str}))
{
# count duplicates!
$dupa->{$full_name_str} += 1;
}
else
{
$dupa->{$full_name_str} = 1;
}
# XXX XXX: is this illegal?
my $msg = "duplicate alias: " .
"\'$full_name_str\'";
my %earg = (self => $self, msg => $msg,
statement => $tc_sth->{statement},
severity => 'warn');
&$GZERR(%earg)
if (defined($GZERR));
# XXX XXX XXX return undef
}
else # update the alias with position info
{
# XXX XXX XXX: what else goes here?
my $foo = {};
$foo->{p1} = $genTree->{p1};
$foo->{p2} = $genTree->{p2};
$foo->{select_col_num} = $select_col_num;
$qb_aliases->{$full_name_str} = $foo;
}
}
else # no alias
{
# derive column "header" from input txt -- the
# default header is just the text of the
# expression.
my $col_hd;
if (exists($genTree->{p1}))
{
$col_hd =
substr($treeCtx->{statement},
$genTree->{p1},
($genTree->{p2} - $genTree->{p1}) + 1
);
$col_hd =~ s/^\s*//; # trim leading spaces
}
else
{
# XXX XXX: generated col for STAR - fake it
# XXX XXX: assume have a column name
my $npa =
$genTree->{value_expression}->{column_name};
my @col_name =
_process_name_pieces(@{$npa});
$col_hd = join(".", @col_name);
}
$genTree->{tc_col_header} = $col_hd;
}
} # end col alias
}
} # end big while
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
}
# recursive function to decorate column info
#
#
sub _get_col_info # private
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
L_bigw:
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
if ($kk !~ m/^(tc_column_name)$/)
{
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
else # column name
{
my $full_name_str = undef;
if (exists($genTree->{tc_col_tablename}))
{
$full_name_str = $genTree->{tc_col_tablename};
}
my $column_name = $genTree->{tc_column_name};
my $stat_pos = [];
$stat_pos = ($genTree->{tc_column_name_stat_pos})
if (exists($genTree->{tc_column_name_stat_pos}));
# XXX XXX XXX: need to deal with table.rid...
if ($column_name =~ m/^(rid|rownum)$/i)
{
if ($column_name =~ m/^(rid)$/i)
{
$genTree->{tc_expr_type} = 'c';
}
else
{
$genTree->{tc_expr_type} = 'n';
}
# XXX XXX: need to deal with other pseudo cols like
# sysdate...
# rid and rownum are valid
next L_bigw;
}
my $foundCol = 0;
# start in current query block
my $current_qb = $treeCtx->{qb_list}->[0];
# NOTE: search backward from most recent
# (innermost) query block to earliest (outermost)
L_qb:
for (my $qb_num = $current_qb;
(defined($qb_num) && ($qb_num > 0));
$qb_num--)
{
my $qb2 = $treeCtx->{tablist}->[$qb_num]->{tables};
# if have a tablename, look there
if (defined($full_name_str))
{
next L_qb
unless (exists($qb2->{$full_name_str}));
my $h1 = $qb2->{$full_name_str}->{tc_table_colhsh};
next L_qb
unless (exists($h1->{$column_name}));
$genTree->{tc_column_num} =
$h1->{$column_name}->[0];
$genTree->{tc_expr_type} =
$h1->{$column_name}->[1];
$genTree->{tc_column_qb} = $qb_num;
$foundCol = 1;
last L_qb; # done!
}
else
{
# need to check all tables in block
keys( %{$qb2} ); # XXX XXX: need to reset
L_littlew:
while ( my ($hkk, $hvv) =
each ( %{$qb2})) # little while
{
my $h1 = $hvv->{tc_table_colhsh};
next L_littlew
unless (exists($h1->{$column_name}));
# check all tables in current query block
# for duplicate column names
if ($foundCol)
{
my $msg = "column name " .
"\'$column_name\' is ambiguous -- ";
$msg .= "tables \'" .
$genTree->{tc_col_tablename} .
"\', \'" . $hkk . "\'";
my %earg = (self => $self, msg => $msg,
statement => $tc_sth->{statement},
stat_pos => $stat_pos,
severity => 'warn');
&$GZERR(%earg)
if (defined($GZERR));
last L_qb;
}
# set the table name
$genTree->{tc_col_tablename} = $hkk;
$genTree->{tc_column_num} =
$h1->{$column_name}->[0];
$genTree->{tc_expr_type} =
$h1->{$column_name}->[1];
$genTree->{tc_column_qb} = $qb_num;
$foundCol = 1;
# last L_qb;
} # end little while
last L_qb
if ($foundCol);
}
} # end for each qb num
unless ($foundCol)
{
push @{$treeCtx->{tc_err}->{nosuch_column}},
$full_name_str;
my $msg = "column \'$column_name\' not found\n";
my %earg = (self => $self, msg => $msg,
statement => $tc_sth->{statement},
stat_pos => $stat_pos,
severity => 'warn');
&$GZERR(%earg)
if (defined($GZERR));
# return undef; # XXX XXX XXX XXX
}
} # end is col name
} # end big while
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
}
# transform standard sql relational operators to Perl-style,
# distinguishing numeric and character comparisons
my $relop_map =
{
'==' => { "n" => "==", "c" => "eq"},
'=' => { "n" => "==", "c" => "eq"},
'<>' => { "n" => "!=", "c" => "ne"},
'!=' => { "n" => "!=", "c" => "ne"},
'>' => { "n" => ">", "c" => "gt"},
'<' => { "n" => "<", "c" => "lt"},
'>=' => { "n" => ">=", "c" => "ge"},
'<=' => { "n" => "<=", "c" => "le"},
'<=>' => { "n" => "<=>", "c" => "cmp"}
};
# comp_op fixup
#
#
sub _fixup_comp_op
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# convert subtree first, then process local select list
{
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
# convert subtree first...
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
# grab the WHERE clause text
if (exists($genTree->{sc_tree}))
{
if (exists($genTree->{p1})
&& exists($genTree->{p2}))
{
my $pos1 = $genTree->{p1};
my $pos2 = $genTree->{p2};
my $sc_txt =
substr($treeCtx->{statement},
$pos1,
($pos2 - $pos1) + 1
);
$genTree->{sc_txt} = $sc_txt;
}
}
# XXX XXX XXX: Get text for update col = expression...
if (exists($genTree->{operator}))
{
if (($genTree->{operator} eq "=") &&
(exists($genTree->{p1})
&& exists($genTree->{p2})))
{
my $pos1 = $genTree->{p1};
my $pos2 = $genTree->{p2};
my $vx_txt =
substr($treeCtx->{statement},
$pos1,
($pos2 - $pos1) + 1
);
$genTree->{vx_txt} = $vx_txt;
}
}
if (exists($genTree->{comp_op}))
{
# print $genTree->{operator}, "\n";
# fixup the perl operators
if (($genTree->{comp_op} eq 'comp_perlish')
&& (3 == scalar(@{$genTree->{operands}})))
{
my $op1 =
$genTree->{operands}->[1];
$genTree->{operands}->[1] = {
tc_comp_op => $op1,
orig_comp_op => $op1
};
my $op2 =
$genTree->{operands}->[2];
# XXX XXX: op2 should be an array of
# perl regex pieces -- reassemble it.
# may need to do some work for non-standard
# quoting
my $perl_lit = join("", @{$op2});
$genTree->{operands}->[2] = {
string_literal => $perl_lit,
orig_reg_exp => $op2
};
}
L_for_ops:
for my $op_idx (0..(@{$genTree->{operands}}-1))
{
my $op1 = $genTree->{operands}->[$op_idx];
# print $op1, "\n", ref($op1), "\n";
next L_for_ops
if (ref($op1)); # ref is false for scalar non-ref
# print $op1, "\n";
my $tok_expr = '(<=>|cmp|eq|==|<>|lt|gt|le|ge|!=|<=|>=|<|>|=)';
next L_for_ops
unless ($op1 =~ m/^$tok_expr$/);
next L_for_ops
unless (exists($relop_map->{$op1}));
my $h1 = $relop_map->{$op1};
my $left_op = $genTree->{operands}->[$op_idx - 1];
my $right_op = $genTree->{operands}->[$op_idx + 1];
my $op_type = '?';
if ((ref($left_op) eq 'HASH') &&
(exists($left_op->{tc_expr_type})))
{
$op_type = $left_op->{tc_expr_type};
} # else type is char by default
# char takes precedence over number, so only test
# right side if left side was numeric
if (($op_type ne 'c') &&
(ref($right_op) eq 'HASH') &&
(exists($right_op->{tc_expr_type})))
{
$op_type = $right_op->{tc_expr_type};
}
$op_type = 'c' # only allow c or n
unless ($op_type =~ m/^(n|c)$/);
# update the operator
$genTree->{operands}->[$op_idx] = {
tc_comp_op => $h1->{$op_type},
orig_comp_op => $op1
};
} # end for
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
}
sub _find_aggregate_functions
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# convert subtree first, then process local select list
{
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
# convert subtree first...
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
if (exists($genTree->{function_name}))
{
my $fname = uc($genTree->{function_name});
if (exists($self->{aggregate_functions}->{$fname}))
{
# perform final aggregation
# need to generate stages to perform aggregate
# initialization and intermediate aggregation
$genTree->{aggregate_stage} =
"finalize";
}
else
{
if (exists($genTree->{operands}))
{
my $ops = $genTree->{operands};
if (scalar(@{$ops})
&& (exists($ops->[0]->{all_distinct})))
{
if (scalar(@{$ops->[0]->{all_distinct}}))
{
# invalid all/distinct qualifier
# for non-aggregate function
my $adq = $ops->[0]->{all_distinct}->[0];
my $msg = "invalid argument ".
"\'$adq\' for non-aggregate function \'$fname\'";
my %earg = (self => $self, msg => $msg,
statement => $tc_sth->{statement},
severity => 'warn');
push @{$treeCtx->{tc_err}->{invalid_args}}, $msg;
&$GZERR(%earg)
if (defined($GZERR));
}
}
}
}
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
} # end _find_aggregate_functions
sub _check_aggregate_functions
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc3};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
my $got_one = 0;
if (exists($genTree->{alg_op_name}))
{
$got_one = 1;
push @{$treeCtx->{tc_agg_check}}, $genTree;
}
if (exists($genTree->{aggregate_stage}))
{
my $op_node = $treeCtx->{tc_agg_check}->[-1];
my $fname = ($genTree->{function_name});
if (exists($op_node->{alg_op_name}))
{
if ($op_node->{alg_op_name} eq 'project')
{
# will need to check project to determine if all
# projected columns are aggregates or GROUPed
$op_node->{tc_has_agg} = 1;
}
# aggregates are legal in HAVING, ORDER BY,
# and illegal in WHERE clause
# XXX XXX : also illegal in JOIN conditions...
if (($op_node->{alg_op_name} eq 'filter')
&& ($op_node->{alg_filter_type} eq 'WHERE'))
{
my $msg = "illegal use of" .
" aggregate function \'$fname\' in WHERE clause";
my %earg = (self => $self, msg => $msg,
statement => $tc_sth->{statement},
severity => 'warn');
push @{$treeCtx->{tc_err}->{invalid_args}}, $msg;
&$GZERR(%earg)
if (defined($GZERR));
}
}
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
if ($got_one)
{
pop @{$treeCtx->{tc_agg_check}};
}
}
return $genTree;
} # end _check_aggregate_functions
sub GetFromWhereEtc
{
my $self = shift;
my %required = (
algebra => "no algebra !",
dict => "no dictionary !",
);
my %optional = (top_cmd => "SELECT");
my %args = (%optional,
@_);
return undef
unless (Validate(\%args, \%required));
my $algebra = $args{algebra};
my $tc4 = {}; # type check tree context for tree walker
# NOTE: we stashed the statement handle in the top of the
# algebra when we did typechecking earlier
my $tc_sth = $algebra->{tc_sth};
$tc_sth->{tc4} = $tc4;
# NOTE: clear out the "statement handle" since it's not part of
# the algebra and we don't want to walk it
$algebra->{tc_sth} = undef;
# local tree walk state
$tc4->{top_qb_num} = 1; # top query block number is 1
if ($args{top_cmd} =~ m/INSERT/i)
{
# NOTE: "top" query block number 2 for INSERT...SELECT
# (use qb 1 to resolve insert table/column info)
$tc4->{top_qb_num} = 2;
}
$tc4->{qb_list} = []; # build an arr starting with current query block num
greet $tc4;
$tc4->{index_keys} = [] # only build index keys
if ($tc_sth->{tc3}->{AndPurity}); # if pure AND search condition
$algebra = $self->_get_from_where($algebra, $args{dict}, $tc_sth);
my $from = $tc4->{from};
my $sel_list = $tc4->{select_list};
my $where = $tc4->{where};
# XXX XXX XXX: need to localize AndPurity per WHERE clause/search cond
my $and_purity = $tc_sth->{tc3}->{AndPurity};
$tc4->{where}->[0]->{sc_and_purity} = $and_purity;
if ($and_purity)
{
$tc4->{where}->[0]->{sc_index_keys} = $tc4->{index_keys};
}
# XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX
# NOTE: replace the "statement handle"
$algebra->{tc_sth} = $tc_sth;
return ($algebra, $from, $sel_list, $where);
}
# transition from old parser to new...
#
sub _get_from_where
{
# whoami;
# NOTE: get the current subroutine name so it is easier
# to call recursively
my $subname = (caller(0))[3];
my $self = shift;
# generic tree of hashes/arrays
my ($genTree, $dict, $tc_sth) = @_;
my $treeCtx = $tc_sth->{tc4};
# recursively convert all elements of array
if (ref($genTree) eq 'ARRAY')
{
my $maxi = scalar(@{$genTree});
$maxi--;
for my $i (0..$maxi)
{
$genTree->[$i] = $self->$subname($genTree->[$i], $dict, $tc_sth);
}
}
if (ref($genTree) eq 'HASH')
{
keys( %{$genTree} ); # XXX XXX: need to reset expression!!
# recursively convert all elements of hash
my $qb_setup = 0; # TRUE if top hash of query block
if (exists($genTree->{query_block}))
{
$qb_setup = 1;
# keep track of current query block number
my $current_qb = $genTree->{query_block};
# push on the front
unshift @{$treeCtx->{qb_list}}, $current_qb;
}
if (scalar(@{$treeCtx->{qb_list}}))
{
my $current_qb = $treeCtx->{qb_list}->[0];
if ($current_qb == $treeCtx->{top_qb_num})
{
if (exists($genTree->{from_clause}))
{
$treeCtx->{from} = $genTree->{from_clause};
}
if (exists($genTree->{select_list}))
{
$treeCtx->{select_list} = $genTree->{select_list};
}
# distinguish WHERE and HAVING clauses...
if (exists($genTree->{search_cond}) &&
(exists($genTree->{alg_op_name}) &&
($genTree->{alg_op_name} eq 'filter')) &&
(exists($genTree->{alg_filter_type}) &&
($genTree->{alg_filter_type} eq 'WHERE')))
{
$treeCtx->{where} = $genTree->{search_cond};
}
}
}
while ( my ($kk, $vv) = each ( %{$genTree})) # big while
{
if (($kk =~ m/tc_index_key/) &&
exists($treeCtx->{index_keys}))
{
# build big list of index keys
push @{$treeCtx->{index_keys}}, @{$vv};
}
# convert subtree first...
$genTree->{$kk} = $self->$subname($vv, $dict, $tc_sth);
}
if ($qb_setup)
{
# pop from the front
shift @{$treeCtx->{qb_list}};
}
}
return $genTree;
}
END { } # module clean-up code here (global destructor)
## YOUR CODE GOES HERE
1; # don't forget to return a true value from the file
__END__
# Below is stub documentation for your module. You better edit it!
=head1 NAME
Genezzo::Plan::TypeCheck - Perform checks on relational algebra representation
=head1 SYNOPSIS
use Genezzo::Plan::TypeCheck;
=head1 DESCRIPTION
Perform type-checking/analysis on relational algebra.
=head1 ARGUMENTS
=head1 FUNCTIONS
=over 4
=item TypeCheck
Perform typechecking on a relational algebra, and add type information
to the tree
=item TableCheck
Check table references in the relational algebra, and provide type information.
=item ColumnCheck
Resolve each column reference in the relational algebra back to some
base table.
=back
=head2 EXPORT
=over 4
=back
=head1 LIMITATIONS
=head1 TODO
=over 4
=item need to generate stages to perform aggregate initialization and intermediate aggregation
=item check for aggregates in WHERE clause
=item check for GROUPing/aggregates
=item check for final select list columns vs all projected columns in all clauses
=item check args for all functions
=item check for function existance in GenDBI and main namespaces
=item update pod
=item need to handle FROM clause subqueries -- some tricky column type issues. check for duplicate aliases/type mismatch in _FROM_subq_star_fixup ?
=item check bool_op - AND purity if no OR's.
=item check relational operator (comp_op, relop)
=item handle ddl/dml (create, insert, delete etc with embedded queries) by
checking for query_block info -- look for hash with 'query_block'
before attempting table/col resolution. Need special type checking
for these functions.
=item refactor to common TreeWalker
=item handle all pseudo cols
=item most value expression stuff needs to migrate to XEval
=back
=head1 AUTHOR
Jeffrey I. Cohen, jcohen@genezzo.com
=head1 SEE ALSO
L<perl(1)>.
Copyright (c) 2005,2006 Jeffrey I Cohen. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
Address bug reports and comments to: jcohen@genezzo.com
For more information, please visit the Genezzo homepage
at L<http://www.genezzo.com>
=cut