r889 - in packages/libsql-statement-perl/trunk: . debian lib/SQL
lib/SQL/Dialects lib/SQL/Statement t
Gunnar Wolf
gwolf at costa.debian.org
Sun Jul 17 08:09:10 UTC 2005
Author: gwolf
Date: 2005-04-05 22:52:12 +0000 (Tue, 05 Apr 2005)
New Revision: 889
Added:
packages/libsql-statement-perl/trunk/lib/SQL/Statement/Functions.pm
packages/libsql-statement-perl/trunk/lib/SQL/Statement/RAM.pm
packages/libsql-statement-perl/trunk/lib/SQL/Statement/Util.pm
packages/libsql-statement-perl/trunk/t/
Removed:
packages/libsql-statement-perl/trunk/test.pl
Modified:
packages/libsql-statement-perl/trunk/Changes
packages/libsql-statement-perl/trunk/MANIFEST
packages/libsql-statement-perl/trunk/Makefile.PL
packages/libsql-statement-perl/trunk/README
packages/libsql-statement-perl/trunk/debian/changelog
packages/libsql-statement-perl/trunk/debian/watch
packages/libsql-statement-perl/trunk/lib/SQL/Dialects/ANSI.pm
packages/libsql-statement-perl/trunk/lib/SQL/Dialects/AnyData.pm
packages/libsql-statement-perl/trunk/lib/SQL/Dialects/CSV.pm
packages/libsql-statement-perl/trunk/lib/SQL/Eval.pm
packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm
packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm
packages/libsql-statement-perl/trunk/lib/SQL/Statement/GetInfo.pm
packages/libsql-statement-perl/trunk/t/01prepare.t
packages/libsql-statement-perl/trunk/t/02execute.t
packages/libsql-statement-perl/trunk/t/03join.t
packages/libsql-statement-perl/trunk/t/04names.t
packages/libsql-statement-perl/trunk/t/05create.pl
Log:
Upstream version 1.11
Modified: packages/libsql-statement-perl/trunk/Changes
===================================================================
--- packages/libsql-statement-perl/trunk/Changes 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/Changes 2005-04-05 22:52:12 UTC (rev 889)
@@ -1,140 +1,221 @@
-Changes log for Perl extension SQL::Statement
-
-Version 1.09, released 22 April, 2004
--------------------------------------
- * fixed parens parsing bug reported by Dan Wright, thanks!
-
-
-Version 1.08, released 20 April, 2004
--------------------------------------
-
- * fixed bug in JOIN handling introduced in 1.06
-
-
-Version 1.07, released 20 April, 2004
--------------------------------------
-
- * fixed infinite recursion bug with empty IN() predicate
- thanks chromatic, for the patch
-
- * fixed case issues with table aliases in joins
- thanks chromatic, for bug report
-
-Version 1.06, released 18 April, 2004
--------------------------------------
-
- * column and table name hashes now default to case sensitive
-
- * where() method now supported as per the docs
-
-
-Version 1.005, released 26 October, 2002
-------------------------------------------
-
- * added support for MySQL-like "DROP TABLE IF EXISTS"
-
- * fixed bug in dotted column names e.g. tableA.colB
-
- * fixed bug in MAX and MIN (thanks Michael Kovacs,
- mkovacs at turing.une.edu.au)
-
- * fixed bug in ORDER BY (when col names not in SELECT list)
- Thanks Janet Goldstein <jgold at cidr.jhmi.edu>
-
-
-Version 1.004, released 13 March, 2002
-------------------------------------------
-
- * added support for delimited identifiers (inside double quotes);
- these are case sensitive and can contain spaces and other
- special chars
-
- * added support for two forms of escaping single quotes inside
- quoted values: 'O\'Brien' or 'O''Brien'
-
- * added support for both C-Style and SQL-Style double-hypen
- comments, e.g. /* comment */ or -- comment
-
- * added GetInfo.pm for use with $dbh->get_info()
-
- * updated the readme file
-
- * fixed bug in update that refers to its own columns
- (e.g. SET num = num + 2)
-
- * fixed bug in MIN and MAX when used with strings
- Thanks Dean Kopesky <dean.kopesky at reuters.com>
-
-Version 1.003, released 01 March, 2002
-------------------------------------------
-
- * identifiers (names of columns, tables, and table name
- aliases) are now all case insensitive as required by the SQL
- standard. all older versions including the XS versions used
- case sensitive column names
-
- * added numerous examples to test.pl
-
- * improved and/or fixed bugs in:
-
- * placeholder support
- Thanks Achim Grolms <Achim.Grolms at fujitsu-siemens.com>
-
- * ORDER BY clause
- Thanks Jan Stocker <jstocker at tzi.de>
-
- * LIKE/CLIKE/RLIKE/IN predicates
- Thanks Udo Beckmann <Udo.Beckmann at trinkaus.de>
-
- * table name aliases in explicit joins
-
-Version 1.002, released 5 February, 2002
-----------------------------------------
-
- * added backwards compatiblity: both SQL::Statement and
- SQL::Parser now work in perl version 5.004 and above.
-
- * changed defaults for DBD::CSV so it now accepts new SQL
- without adding extra flags to scripts
-
- * added support for SQL comments
-
- * added support for temporary tables and on commit clauses in
- CREATE statements and drop behaviour flags in DROP statements
- (SQL::Parser only, not supported by SQL::Statement)
-
- * fixed bugs in qualified column names (e.g. tableA.*), and in
- joins using ON or WHERE
-
-Version 1.001, released January 17,2002
----------------------------------------
-
-Fixed bug in UPDATE that caused the new value to be a hash
-rather than a scalar.
-
-Version 1.0, released January 15, 2002
---------------------------------------
-
-This is the first CPAN release of the pure perl version of the
-module. It was previously released in an XS version by Jochen
-Wiedman who has turned over maintenance of it to me.
-
-The new Pure Perl version of SQL::Statement supports everything
-supported by the XS version and, additionally, at least partial
-support for the following features that are not supported at all
-by the XS version:
-
- * Explicit and implicit joins
- * Table name aliases
- * Set functions
- * String functions
- * String concatenation
- * Numeric expressions
- * IN predicate
- * BETWEEN predicate
- * Alphabetic comparison in WHERE clauses
- * Ordering of text that looks like a number
- * Verbose error messages for both Parsing and Execution errors
-
-
-
+Changes log for Perl extension SQL::Statement
+
+
+Version 1.10, released 27 March, 2005
+----------------------------------------
+ * added support for CREATE TABLE AS SELECT ... and CREATE TABLE AS IMPORT()
+
+ * added support for in-memory tables and heterogeneous operations,
+ see the SQL::Parser docs
+
+ * added many new built-in functions see SQL::Statement::Functions.pm
+
+ * added support for user-defined functions, see SQL::Statement::Functions.pm
+
+ * added support for column name aliases
+ thanks for patch, Robert Rothenberg
+
+ * added support for comparison to empty string (e.g. WHERE col1='')
+ currently returns the same as WHERE col1 IS NULL
+ thanks for patch, cpanATgoess.org
+
+ * fixed bug in S::P::clean_sql() newline-handling,
+ thanks for patch Steffen G., steffenATkonzeptloses.de
+
+ * fixed bug in SQL::Parser::feature()
+ thanks for patch, chromatic
+
+ * the word "INTO" is now optional in "INSERT INTO tblname ..."
+ * the word "FROM" is now optional in "DELETE FROM tblname ..."
+ thanks for suggestion, gipeol at sci.kun.nl
+
+ * optimized portions of eval_where, process_predicate, and is_matched
+ HUGE thanks Dan Wright and Dean Arnold for patches
+
+ * HUGE thanks to Dean Arnold for all the following which should clean up
+ a number of bugs in parentheses parsing and in the predicates IN and
+ BETWEEN as well as speed things up considerably
+
+ SQL::Parser changes:
+ - removed recursion from get_in(), get_btwn()
+ - fixed paren scan and argument separator scan in get_in()
+ - optimized get_in/get_btwn code
+ - made get_in/get_btwn OO methods to support
+ being overridden by subclasses
+ - added transform_syntax() abstract method
+ to permit subclasses to add their own
+ syntax extensions
+ - rewrite of parens_search() to fixed predicate
+ paren processing, remove recursion, and optimize
+ code
+ - rewrite of non_parens_search() to fixed predicate
+ paren processing and optimize code
+ - rewrite of PREDICATE to optimize code; moved
+ operator regex construction to dialect
+ initialization
+ - change undo_string_funcs(), undo_math_funcs(),
+ nongroup_numeric(), nongroup_string()
+ to remove scoped recursion
+ - fixed nongroup_numeric() for case insensitive
+ operator match
+ - fixed nongroup_string, undo_string_funcs() to
+ include user defined funcs
+ - fixed ROW_VALUE's scan for user defined function
+ argument separator scan
+
+ * fixed function detection regex in SQL::Parser::ROW_VALUE
+ to accomodate arbitrary spacing
+
+ * fixed SQL::Parser::SELECT_LIST()/extract_column_list()
+ to support concat operator '||' expressions
+
+ * added following functions to SQL::Statement::Functions:
+ - COALESCE
+ - NVL (same as COALESCE)
+ - DECODE (same as Oracle DECODE)
+ - CONCAT
+ - REPLACE/SUBSTITUTE
+
+ * fixed/adapted SQL::Statement::get_row_value(),
+ SQL::Statement::SELECT(), for join'ed
+ resultsets
+
+
+Version 1.09, released 22 April, 2004
+-------------------------------------
+ * fixed parens parsing bug reported by Dan Wright, thanks!
+
+
+Version 1.08, released 20 April, 2004
+-------------------------------------
+
+ * fixed bug in JOIN handling introduced in 1.06
+
+
+Version 1.07, released 20 April, 2004
+-------------------------------------
+
+ * fixed infinite recursion bug with empty IN() predicate
+ thanks chromatic, for the patch
+
+ * fixed case issues with table aliases in joins
+ thanks chromatic, for bug report
+
+Version 1.06, released 18 April, 2004
+-------------------------------------
+
+ * column and table name hashes now default to case sensitive
+
+ * where() method now supported as per the docs
+
+
+Version 1.005, released 26 October, 2002
+------------------------------------------
+
+ * added support for MySQL-like "DROP TABLE IF EXISTS"
+
+ * fixed bug in dotted column names e.g. tableA.colB
+
+ * fixed bug in MAX and MIN (thanks Michael Kovacs,
+ mkovacs at turing.une.edu.au)
+
+ * fixed bug in ORDER BY (when col names not in SELECT list)
+ Thanks Janet Goldstein <jgold at cidr.jhmi.edu>
+
+
+Version 1.004, released 13 March, 2002
+------------------------------------------
+
+ * added support for delimited identifiers (inside double quotes);
+ these are case sensitive and can contain spaces and other
+ special chars
+
+ * added support for two forms of escaping single quotes inside
+ quoted values: 'O\'Brien' or 'O''Brien'
+
+ * added support for both C-Style and SQL-Style double-hypen
+ comments, e.g. /* comment */ or -- comment
+
+ * added GetInfo.pm for use with $dbh->get_info()
+
+ * updated the readme file
+
+ * fixed bug in update that refers to its own columns
+ (e.g. SET num = num + 2)
+
+ * fixed bug in MIN and MAX when used with strings
+ Thanks Dean Kopesky <dean.kopesky at reuters.com>
+
+Version 1.003, released 01 March, 2002
+------------------------------------------
+
+ * identifiers (names of columns, tables, and table name
+ aliases) are now all case insensitive as required by the SQL
+ standard. all older versions including the XS versions used
+ case sensitive column names
+
+ * added numerous examples to test.pl
+
+ * improved and/or fixed bugs in:
+
+ * placeholder support
+ Thanks Achim Grolms <Achim.Grolms at fujitsu-siemens.com>
+
+ * ORDER BY clause
+ Thanks Jan Stocker <jstocker at tzi.de>
+
+ * LIKE/CLIKE/RLIKE/IN predicates
+ Thanks Udo Beckmann <Udo.Beckmann at trinkaus.de>
+
+ * table name aliases in explicit joins
+
+Version 1.002, released 5 February, 2002
+----------------------------------------
+
+ * added backwards compatiblity: both SQL::Statement and
+ SQL::Parser now work in perl version 5.004 and above.
+
+ * changed defaults for DBD::CSV so it now accepts new SQL
+ without adding extra flags to scripts
+
+ * added support for SQL comments
+
+ * added support for temporary tables and on commit clauses in
+ CREATE statements and drop behaviour flags in DROP statements
+ (SQL::Parser only, not supported by SQL::Statement)
+
+ * fixed bugs in qualified column names (e.g. tableA.*), and in
+ joins using ON or WHERE
+
+Version 1.001, released January 17,2002
+---------------------------------------
+
+Fixed bug in UPDATE that caused the new value to be a hash
+rather than a scalar.
+
+Version 1.0, released January 15, 2002
+--------------------------------------
+
+This is the first CPAN release of the pure perl version of the
+module. It was previously released in an XS version by Jochen
+Wiedman who has turned over maintenance of it to me.
+
+The new Pure Perl version of SQL::Statement supports everything
+supported by the XS version and, additionally, at least partial
+support for the following features that are not supported at all
+by the XS version:
+
+ * Explicit and implicit joins
+ * Table name aliases
+ * Set functions
+ * String functions
+ * String concatenation
+ * Numeric expressions
+ * IN predicate
+ * BETWEEN predicate
+ * Alphabetic comparison in WHERE clauses
+ * Ordering of text that looks like a number
+ * Verbose error messages for both Parsing and Execution errors
+
+
+
Property changes on: packages/libsql-statement-perl/trunk/Changes
___________________________________________________________________
Name: svn:executable
+ *
Modified: packages/libsql-statement-perl/trunk/MANIFEST
===================================================================
--- packages/libsql-statement-perl/trunk/MANIFEST 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/MANIFEST 2005-04-05 22:52:12 UTC (rev 889)
@@ -8,5 +8,9 @@
lib/SQL/Dialects/ANSI.pm
lib/SQL/Dialects/AnyData.pm
lib/SQL/Dialects/CSV.pm
+lib/SQL/Statement/Functions.pm
lib/SQL/Statement/GetInfo.pm
-test.pl
+lib/SQL/Statement/RAM.pm
+t/01prepare.t
+t/02execute.t
+t/03join.t
Property changes on: packages/libsql-statement-perl/trunk/MANIFEST
___________________________________________________________________
Name: svn:executable
+ *
Property changes on: packages/libsql-statement-perl/trunk/Makefile.PL
___________________________________________________________________
Name: svn:executable
+ *
Modified: packages/libsql-statement-perl/trunk/README
===================================================================
--- packages/libsql-statement-perl/trunk/README 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/README 2005-04-05 22:52:12 UTC (rev 889)
@@ -41,7 +41,7 @@
perl
DBI
- DBD::CSV or DBD::AnyData
+ DBD::CSV or DBD::AnyData or other DBDs that subclass SQL::Statement
WHERE DO I FIND OUT MORE?
@@ -51,13 +51,12 @@
moduels, there are extensive help documents included with the
modules. Use perldoc or pod2html or simply read the POD section
of the .pm files. For further questions, write to the
-comp.lang.perl.modules newsgroup or the dbi-users at perl.org
-listserv.
+the dbi-users at perl.org listserv or try www.perlmonks.org.
WHO DUNNIT?
The original XS versions of the modules were written by Jochen
Wiedmann. The current, pure perl versions were rewritten
(mostly from the ground up) by Jeff Zucker
-<jeff at vpservices.com>. Both versions are currently maintained
+<jzuckerATcpan.org>. Both versions are currently maintained
by Jeff.
Property changes on: packages/libsql-statement-perl/trunk/README
___________________________________________________________________
Name: svn:executable
+ *
Modified: packages/libsql-statement-perl/trunk/debian/changelog
===================================================================
--- packages/libsql-statement-perl/trunk/debian/changelog 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/debian/changelog 2005-04-05 22:52:12 UTC (rev 889)
@@ -1,3 +1,9 @@
+libsql-statement-perl (1.11-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Gunnar Wolf <gwolf at debian.org> Tue, 5 Apr 2005 17:51:07 -0500
+
libsql-statement-perl (1.09-1) unstable; urgency=low
* New upstream release (Closes: #165723, #178052)
Modified: packages/libsql-statement-perl/trunk/debian/watch
===================================================================
--- packages/libsql-statement-perl/trunk/debian/watch 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/debian/watch 2005-04-05 22:52:12 UTC (rev 889)
@@ -3,4 +3,4 @@
# to check for upstream updates and more.
# Site Directory Pattern Version Script
version=2
-http://www.cpan.org/modules/by-module/SQL-Statement-(\d.*)\.tar\.gz debian uupdate
+http://www.cpan.org/modules/by-module/SQL/SQL-Statement-(\d.*)\.tar\.gz debian uupdate
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Dialects/ANSI.pm
___________________________________________________________________
Name: svn:executable
+ *
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Dialects/AnyData.pm
___________________________________________________________________
Name: svn:executable
+ *
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Dialects/CSV.pm
___________________________________________________________________
Name: svn:executable
+ *
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Eval.pm
___________________________________________________________________
Name: svn:executable
+ *
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm 2005-04-05 22:52:12 UTC (rev 889)
@@ -1,2404 +1,3254 @@
-######################################################################
-package SQL::Parser;
-######################################################################
-#
-# This module is copyright (c), 2001,2002 by Jeff Zucker.
-# All rights resered.
-#
-# It may be freely distributed under the same terms as Perl itself.
-# See below for help and copyright information (search for SYNOPSIS).
-#
-######################################################################
-
-use strict;
-use warnings;
-use vars qw($VERSION);
-use constant FUNCTION_NAMES => join '|', qw(
- TRIM SUBSTRING UPPER LOWER TO_CHAR
-);
-
-$VERSION = '1.09';
-
-BEGIN { if( $ENV{SQL_USER_DEFS} ) { require SQL::UserDefs; } }
-
-
-#############################
-# PUBLIC METHODS
-#############################
-
-sub new {
- my $class = shift;
- my $dialect = shift || 'ANSI';
- $dialect = 'ANSI' if uc $dialect eq 'ANSI';
- $dialect = 'AnyData' if uc $dialect eq 'ANYDATA' or uc $dialect eq 'CSV';
-# $dialect = 'CSV' if uc $dialect eq 'CSV';
- if ($dialect eq 'SQL::Eval') {
- $dialect = 'AnyData';
- }
- my $flags = shift || {};
- $flags->{"dialect"} = $dialect;
- $flags->{"PrintError"} = 1 unless defined $flags->{"PrintError"};
- my $self = bless_me($class,$flags);
- $self->dialect( $self->{"dialect"} );
- $self->set_feature_flags($self->{"select"},$self->{"create"});
- return bless $self,$class;
-}
-
-sub parse {
- my $self = shift;
- my $sql = shift;
-#printf "<%s>", $self->{dialect_set};
- $self->dialect( $self->{"dialect"} ) unless $self->{"dialect_set"};
- $sql =~ s/^\s+//;
- $sql =~ s/\s+$//;
- $self->{"struct"} = {};
- $self->{"tmp"} = {};
- $self->{"original_string"} = $sql;
- $self->{struct}->{"original_string"} = $sql;
-
- ################################################################
- #
- # COMMENTS
-
- # C-STYLE
- #
- my $comment_re = $self->{"comment_re"} || '(\/\*.*?\*\/)';
- $self->{"comment_re"} = $comment_re;
- my $starts_with_comment;
- if ($sql =~ /^\s*$comment_re(.*)$/s) {
- $self->{"comment"} = $1;
- $sql = $2;
- $starts_with_comment=1;
- }
- # SQL STYLE
- #
- if ($sql =~ /^\s*--(.*)(\n|$)/) {
- $self->{"comment"} = $1;
- return 1;
- }
- ################################################################
-
- $sql = $self->clean_sql($sql);
- my($com) = $sql =~ /^\s*(\S+)\s+/s ;
- if (!$com) {
- return 1 if $starts_with_comment;
- return $self->do_err("Incomplete statement!");
- }
- $com = uc $com;
- if ($self->{"opts"}->{"valid_commands"}->{$com}) {
- #print "<$sql>\n";
- my $rv = $self->$com($sql);
- delete $self->{"struct"}->{"literals"};
-# return $self->do_err("No table names found!")
-# unless $self->{"struct"}->{"table_names"};
- return $self->do_err("No command found!")
- unless $self->{"struct"}->{"command"};
- if ( $self->{"struct"}->{join}
- and scalar keys %{$self->{"struct"}->{join}}==0
- ) {
- delete $self->{"struct"}->{join};
- }
- $self->replace_quoted_ids();
-#print "<@{$self->{struct}->{table_names}}>";
- for (@{$self->{struct}->{table_names}}) {
- push @{$self->{struct}->{org_table_names}},$_;
- }
-#$self->{struct}->{org_table_names} = $self->{struct}->{table_names};
-my @uTables = map {uc $_ } @{$self->{struct}->{table_names}};
-$self->{struct}->{table_names} = \@uTables unless $com eq 'CREATE';
-#print "[",@{$self->{struct}->{column_names}},"]\n" if $self->{struct}->{column_names} and $com eq 'SELECT';
- if ($self->{struct}->{column_names}) {
- for (@{$self->{struct}->{column_names}}) {
- push @{$self->{struct}->{org_col_names}},
- $self->{struct}->{ORG_NAME}->{uc $_};
- }
- }
-$self->{struct}->{join}->{table_order}
- = $self->{struct}->{table_names}
- if $self->{struct}->{join}->{table_order}
- and scalar(@{$self->{struct}->{join}->{table_order}}) == 0;
-@{$self->{struct}->{join}->{keycols}}
- = map {uc $_ } @{$self->{struct}->{join}->{keycols}}
- if $self->{struct}->{join}->{keycols};
-@{$self->{struct}->{join}->{shared_cols}}
- = map {uc $_ } @{$self->{struct}->{join}->{shared_cols}}
- if $self->{struct}->{join}->{shared_cols};
-my @uCols = map {uc $_ } @{$self->{struct}->{column_names}};
-$self->{struct}->{column_names} = \@uCols unless $com eq 'CREATE';
- if ($self->{original_string} =~ /Y\.\*/) {
-#use mylibs; zwarn $self; exit;
- }
- if ($com eq 'SELECT') {
-#use Data::Dumper;
-#print Dumper $self->{struct}->{join};
-#exit;
- }
- delete $self->{struct}->{join}
- if $self->{struct}->{join}
- and scalar keys %{$self->{struct}->{join}}==0;
- return $rv;
- }
- else {
- $self->{struct}={};
- if ($ENV{SQL_USER_DEFS}) {
- return SQL::UserDefs::user_parse($self,$sql);
- }
- return $self->do_err("Command '$com' not recognized or not supported!");
- }
-}
-
-sub replace_quoted_ids {
- my $self = shift;
- my $id = shift;
- return $id unless $self->{struct}->{quoted_ids};
- if ($id) {
- if ($id =~ /^\?QI(\d+)\?$/) {
- return '"'.$self->{struct}->{quoted_ids}->[$1].'"';
- }
- else {
- return $id;
- }
- }
- my @tables = @{$self->{struct}->{table_names}};
- for my $t(@tables) {
- if ($t =~ /^\?QI(.+)\?$/ ) {
- $t = '"'.$self->{struct}->{quoted_ids}->[$1].'"';
-# $t = $self->{struct}->{quoted_ids}->[$1];
- }
- }
- $self->{struct}->{table_names} = \@tables;
- delete $self->{struct}->{quoted_ids};
-}
-
-sub structure { shift->{"struct"} }
-sub command { my $x = shift->{"struct"}->{command} || '' }
-
-sub feature {
- my($self,$opt_class,$opt_name,$opt_value) = @_;
- if (defined $opt_value) {
- if ( $opt_class eq 'select' ) {
- $self->set_feature_flags( {"join"=>$opt_value} );
- }
- elsif ( $opt_class eq 'create' ) {
- $self->set_feature_flags( undef, {$opt_name=>$opt_value} );
- }
- else {
- $self->{$opt_class}->{$opt_name} = $opt_value;
- }
- }
- else {
- return $self->{"opts"}->{$opt_class}->{$opt_name};
- }
-}
-
-sub errstr { shift->{"struct"}->{"errstr"} }
-
-sub list {
- my $self = shift;
- my $com = uc shift;
- return () if $com !~ /COMMANDS|RESERVED|TYPES|OPS|OPTIONS|DIALECTS/i;
- $com = 'valid_commands' if $com eq 'COMMANDS';
- $com = 'valid_comparison_operators' if $com eq 'OPS';
- $com = 'valid_data_types' if $com eq 'TYPES';
- $com = 'valid_options' if $com eq 'OPTIONS';
- $com = 'reserved_words' if $com eq 'RESERVED';
- $self->dialect( $self->{"dialect"} ) unless $self->{"dialect_set"};
-
- return sort keys %{ $self->{"opts"}->{$com} } unless $com eq 'DIALECTS';
- my $dDir = "SQL/Dialects";
- my @dialects;
- for my $dir(@INC) {
- local *D;
-
- if ( opendir(D,"$dir/$dDir") ) {
- @dialects = grep /.*\.pm$/, readdir(D);
- last;
- }
- }
- @dialects = map { s/\.pm$//; $_} @dialects;
- return @dialects;
-}
-
-sub dialect {
- my($self,$dialect) = @_;
- return $self->{"dialect"} unless $dialect;
- return $self->{"dialect"} if $self->{dialect_set};
- $self->{"opts"} = {};
- my $mod = "SQL/Dialects/$dialect.pm";
- undef $@;
- eval {
- require "$mod";
- };
- return $self->do_err($@) if $@;
- $mod =~ s/\.pm//;
- $mod =~ s"/"::"g;
- my @data = split /\n/, $mod->get_config;
- my $feature;
- for (@data) {
- chomp;
- s/^\s+//;
- s/\s+$//;
- next unless $_;
- if (/^\[(.*)\]$/i) {
- $feature = lc $1;
- $feature =~ s/\s+/_/g;
- next;
- }
- my $newopt = uc $_;
- $newopt =~ s/\s+/ /g;
- $self->{"opts"}->{$feature}->{$newopt} = 1;
- }
- $self->{"dialect"} = $dialect;
- $self->{"dialect_set"}++;
-}
-
-##################################################################
-# SQL COMMANDS
-##################################################################
-
-####################################################
-# DROP TABLE <table_name>
-####################################################
-sub DROP {
- my $self = shift;
- my $stmt = shift;
- my $table_name;
- $self->{"struct"}->{"command"} = 'DROP';
- if ($stmt =~ /^\s*DROP\s+TABLE\s+IF\s+EXISTS\s+(.*)$/si ) {
- $stmt = "DROP TABLE $1";
- $self->{"struct"}->{ignore_missing_table}=1;
- }
- if ($stmt =~ /^\s*DROP\s+(\S+)\s+(.+)$/si ) {
- my $com2 = $1 || '';
- $table_name = $2;
- if ($com2 !~ /^TABLE$/i) {
- return $self->do_err(
- "The command 'DROP $com2' is not recognized or not supported!"
- );
- }
- $table_name =~ s/^\s+//;
- $table_name =~ s/\s+$//;
- if ( $table_name =~ /(\S+) (RESTRICT|CASCADE)/i) {
- $table_name = $1;
- $self->{"struct"}->{"drop_behavior"} = uc $2;
- }
- }
- else {
- return $self->do_err( "Incomplete DROP statement!" );
-
- }
- return undef unless $self->TABLE_NAME($table_name);
- $table_name = $self->replace_quoted_ids($table_name);
- $self->{"tmp"}->{"is_table_name"} = {$table_name => 1};
- $self->{"struct"}->{"table_names"} = [$table_name];
- return 1;
-}
-
-####################################################
-# DELETE FROM <table_name> WHERE <search_condition>
-####################################################
-sub DELETE {
- my($self,$str) = @_;
- $self->{"struct"}->{"command"} = 'DELETE';
- my($table_name,$where_clause) = $str =~
- /^DELETE FROM (\S+)(.*)$/i;
- return $self->do_err(
- 'Incomplete DELETE statement!'
- ) if !$table_name;
- return undef unless $self->TABLE_NAME($table_name);
- $self->{"tmp"}->{"is_table_name"} = {$table_name => 1};
- $self->{"struct"}->{"table_names"} = [$table_name];
- $self->{"struct"}->{"column_names"} = ['*'];
- $where_clause =~ s/^\s+//;
- $where_clause =~ s/\s+$//;
- if ($where_clause) {
- $where_clause =~ s/^WHERE\s*(.*)$/$1/i;
- return undef unless $self->SEARCH_CONDITION($where_clause);
- }
- return 1;
-}
-
-##############################################################
-# SELECT
-##############################################################
-# SELECT [<set_quantifier>] <select_list>
-# | <set_function_specification>
-# FROM <from_clause>
-# [WHERE <search_condition>]
-# [ORDER BY <order_by_clause>]
-# [LIMIT <limit_clause>]
-##############################################################
-
-sub SELECT {
- my($self,$str) = @_;
- $self->{"struct"}->{"command"} = 'SELECT';
- my($from_clause,$where_clause,$order_clause,$limit_clause);
- $str =~ s/^SELECT (.+)$/$1/i;
- if ( $str =~ s/^(.+) LIMIT (.+)$/$1/i ) { $limit_clause = $2; }
- if ( $str =~ s/^(.+) ORDER BY (.+)$/$1/i ) { $order_clause = $2; }
- if ( $str =~ s/^(.+?) WHERE (.+)$/$1/i ) { $where_clause = $2; }
- if ( $str =~ s/^(.+?) FROM (.+)$/$1/i ) { $from_clause = $2; }
- else {
- return $self->do_err("Couldn't find FROM clause in SELECT!");
- }
- return undef unless $self->FROM_CLAUSE($from_clause);
- return undef unless $self->SELECT_CLAUSE($str);
- if ($where_clause) {
- return undef unless $self->SEARCH_CONDITION($where_clause);
- }
- if ($order_clause) {
- return undef unless $self->SORT_SPEC_LIST($order_clause);
- }
- if ($limit_clause) {
- return undef unless $self->LIMIT_CLAUSE($limit_clause);
- }
- if ( ( $self->{"struct"}->{join}->{"clause"}
- and $self->{"struct"}->{join}->{"clause"} eq 'ON'
- )
- or ( $self->{"struct"}->{"multiple_tables"}
-###new
- and !(scalar keys %{$self->{"struct"}->{join}})
-# and !$self->{"struct"}->{join}
-###
- ) ) {
- return undef unless $self->IMPLICIT_JOIN();
- }
- return 1;
-}
-
-sub IMPLICIT_JOIN {
- my $self = shift;
- delete $self->{"struct"}->{"multiple_tables"};
- if ( !$self->{"struct"}->{join}->{"clause"}
- or $self->{"struct"}->{join}->{"clause"} ne 'ON'
- ) {
- $self->{"struct"}->{join}->{"type"} = 'INNER';
- $self->{"struct"}->{join}->{"clause"} = 'IMPLICIT';
- }
- if (defined $self->{"struct"}->{"keycols"} ) {
- my @keys;
- my @keys2 = @keys = @{ $self->{"struct"}->{"keycols"} };
- $self->{"struct"}->{join}->{"table_order"} = $self->order_joins(\@keys2);
- @{$self->{"struct"}->{join}->{"keycols"}} = @keys;
- delete $self->{"struct"}->{"keycols"};
- }
- else {
- return $self->do_err("No equijoin condition in WHERE or ON clause");
- }
- return 1;
-}
-
-sub EXPLICIT_JOIN {
- my $self = shift;
- my $remainder = shift;
- return undef unless $remainder;
- my($tableA,$tableB,$keycols,$jtype,$natural);
- if ($remainder =~ /^(.+?) (NATURAL|INNER|LEFT|RIGHT|FULL|UNION|JOIN)(.+)$/s){
- $tableA = $1;
- $remainder = $2.$3;
- }
- else {
- ($tableA,$remainder) = $remainder =~ /^(\S+) (.*)/;
- }
- if ( $remainder =~ /^NATURAL (.+)/) {
- $self->{"struct"}->{join}->{"clause"} = 'NATURAL';
- $natural++;
- $remainder = $1;
- }
- if ( $remainder =~
- /^(INNER|LEFT|RIGHT|FULL|UNION) JOIN (.+)/
- ) {
- $jtype = $self->{"struct"}->{join}->{"clause"} = $1;
- $remainder = $2;
- $jtype = "$jtype OUTER" if $jtype !~ /INNER|UNION/;
- }
- if ( $remainder =~
- /^(LEFT|RIGHT|FULL) OUTER JOIN (.+)/
- ) {
- $jtype = $self->{"struct"}->{join}->{"clause"} = $1 . " OUTER";
- $remainder = $2;
- }
- if ( $remainder =~ /^JOIN (.+)/) {
- $jtype = 'INNER';
- $self->{"struct"}->{join}->{"clause"} = 'DEFAULT INNER';
- $remainder = $1;
- }
- if ( $self->{"struct"}->{join} ) {
- if ( $remainder && $remainder =~ /^(.+?) USING \(([^\)]+)\)(.*)/) {
- $self->{"struct"}->{join}->{"clause"} = 'USING';
- $tableB = $1;
- my $keycolstr = $2;
- $remainder = $3;
- @$keycols = split /,/,$keycolstr;
- }
- if ( $remainder && $remainder =~ /^(.+?) ON (.+)/) {
- $self->{"struct"}->{join}->{"clause"} = 'ON';
- $tableB = $1;
-#zzz
-#print "here";
-#print 9 if $self->can('TABLE_NAME_LIST');
-#return undef unless $self->TABLE_NAME_LIST($tableA.','.$tableB);
-#print "there";
-#exit;
-
- my $keycolstr = $2;
- $remainder = $3;
- if ($keycolstr =~ / OR /i ) {
- return $self->do_err(qq~Can't use OR in an ON clause!~,1);
- }
- @$keycols = split / AND /i,$keycolstr;
-#zzz
-return undef unless $self->TABLE_NAME_LIST($tableA.','.$tableB);
-# $self->{"tmp"}->{"is_table_name"}->{"$tableA"} = 1;
-# $self->{"tmp"}->{"is_table_name"}->{"$tableB"} = 1;
- for (@$keycols) {
- my %is_done;
- my($arg1,$arg2) = split / = /;
- my($c1,$c2)=($arg1,$arg2);
- $c1 =~ s/^.*\.([^\.]+)$/$1/;
- $c2 =~ s/^.*\.([^\.]+)$/$1/;
- if ($c1 eq $c2) {
- return undef unless $arg1 = $self->ROW_VALUE($c1);
- if ( $arg1->{type} eq 'column' and !$is_done{$c1}
- ){
- push @{$self->{struct}->{keycols}},$arg1->{value};
- $is_done{$c1}=1;
- }
- }
- else {
- return undef unless $arg1 = $self->ROW_VALUE($arg1);
- return undef unless $arg2 = $self->ROW_VALUE($arg2);
- if ( $arg1->{"type"}eq 'column'
- and $arg2->{"type"}eq 'column'){
- push @{ $self->{"struct"}->{"keycols"} }
- , $arg1->{"value"};
- push @{ $self->{"struct"}->{"keycols"} }
- , $arg2->{"value"};
- # delete $self->{"struct"}->{"where_clause"};
- }
- }
- }
- }
- elsif ($remainder =~ /^(.+?)$/i) {
- $tableB = $1;
- $remainder = $2;
- }
- $remainder =~ s/^\s+// if $remainder;
- }
-
- if ($jtype) {
- $jtype = "NATURAL $jtype" if $natural;
- if ($natural and $keycols) {
- return $self->do_err(
- qq~Can't use NATURAL with a USING or ON clause!~
- );
- }
- return undef unless $self->TABLE_NAME_LIST("$tableA,$tableB");
- $self->{"struct"}->{join}->{"type"} = $jtype;
- $self->{"struct"}->{join}->{"keycols"} = $keycols if $keycols;
- return 1;
- }
- return $self->do_err("Couldn't parse explicit JOIN!");
-}
-
-sub SELECT_CLAUSE {
- my($self,$str) = @_;
- return undef unless $str;
- if ($str =~ s/^(DISTINCT|ALL) (.+)$/$2/i) {
- $self->{"struct"}->{"set_quantifier"} = uc $1;
- }
- if ($str =~ /[()]/) {
- return undef unless $self->SET_FUNCTION_SPEC($str);
- }
- else {
- return undef unless $self->SELECT_LIST($str);
- }
-}
-
-sub FROM_CLAUSE {
- my($self,$str) = @_;
- return undef unless $str;
- if ($str =~ / JOIN /i ) {
- return undef unless $self->EXPLICIT_JOIN($str);
- }
- else {
- return undef unless $self->TABLE_NAME_LIST($str);
- }
-}
-
-sub INSERT {
- my($self,$str) = @_;
- my $col_str;
- my($table_name,$val_str) = $str =~
- /^INSERT\s+INTO\s+(.+?)\s+VALUES\s+\((.+?)\)$/i;
- if ($table_name and $table_name =~ /[()]/ ) {
- ($table_name,$col_str,$val_str) = $str =~
- /^INSERT\s+INTO\s+(.+?)\s+\((.+?)\)\s+VALUES\s+\((.+?)\)$/i;
- }
- return $self->do_err('No table name specified!') unless $table_name;
- return $self->do_err('Missing values list!') unless defined $val_str;
- return undef unless $self->TABLE_NAME($table_name);
- $self->{"struct"}->{"command"} = 'INSERT';
- $self->{"struct"}->{"table_names"} = [$table_name];
- if ($col_str) {
- return undef unless $self->COLUMN_NAME_LIST($col_str);
- }
- else {
- $self->{"struct"}->{"column_names"} = ['*'];
- }
- return undef unless $self->LITERAL_LIST($val_str);
- return 1;
-}
-
-###################################################################
-# UPDATE ::=
-#
-# UPDATE <table> SET <set_clause_list> [ WHERE <search_condition>]
-#
-###################################################################
-sub UPDATE {
- my($self,$str) = @_;
- $self->{"struct"}->{"command"} = 'UPDATE';
- my($table_name,$remainder) = $str =~
- /^UPDATE (.+?) SET (.+)$/i;
- return $self->do_err(
- 'Incomplete UPDATE clause'
- ) if !$table_name or !$remainder;
- return undef unless $self->TABLE_NAME($table_name);
- $self->{"tmp"}->{"is_table_name"} = {$table_name => 1};
- $self->{"struct"}->{"table_names"} = [$table_name];
- my($set_clause,$where_clause) = $remainder =~
- /(.*?) WHERE (.*)$/i;
- $set_clause = $remainder if !$set_clause;
- return undef unless $self->SET_CLAUSE_LIST($set_clause);
- if ($where_clause) {
- return undef unless $self->SEARCH_CONDITION($where_clause);
- }
- my @vals = @{$self->{"struct"}->{"values"}};
- my $num_val_placeholders=0;
- for my $v(@vals) {
- $num_val_placeholders++ if $v->{"type"} eq 'placeholder';
- }
- $self->{"struct"}->{"num_val_placeholders"}=$num_val_placeholders;
- return 1;
-}
-
-#########
-# CREATE
-#########
-
-sub CREATE {
- my $self = shift;
- my $stmt = shift;
- $self->{"struct"}->{"command"} = 'CREATE';
- my($table_name,$table_element_def,%is_col_name);
- if ($stmt =~ /^CREATE (LOCAL|GLOBAL) TEMPORARY TABLE(.*)$/si ) {
- $self->{"struct"}->{"table_type"} = "$1 TEMPORARY";
- $stmt = "CREATE TABLE$2";
- }
- if ($stmt =~ /^(.*) ON COMMIT (DELETE|PRESERVE) ROWS\s*$/si ) {
- $stmt = $1;
- $self->{"struct"}->{"commit_behaviour"} = $2;
- return $self->do_err(
- "Can't specify commit behaviour for permanent tables."
- )
- if !defined $self->{"struct"}->{"table_type"}
- or $self->{"struct"}->{"table_type"} !~ /TEMPORARY/;
- }
- if ($stmt =~ /^CREATE TABLE (\S+) \((.*)\)$/si ) {
- $table_name = $1;
- $table_element_def = $2;
- }
- else {
- return $self->do_err( "Can't find column definitions!" );
- }
- return undef unless $self->TABLE_NAME($table_name);
- $table_element_def =~ s/\s+\(/(/g;
- my $primary_defined;
- for my $col(split ',',$table_element_def) {
- my($name,$type,$constraints)=($col =~/\s*(\S+)\s+(\S+)\s*(.*)/);
- if (!$type) {
- return $self->do_err( "Column definition is missing a data type!" );
- }
- return undef if !($self->IDENTIFIER($name));
-# if ($name =~ /^\?QI(.+)\?$/ ) {
- $name = $self->replace_quoted_ids($name);
-# }
- $constraints =~ s/^\s+//;
- $constraints =~ s/\s+$//;
- if ($constraints) {
- $constraints =~ s/PRIMARY KEY/PRIMARY_KEY/i;
- $constraints =~ s/NOT NULL/NOT_NULL/i;
- my @c = split /\s+/, $constraints;
- my %has_c;
- for my $constr(@c) {
- if ( $constr =~ /^\s*(UNIQUE|NOT_NULL|PRIMARY_KEY)\s*$/i ) {
- my $cur_c = uc $1;
- if ($has_c{$cur_c}++) {
- return $self->do_err(
- qq~Duplicate column constraint: '$constr'!~
- );
- }
- if ($cur_c eq 'PRIMARY_KEY' and $primary_defined++ ) {
- return $self->do_err(
- qq~Can't have two PRIMARY KEYs in a table!~
- );
- }
- $constr =~ s/_/ /g;
- push @{$self->{"struct"}->{"column_defs"}->{"$name"}->{"constraints"} }, $constr;
-
- }
- else {
- return $self->do_err("Unknown column constraint: '$constr'!");
- }
- }
- }
- $type = uc $type;
- my $length;
- if ( $type =~ /(.+)\((.+)\)/ ) {
- $type = $1;
- $length = $2;
- }
- if (!$self->{"opts"}->{"valid_data_types"}->{"$type"}) {
- return $self->do_err("'$type' is not a recognized data type!");
- }
- $self->{"struct"}->{"column_defs"}->{"$name"}->{"data_type"} = $type;
- $self->{"struct"}->{"column_defs"}->{"$name"}->{"data_length"} = $length;
- push @{$self->{"struct"}->{"column_names"}},$name;
- #push @{$self->{"struct"}->{ORG_NAME}},$name;
- my $tmpname = $name;
- $tmpname = uc $tmpname unless $tmpname =~ /^"/;
- return $self->do_err("Duplicate column names!")
- if $is_col_name{$tmpname}++;
-
- }
- $self->{"struct"}->{"table_names"} = [$table_name];
- return 1;
-}
-
-
-###############
-# SQL SUBRULES
-###############
-
-sub SET_CLAUSE_LIST {
- my $self = shift;
- my $set_string = shift;
- my @sets = split /,/,$set_string;
- my(@cols, at vals);
- for(@sets) {
- my($col,$val) = split / = /,$_;
- return $self->do_err('Incomplete SET clause!') if !defined $col or !defined $val;
- push @cols, $col;
- push @vals, $val;
- }
- return undef unless $self->COLUMN_NAME_LIST(join ',', at cols);
- return undef unless $self->LITERAL_LIST(join ',', at vals);
- return 1;
-}
-
-sub SET_QUANTIFIER {
- my($self,$str) = @_;
- if ($str =~ /^(DISTINCT|ALL)\s+(.*)$/si) {
- $self->{"struct"}->{"set_quantifier"} = uc $1;
- $str = $2;
- }
- return $str;
-}
-
-sub SELECT_LIST {
- my $self = shift;
- my $col_str = shift;
- if ( $col_str =~ /^\s*\*\s*$/ ) {
- $self->{"struct"}->{"column_names"} = ['*'];
- return 1;
- }
- my @col_list = split ',',$col_str;
- if (!(scalar @col_list)) {
- return $self->do_err('Missing column name list!');
- }
- my(@newcols,$newcol);
- for my $col(@col_list) {
-# $col = trim($col);
- $col =~ s/^\s+//;
- $col =~ s/\s+$//;
- if ($col =~ /^(\S+)\.\*$/) {
- my $table = $1;
- my %is_table_alias = %{$self->{"tmp"}->{"is_table_alias"}};
- $table = $is_table_alias{$table} if $is_table_alias{$table};
- $table = $is_table_alias{"\L$table"} if $is_table_alias{"\L$table"};
-# $table = uc $table unless $table =~ /^"/;
-#use mylibs; zwarn \%is_table_alias;
-#print "\n<<$table>>\n";
- return undef unless $self->TABLE_NAME($table);
- $table = $self->replace_quoted_ids($table);
- push @newcols, "$table.*";
- }
- else {
- return undef unless $newcol = $self->COLUMN_NAME($col);
- push @newcols, $newcol;
- }
- }
- $self->{"struct"}->{"column_names"} = \@newcols;
- return 1;
-}
-
-sub SET_FUNCTION_SPEC {
- my($self,$col_str) = @_;
- my @funcs = split /,/, $col_str;
- my %iscol;
- for my $func(@funcs) {
- if ($func =~ /^(COUNT|AVG|SUM|MAX|MIN) \((.*)\)\s*$/i ) {
- my $set_function_name = uc $1;
- my $set_function_arg = $2;
- my $distinct;
- if ( $set_function_arg =~ s/(DISTINCT|ALL) (.+)$/$2/i ) {
- $distinct = uc $1;
- $self->{"struct"}->{"set_quantifier"} = $distinct;
- }
- my $count_star = 1 if $set_function_name eq 'COUNT'
- and $set_function_arg eq '*';
- my $ok = $self->COLUMN_NAME($set_function_arg)
- if !$count_star;
- return undef if !$count_star and !$ok;
- if ($set_function_arg !~ /^"/) {
- $set_function_arg = uc $set_function_arg;
- }
- push @{ $self->{"struct"}->{'set_function'}}, {
- name => $set_function_name,
- arg => $set_function_arg,
- distinct => $distinct,
- };
- push( @{ $self->{"struct"}->{"column_names"} }, $set_function_arg)
- if !$iscol{$set_function_arg}++
- and ($set_function_arg ne '*');
- }
- else {
- return $self->do_err("Bad set function before FROM clause.");
- }
- }
- my $cname = $self->{"struct"}->{"column_names"};
- if ( !$cname or not scalar @$cname ) {
- $self->{"struct"}->{"column_names"} = ['*'];
- }
- return 1;
-}
-
-sub LIMIT_CLAUSE {
- my($self,$limit_clause) = @_;
-# $limit_clause = trim($limit_clause);
- $limit_clause =~ s/^\s+//;
- $limit_clause =~ s/\s+$//;
-
- return 1 if !$limit_clause;
- my($offset,$limit,$junk) = split /,/, $limit_clause;
- return $self->do_err('Bad limit clause!')
- if (defined $limit and $limit =~ /[^\d]/)
- or ( defined $offset and $offset =~ /[^\d]/ )
- or defined $junk;
- if (defined $offset and !defined $limit) {
- $limit = $offset;
- undef $offset;
- }
- $self->{"struct"}->{"limit_clause"} = {
- limit => $limit,
- offset => $offset,
- };
- return 1;
-}
-
-sub is_number {
- my $x=shift;
- return 0 if !defined $x;
- return 1 if $x =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
- return 0;
-}
-
-sub SORT_SPEC_LIST {
- my($self,$order_clause) = @_;
- return 1 if !$order_clause;
- my %is_table_name = %{$self->{"tmp"}->{"is_table_name"}};
- my %is_table_alias = %{$self->{"tmp"}->{"is_table_alias"}};
- my @ocols;
- my @order_columns = split ',',$order_clause;
- for my $col(@order_columns) {
- my $newcol;
- my $newarg;
- if ($col =~ /\s*(\S+)\s+(ASC|DESC)/si ) {
- $newcol = $1;
- $newarg = uc $2;
- }
- elsif ($col =~ /^\s*(\S+)\s*$/si ) {
- $newcol = $1;
- }
- else {
- return $self->do_err(
- 'Junk after column name in ORDER BY clause!'
- );
- }
- return undef if !($newcol = $self->COLUMN_NAME($newcol));
- if ($newcol =~ /^(.+)\..+$/s ) {
- my $table = $1;
- if ($table =~ /^'/) {
- if (!$is_table_name{"$table"} and !$is_table_alias{"$table"} ) {
- return $self->do_err( "Table '$table' in ORDER BY clause "
- . "not in FROM clause."
- );
- }}
- elsif (!$is_table_name{"\L$table"} and !$is_table_alias{"\L$table"} ) {
- return $self->do_err( "Table '$table' in ORDER BY clause "
- . "not in FROM clause."
- );
- }
- }
- push @ocols, {$newcol => $newarg};
- }
- $self->{"struct"}->{"sort_spec_list"} = \@ocols;
- return 1;
-}
-
-sub SEARCH_CONDITION {
- my $self = shift;
- my $str = shift;
- $str =~ s/^\s*WHERE (.+)/$1/;
- $str =~ s/^\s+//;
- $str =~ s/\s+$//;
- return $self->do_err("Couldn't find WHERE clause!") unless $str;
- $str = get_btwn( $str );
- $str = get_in( $str );
- my $open_parens = $str =~ tr/\(//;
- my $close_parens = $str =~ tr/\)//;
- if ($open_parens != $close_parens) {
- return $self->do_err("Mismatched parentheses in WHERE clause!");
- }
- $str = nongroup_numeric( nongroup_string( $str ) );
- my $pred = $open_parens
- ? $self->parens_search($str,[])
- : $self->non_parens_search($str,[]);
- return $self->do_err("Couldn't find predicate!") unless $pred;
- $self->{"struct"}->{"where_clause"} = $pred;
- return 1;
-}
-
-############################################################
-# UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE
-############################################################
-
-# get BETWEEN clause
-#
-sub get_btwn {
- my $str = shift;
- if ($str =~ /^(.+?) BETWEEN (.+)$/i ) {
- my($col,$in,$out,$contents);
- my $front = $1;
- my $back = $2;
- my $not = 1 if $front =~ s/^(.+) NOT$/$1/i;
- if ($front =~ s/^(.+? )(AND|OR|\() (.+)$/$1$2/i) {
- $col = $3;
- }
- else {
- $col = $front;
- $front = '';
- }
- $front .= " NOT" if $not;
- my($val1,$val2);
- if ($back =~ s/^(.+?) AND (.+)$/$2/) {
- $val1 = $1;
- }
- if ($back =~ s/^(.+?) (AND|OR)(.+)$/$2$3/i) {
- $val2 = $1;
- }
- else {
- $val2 = $back;
- $back = '';
- }
- $str = "$front ($col > $val1 AND $col < $val2) $back";
- return get_btwn($str);
- }
- return $str;
-}
-
-# get IN clause
-#
-# a IN (b,c) -> (a=b OR a=c)
-# a NOT IN (b,c) -> (a<>b AND a<>c)
-#
-sub get_in {
- my $str = shift;
- my $in_inside_parens;
- if ($str =~ /^(.+?) IN (\(.+)$/i ) {
- my($col,$in,$out,$contents);
- my $front = $1;
- my $back = $2;
- my $not;
- $not++ if $front =~ s/^(.+) NOT$/$1/i;
- if ($front =~ s/^(.+? )(AND|OR|\() (.+)$/$1$2/i) {
- $col = $3;
- }
- else {
- $col = $front;
- $not++ if $col =~ s/^NOT (.+)/$1/i;
- $front = '';
- }
- if ( $col =~ s/^\(// ) {
- $in_inside_parens++;
- }
-#print "~$not~\n";
- # $front .= " NOT" if $not;
-# $not++ if $front =~ s/^(.+) NOT$/$1/i;
- my @chars = split '', $back;
- for (0..$#chars) {
- my $char = shift @chars;
- $contents .= $char;
- $in++ if $char eq '(';
- if ( $char eq ')' ) {
- $out++;
- last if $in == $out;
- }
- }
- $back = join '', @chars;
- $back =~ s/\)$// if $in_inside_parens;
- # print "\n[$front][$col][$contents][$back]\n";
- #die "\n[$contents]\n";
- $contents =~ s/^\(//;
- $contents =~ s/\)$//;
- my @vals = split /,/, $contents;
-my $op = '=';
-my $combiner = 'OR';
-if ($not) {
- $op = '<>';
- $combiner = 'AND';
-}
- @vals = map { "$col $op $_" } @vals;
- my $valStr = join " $combiner ", @vals;
- $str = "$front ($valStr) $back";
- $str =~ s/\s+/ /g;
- return get_in($str);
- }
-$str =~ s/^\s+//;
-$str =~ s/\s+$//;
-$str =~ s/\(\s+/(/;
-$str =~ s/\s+\)/)/;
-#print "$str:\n";
- return $str;
-}
-
-# groups clauses by nested parens
-#
-sub parens_search {
- my $self = shift;
- my $str = shift;
- my $predicates = shift;
- my $index = scalar @$predicates;
-
- # to handle WHERE (a=b) AND (c=d)
- # but needs escape space to not foul up AND/OR
- if ($str =~ /\(([^()]+?)\)/ ) {
- my $pred = quotemeta $1;
- if ($pred !~ / (AND|OR)\\ / ) {
- $str =~ s/\(($pred)\)/$1/;
- }
- }
- #
-
- if ($str =~ s/\(([^()]+)\)/^$index^/ ) {
- push @$predicates, $1;
- }
- # patch from Chromatic
- if ($str =~ /\((?!\))/ ) {
- return $self->parens_search($str,$predicates);
- }
- else {
- return $self->non_parens_search($str,$predicates);
- }
-}
-
-# creates predicates from clauses that either have no parens
-# or ANDs or have been previously grouped by parens and ANDs
-#
-sub non_parens_search {
- my $self = shift;
- my $str = shift;
- my $predicates = shift;
- my $neg = 0;
- my $nots = {};
- if ( $str =~ s/^NOT (\^.+)$/$1/i ) {
- $neg = 1;
- $nots = {pred=>1};
- }
- my( $pred1, $pred2, $op );
- my $and_preds =[];
- ($str,$and_preds) = group_ands($str);
- $str =~ s/^\s*\^0\^\s*$/$predicates->[0]/;
- return if $str =~ /^\s*~0~\s*$/;
- if ( ($pred1, $op, $pred2) = $str =~ /^(.+) (AND|OR) (.+)$/i ) {
- $pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
- $pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
- $pred1 = $self->non_parens_search($pred1,$predicates);
- $pred2 = $self->non_parens_search($pred2,$predicates);
- # print $op;
- return {
- neg => $neg,
- nots => $nots,
- arg1 => $pred1,
- op => uc $op,
- arg2 => $pred2,
- };
- }
- else {
- my $xstr = $str;
- $xstr =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
- my($k,$v) = $xstr =~ /^(\S+?)\s+\S+\s*(.+)\s*$/;
- #print "$k,$v\n" if defined $k;
- push @{ $self->{struct}->{where_cols}->{$k}}, $v if defined $k;
- # print " [$str] ";
- return $self->PREDICATE($str);
- }
-}
-
-# groups AND clauses that aren't already grouped by parens
-#
-sub group_ands{
- my $str = shift;
- my $and_preds = shift || [];
- return($str,$and_preds) unless $str =~ / AND / and $str =~ / OR /;
- if ($str =~ /^(.*?) AND (.*)$/i ) {
- my $index = scalar @$and_preds;
- my($front, $back)=($1,$2);
- if ($front =~ /^.* OR (.*)$/i ) {
- $front = $1;
- }
- if ($back =~ /^(.*?) (OR|AND) (.*)$/i ) {
- $back = $1;
- }
- my $newpred = "$front AND $back";
- push @$and_preds, $newpred;
- $str =~ s/\Q$newpred/~$index~/i;
- return group_ands($str,$and_preds);
- }
- else {
- return $str,$and_preds;
- }
-}
-
-# replaces string function parens with square brackets
-# e.g TRIM (foo) -> TRIM[foo]
-#
-
-sub nongroup_string {
- my $f= FUNCTION_NAMES;
- my $str = shift;
-# $str =~ s/(TRIM|SUBSTRING|UPPER|LOWER) \(([^()]+)\)/$1\[$2\]/gi;
- $str =~ s/($f) \(([^()]+)\)/$1\[$2\]/gi;
-# if ( $str =~ /(TRIM|SUBSTRING|UPPER|LOWER) \(/i ) {
- if ( $str =~ /($f) \(/i ) {
- return nongroup_string($str);
- }
- else {
- return $str;
- }
-}
-
-# replaces math parens with square brackets
-# e.g (4-(6+7)*9) -> MATH[4-MATH[6+7]*9]
-#
-sub nongroup_numeric {
- my $str = shift;
- my $has_op;
- if ( $str =~ /\(([0-9 \*\/\+\-_a-zA-Z\[\]\?]+)\)/ ) {
- my $match = $1;
- if ($match !~ /(LIKE |IS|BETWEEN|IN)/ ) {
- my $re = quotemeta($match);
- $str =~ s/\($re\)/MATH\[$match\]/;
- }
- else {
- $has_op++;
- }
- }
- if ( !$has_op and $str =~ /\(([0-9 \*\/\+\-_a-zA-Z\[\]\?]+)\)/ ) {
- return nongroup_numeric($str);
- }
- else {
- return $str;
- }
-}
-############################################################
-
-
-#########################################################
-# LITERAL_LIST ::= <literal> [,<literal>]
-#########################################################
-sub LITERAL_LIST {
- my $self = shift;
- my $str = shift;
- my @tokens = split /,/, $str;
- my @values;
- for my $tok(@tokens) {
- my $val = $self->ROW_VALUE($tok);
- return $self->do_err(
- qq('$tok' is not a valid value or is not quoted!)
- ) unless $val;
- push @values, $val;
- }
- $self->{"struct"}->{"values"} = \@values;
- return 1;
-}
-
-
-###################################################################
-# LITERAL ::= <quoted_string> | <question mark> | <number> | NULL
-###################################################################
-sub LITERAL {
- my $self = shift;
- my $str = shift;
- return 'null' if $str =~ /^NULL$/i; # NULL
-# return 'empty_string' if $str =~ /^~E~$/i; # NULL
- if ($str eq '?') {
- $self->{struct}->{num_placeholders}++;
- return 'placeholder';
- }
-# return 'placeholder' if $str eq '?'; # placeholder question mark
- return 'string' if $str =~ /^'.*'$/s; # quoted string
- return 'number' if $str =~ # number
- /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
- return undef;
-}
-###################################################################
-# PREDICATE
-###################################################################
-sub PREDICATE {
- my $self = shift;
- my $str = shift;
- my @allops = keys %{ $self->{"opts"}->{"valid_comparison_operators"} };
- my @notops;
- for (@allops) { push (@notops, $_) if /NOT/i };
- my $ops = join '|', @notops;
- my $opexp = "^\\s*(.+)\\s+($ops)\\s+(.*)\\s*\$";
- my($arg1,$op,$arg2) = $str =~ /$opexp/i;
- if (!defined $op) {
- my @compops;
- for (@allops) { push (@compops, $_) if /<=|>=|<>/ };
- $ops = join '|', @compops;
- $opexp = "^\\s*(.+)\\s+($ops)\\s+(.*)\\s*\$";
- ($arg1,$op,$arg2) = $str =~ /$opexp/i;
- }
- if (!defined $op) {
- $ops = join '|', @allops;
- $opexp = "^\\s*(.+)\\s+($ops)\\s+(.*)\\s*\$";
- ($arg1,$op,$arg2) = $str =~ /$opexp/i;
- }
- $op = uc $op;
- if (!defined $arg1 || !defined $op || !defined $arg2) {
- return $self->do_err("Bad predicate: '$str'!");
- }
- my $negated = 0; # boolean value showing if predicate is negated
- my %not; # hash showing elements modified by NOT
- #
- # e.g. "NOT bar = foo" -> %not = (arg1=>1)
- # "bar NOT LIKE foo" -> %not = (op=>1)
- # "NOT bar NOT LIKE foo" -> %not = (arg1=>1,op=>1);
- # "NOT bar IS NOT NULL" -> %not = (arg1=>1,op=>1);
- # "bar = foo" -> %not = undef;
- #
- if ( $arg1 =~ s/^NOT (.+)$/$1/i ) {
- $not{arg1}++;
- }
- if ( $op =~ s/^(.+) NOT$/$1/i
- || $op =~ s/^NOT (.+)$/$1/i ) {
- $not{op}++;
- }
- $negated = 1 if %not and scalar keys %not == 1;
- return undef unless $arg1 = $self->ROW_VALUE($arg1);
- return undef unless $arg2 = $self->ROW_VALUE($arg2);
- if ( $arg1->{"type"}eq 'column'
- and $arg2->{"type"}eq 'column'
- and $op eq '='
- ) {
- push @{ $self->{"struct"}->{"keycols"} }, $arg1->{"value"};
- push @{ $self->{"struct"}->{"keycols"} }, $arg2->{"value"};
- }
- return {
- neg => $negated,
- nots => \%not,
- arg1 => $arg1,
- op => $op,
- arg2 => $arg2,
- };
-}
-
-sub undo_string_funcs {
- my $str = shift;
- my $f= FUNCTION_NAMES;
-# $str =~ s/(TRIM|UPPER|LOWER|SUBSTRING)\[([^\]\[]+?)\]/$1 ($2)/;
-# if ($str =~ /(TRIM|UPPER|LOWER|SUBSTRING)\[/) {
- $str =~ s/($f)\[([^\]\[]+?)\]/$1 ($2)/;
- if ($str =~ /($f)\[/) {
- return undo_string_funcs($str);
- }
- return $str;
-}
-
-sub undo_math_funcs {
- my $str = shift;
- $str =~ s/MATH\[([^\]\[]+?)\]/($1)/;
- if ($str =~ /MATH\[/) {
- return undo_math_funcs($str);
- }
- return $str;
-}
-
-
-###################################################################
-# ROW_VALUE ::= <literal> | <column_name>
-###################################################################
-sub ROW_VALUE {
- my $self = shift;
- my $str = shift;
- $str = undo_string_funcs($str);
- $str = undo_math_funcs($str);
- my $type;
-
- # MATH
- #
- if ($str =~ /[\*\+\-\/]/ ) {
- my @vals;
- my $i=-1;
- $str =~ s/([^\s\*\+\-\/\)\(]+)/push @vals,$1;$i++;"?$i?"/ge;
- my @newvalues;
- for (@vals) {
- my $val = $self->ROW_VALUE($_);
- if ($val && $val->{"type"} !~ /number|column|placeholder/) {
- return $self->do_err(qq[
- String '$val' not allowed in Numeric expression!
- ]);
- }
- push @newvalues,$val;
- }
- return {
- type => 'function',
- name => 'numeric_exp',
- str => $str,
- vals => \@newvalues,
- }
- }
-
- # SUBSTRING (value FROM start [FOR length])
- #
- if ($str =~ /^SUBSTRING \((.+?) FROM (.+)\)\s*$/i ) {
- my $name = 'SUBSTRING';
- my $start = $2;
- my $value = $self->ROW_VALUE($1);
- my $length;
- if ($start =~ /^(.+?) FOR (.+)$/i) {
- $start = $1;
- $length = $2;
- $length = $self->ROW_VALUE($length);
- }
- $start = $self->ROW_VALUE($start);
- $str =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
- return $self->do_err(
- "Can't use a string as a SUBSTRING position: '$str'!")
- if $start->{"type"} eq 'string'
- or ($start->{"length"} and $start->{"length"}->{"type"} eq 'string');
- return undef unless $value;
- return $self->do_err(
- "Can't use a number in SUBSTRING: '$str'!")
- if $value->{"type"} eq 'number';
- return {
- "type" => 'function',
- "name" => $name,
- "value" => $value,
- "start" => $start,
- "length" => $length,
- };
- }
-
- # TO_CHAR (value)
- #
- if ($str =~ /^TO_CHAR \((.+)\)\s*$/i ) {
- my $name = 'TO_CHAR';
- my $value = $self->ROW_VALUE($1);
- return undef unless $value;
- return {
- type => 'function',
- name => $name,
- value => $value,
- };
- }
-
- # UPPER (value) and LOWER (value)
- #
- if ($str =~ /^(UPPER|LOWER) \((.+)\)\s*$/i ) {
- my $name = uc $1;
- my $value = $self->ROW_VALUE($2);
- return undef unless $value;
- $str =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
- return $self->do_err(
- "Can't use a number in UPPER/LOWER: '$str'!")
- if $value->{"type"} eq 'number';
- return {
- type => 'function',
- name => $name,
- value => $value,
- };
- }
-
- # TRIM ( [ [TRAILING|LEADING|BOTH] ['char'] FROM ] value )
- #
- if ($str =~ /^(TRIM) \((.+)\)\s*$/i ) {
- my $name = uc $1;
- my $value = $2;
- my($trim_spec,$trim_char);
- if ($value =~ /^(.+) FROM ([^\(\)]+)$/i ) {
- my $front = $1;
- $value = $2;
- if ($front =~ /^\s*(TRAILING|LEADING|BOTH)(.*)$/i ) {
- $trim_spec = uc $1;
-# $trim_char = trim($2);
- $trim_char = $2;
- $trim_char =~ s/^\s+//;
- $trim_char =~ s/\s+$//;
- undef $trim_char if length($trim_char)==0;
- }
- else {
-# $trim_char = trim($front);
- $trim_char = $front;
- $trim_char =~ s/^\s+//;
- $trim_char =~ s/\s+$//;
- }
- }
- $trim_char =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g if $trim_char;
- $value = $self->ROW_VALUE($value);
- return undef unless $value;
- $str =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
- return $self->do_err(
- "Can't use a number in TRIM: '$str'!")
- if $value->{"type"} eq 'number';
- return {
- type => 'function',
- name => $name,
- value => $value,
- trim_spec => $trim_spec,
- trim_char => $trim_char,
- };
- }
-
- # STRING CONCATENATION
- #
- if ($str =~ /\|\|/ ) {
- my @vals = split / \|\| /,$str;
- my @newvals;
- for my $val(@vals) {
- my $newval = $self->ROW_VALUE($val);
- return undef unless $newval;
- return $self->do_err(
- "Can't use a number in string concatenation: '$str'!")
- if $newval->{"type"} eq 'number';
- push @newvals,$newval;
- }
- return {
- type => 'function',
- name => 'str_concat',
- value => \@newvals,
- };
- }
-
- # NULL, PLACEHOLDER, NUMBER
- #
- if ( $type = $self->LITERAL($str) ) {
- undef $str if $type eq 'null';
-# if ($type eq 'empty_string') {
-# $str = '';
-# $type = 'string';
-# }
- $str = '' if $str and $str eq q('');
- return { type => $type, value => $str };
- }
-
- # QUOTED STRING LITERAL
- #
- if ($str =~ /\?(\d+)\?/) {
- return { type =>'string',
- value => $self->{"struct"}->{"literals"}->[$1] };
- }
- # COLUMN NAME
- #
- return undef unless $str = $self->COLUMN_NAME($str);
- if ( $str =~ /^(.*)\./ && !$self->{"tmp"}->{"is_table_name"}->{"\L$1"}
- and !$self->{"tmp"}->{"is_table_alias"}->{"\L$1"} ) {
- return $self->do_err(
- "Table '$1' in WHERE clause not in FROM clause!"
- );
- }
-# push @{ $self->{"struct"}->{"where_cols"}},$str
-# unless $self->{"tmp"}->{"where_cols"}->{"$str"};
- $self->{"tmp"}->{"where_cols"}->{"$str"}++;
- return { type => 'column', value => $str };
-}
-
-###############################################
-# COLUMN NAME ::= [<table_name>.] <identifier>
-###############################################
-
-sub COLUMN_NAME {
- my $self = shift;
- my $str = shift;
- my($table_name,$col_name);
- if ( $str =~ /^\s*(\S+)\.(\S+)$/s ) {
- if (!$self->{"opts"}->{"valid_options"}->{"SELECT_MULTIPLE_TABLES"}) {
- return $self->do_err('Dialect does not support multiple tables!');
- }
- $table_name = $1;
- $col_name = $2;
-# my $alias = $self->{struct}->{table_alias} || [];
-# $table_name = shift @$alias if $alias;
- return undef unless $self->TABLE_NAME($table_name);
- $table_name = $self->replace_quoted_ids($table_name);
- my $ref;
- if ($table_name =~ /^"/) { #"
- if (!$self->{"tmp"}->{"is_table_name"}->{"$table_name"}
- and !$self->{"tmp"}->{"is_table_alias"}->{"$table_name"}
- ) {
- $self->do_err(
- "Table '$table_name' referenced but not found in FROM list!"
- );
- return undef;
- }
- }
- elsif (!$self->{"tmp"}->{"is_table_name"}->{"\L$table_name"}
- and !$self->{"tmp"}->{"is_table_alias"}->{"\L$table_name"}
- ) {
- $self->do_err(
- "Table '$table_name' referenced but not found in FROM list!"
- );
- return undef;
- }
- }
- else {
- $col_name = $str;
- }
-# $col_name = trim($col_name);
- $col_name =~ s/^\s+//;
- $col_name =~ s/\s+$//;
- return undef unless $col_name eq '*' or $self->IDENTIFIER($col_name);
-#
-# MAKE COL NAMES ALL UPPER CASE
- my $orgcol = $col_name;
- if ($col_name =~ /^\?QI(\d+)\?$/) {
- $col_name = $self->replace_quoted_ids($col_name);
- }
- else {
-# $col_name = lc $col_name;
- $col_name = uc $col_name unless $self->{struct}->{command} eq 'CREATE';
-
- }
- $self->{struct}->{ORG_NAME}->{$col_name} = $orgcol;
-
-#
-#
- if ($table_name) {
- my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"};
-#use mylibs; print "$table_name"; zwarn $self->{tmp};
- $table_name = $alias if defined $alias;
-$table_name = uc $table_name;
- $col_name = "$table_name.$col_name";
-#print "<<$col_name>>";
- }
- return $col_name;
-}
-
-#########################################################
-# COLUMN NAME_LIST ::= <column_name> [,<column_name>...]
-#########################################################
-sub COLUMN_NAME_LIST {
- my $self = shift;
- my $col_str = shift;
- my @col_list = split ',',$col_str;
- if (!(scalar @col_list)) {
- return $self->do_err('Missing column name list!');
- }
- my @newcols;
- my $newcol;
- for my $col(@col_list) {
- $col =~ s/^\s+//;
- $col =~ s/\s+$//;
-# return undef if !($newcol = $self->COLUMN_NAME(trim($col)));
- return undef if !($newcol = $self->COLUMN_NAME($col));
- push @newcols, $newcol;
- }
- $self->{"struct"}->{"column_names"} = \@newcols;
- return 1;
-}
-
-
-#####################################################
-# TABLE_NAME_LIST := <table_name> [,<table_name>...]
-#####################################################
-sub TABLE_NAME_LIST {
- my $self = shift;
- my $table_name_str = shift;
- my %aliases = ();
- my @tables;
- my @table_names = split ',', $table_name_str;
- if ( scalar @table_names > 1
- and !$self->{"opts"}->{"valid_options"}->{'SELECT_MULTIPLE_TABLES'}
- ) {
- return $self->do_err('Dialect does not support multiple tables!');
- }
- my %is_table_alias;
- for my $table_str(@table_names) {
- my($table,$alias);
- my(@tstr) = split / /,$table_str;
- if (@tstr == 1) { $table = $tstr[0]; }
- elsif (@tstr == 2) { $table = $tstr[0]; $alias = $tstr[1]; }
-# elsif (@tstr == 2) { $table = $tstr[1]; $alias = $tstr[0]; }
- elsif (@tstr == 3) {
- return $self->do_err("Can't find alias in FROM clause!")
- unless uc($tstr[1]) eq 'AS';
- $table = $tstr[0]; $alias = $tstr[2];
-# $table = $tstr[2]; $alias = $tstr[0];
- }
- else {
- return $self->do_err("Can't find table names in FROM clause!")
- }
- return undef unless $self->TABLE_NAME($table);
- $table = $self->replace_quoted_ids($table);
-# zzz
- push @tables, $table;
- if ($alias) {
-#die $alias, $table;
- return undef unless $self->TABLE_NAME($alias);
- $alias = $self->replace_quoted_ids($alias);
- if ($alias =~ /^"/) {
- push @{$aliases{$table}},"$alias";
- $is_table_alias{"$alias"}=$table;
- }
- else {
- push @{$aliases{$table}},"\L$alias";
- $is_table_alias{"\L$alias"}=$table;
- }
-# $aliases{$alias} = $table;
- }
- }
-# my %is_table_name = map { $_ => 1 } @tables,keys %aliases;
- my %is_table_name = map { lc $_ => 1 } @tables;
- #%is_table_alias = map { lc $_ => 1 } @aliases;
- $self->{"tmp"}->{"is_table_alias"} = \%is_table_alias;
- $self->{"tmp"}->{"is_table_name"} = \%is_table_name;
- $self->{"struct"}->{"table_names"} = \@tables;
- $self->{"struct"}->{"table_alias"} = \%aliases;
- $self->{"struct"}->{"multiple_tables"} = 1 if @tables > 1;
- return 1;
-}
-
-#############################
-# TABLE_NAME := <identifier>
-#############################
-sub TABLE_NAME {
- my $self = shift;
- my $table_name = shift;
- if ($table_name =~ /\s*(\S+)\s+\S+/s) {
- return $self->do_err("Junk after table name '$1'!");
- }
- $table_name =~ s/\s+//s;
- if (!$table_name) {
- return $self->do_err('No table name specified!');
- }
- return $self->IDENTIFIER($table_name);
-# return undef if !($self->IDENTIFIER($table_name));
-# return 1;
-}
-
-
-###################################################################
-# IDENTIFIER ::= <alphabetic_char> { <alphanumeric_char> | _ }...
-#
-# and must not be a reserved word or over 128 chars in length
-###################################################################
-sub IDENTIFIER {
- my $self = shift;
- my $id = shift;
- if ($id =~ /^\?QI(.+)\?$/ ) {
- return 1;
- }
- return 1 if $id =~ /^".+?"$/s; # QUOTED IDENTIFIER
- my $err = "Bad table or column name '$id' "; # BAD CHARS
- if ($id =~ /\W/) {
- $err .= "has chars not alphanumeric or underscore!";
- return $self->do_err( $err );
- }
- if ($id =~ /^_/ or $id =~ /^\d/) { # BAD START
- $err .= "starts with non-alphabetic character!";
- return $self->do_err( $err );
- }
- if ( length $id > 128 ) { # BAD LENGTH
- $err .= "contains more than 128 characters!";
- return $self->do_err( $err );
- }
-$id = uc $id;
-#print "<$id>";
-#use mylibs; zwarn $self->{opts}->{reserved_words};
-#exit;
- if ( $self->{"opts"}->{"reserved_words"}->{$id} ) { # BAD RESERVED WORDS
- $err .= "is a SQL reserved word!";
- return $self->do_err( $err );
- }
- return 1;
-}
-
-########################################
-# PRIVATE METHODS AND UTILITY FUNCTIONS
-########################################
-sub order_joins {
- my $self = shift;
- my $links = shift;
- for my $link(@$links) {
- if ($link !~ /\./) {
- return [];
- }
- }
- @$links = map { s/^(.+)\..*$/$1/; $1; } @$links;
- my @all_tables;
- my %relations;
- my %is_table;
- while (@$links) {
- my $t1 = shift @$links;
- my $t2 = shift @$links;
- return undef unless defined $t1 and defined $t2;
- push @all_tables, $t1 unless $is_table{$t1}++;
- push @all_tables, $t2 unless $is_table{$t2}++;
- $relations{$t1}{$t2}++;
- $relations{$t2}{$t1}++;
- }
- my @tables = @all_tables;
- my @order = shift @tables;
- my %is_ordered = ( $order[0] => 1 );
- my %visited;
- while(@tables) {
- my $t = shift @tables;
- my @rels = keys %{$relations{$t}};
- for my $t2(@rels) {
- next unless $is_ordered{$t2};
- push @order, $t;
- $is_ordered{$t}++;
- last;
- }
- if (!$is_ordered{$t}) {
- push @tables, $t if $visited{$t}++ < @all_tables;
- }
- }
- return $self->do_err(
- "Unconnected tables in equijoin statement!"
- ) if @order < @all_tables;
- return \@order;
-}
-
-sub bless_me {
- my $class = shift;
- my $self = shift || {};
- return bless $self, $class;
-}
-
-# PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW
-#
-#
-sub set_feature_flags {
- my($self,$select,$create) = @_;
- if (defined $select) {
- delete $self->{"select"};
- $self->{"opts"}->{"valid_options"}->{"SELECT_MULTIPLE_TABLES"} =
- $self->{"opts"}->{"select"}->{join} = $select->{join};
- }
- if (defined $create) {
- delete $self->{"create"};
- for my $key(keys %$create) {
- my $type = $key;
- $type =~ s/type_(.*)/\U$1/;
- $self->{"opts"}->{"valid_data_types"}->{"$type"} =
- $self->{"opts"}->{"create"}->{"$key"} = $create->{"$key"};
- }
- }
-}
-
-sub clean_sql {
- my $self = shift;
- my $sql = shift;
- my $fields;
- my $i=-1;
- my $e = '\\';
- $e = quotemeta($e);
-###new
-# CAN'T HANDLE BLOBS!!!
-# $sql = quotemeta($sql);
- # print "[$sql]\n";
-# if ($sql =~ s/^(.*,\s*)''(\s*[,\)].*)$/${1}NULL$2/g ) {
-# }
-# $sql =~ s/^([^\\']+?)''(.*)$/${1} NULL $2/g;
-
- # $sql =~ s/([^\\]+?)''/$1 ~E~ /g;
-
- # print "$sql\n";
-###newend
-
-# $sql =~ s~'(([^'$e]|$e.)+)'~push(@$fields,$1);$i++;"?$i?"~ge;
- $sql =~ s~'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge;
-
-# $sql =~ s/([^\\]+?)''/$1 ~E~ /g;
- #print "<$sql>";
- @$fields = map { s/''/\\'/g; $_ } @$fields;
-
-###new
-# if ( $sql =~ /'/) {
- if ( $sql =~ tr/[^\\]'// % 2 == 1 ) {
-###endnew
- $sql =~ s/^.*\?(.+)$/$1/;
- die "Mismatched single quote before: '$sql\n";
- }
- if ($sql =~ /\?\?(\d)\?/) {
- $sql = $fields->[$1];
- die "Mismatched single quote: '$sql\n";
- }
- @$fields = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$fields;
- $self->{"struct"}->{"literals"} = $fields;
-
- my $qids;
- $i=-1;
- $e = q/""/;
-# $sql =~ s~"(([^"$e]|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
- $sql =~ s~"(([^"]|"")+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
- #@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids;
- $self->{"struct"}->{"quoted_ids"} = $qids if $qids;
-
-# $sql =~ s~'(([^'\\]|\\.)+)'~push(@$fields,$1);$i++;"?$i?"~ge;
-# @$fields = map { s/\\'/'/g; s/^'(.*)'$/$1/; $_} @$fields;
-#print "$sql [@$fields]\n";# if $sql =~ /SELECT/;
-
-## before line 1511
- my $comment_re = $self->{"comment_re"};
-# if ( $sql =~ s/($comment_re)//gs) {
-# $self->{"comment"} = $1;
-# }
- if ( $sql =~ /(.*)$comment_re$/s) {
- $sql = $1;
- $self->{"comment"} = $2;
- }
- if ($sql =~ /^(.*)--(.*)(\n|$)/) {
- $sql = $1;
- $self->{"comment"} = $2;
- }
-
- $sql =~ s/\n/ /g;
- $sql =~ s/\s+/ /g;
- $sql =~ s/(\S)\(/$1 (/g; # ensure whitespace before (
- $sql =~ s/\)(\S)/) $1/g; # ensure whitespace after )
- $sql =~ s/\(\s*/(/g; # trim whitespace after (
- $sql =~ s/\s*\)/)/g; # trim whitespace before )
- #
- # $sql =~ s/\s*\(/(/g; # trim whitespace before (
- # $sql =~ s/\)\s*/)/g; # trim whitespace after )
- for my $op( qw( = <> < > <= >= \|\|) ) {
- $sql =~ s/(\S)$op/$1 $op/g;
- $sql =~ s/$op(\S)/$op $1/g;
- }
- $sql =~ s/< >/<>/g;
- $sql =~ s/< =/<=/g;
- $sql =~ s/> =/>=/g;
- $sql =~ s/\s*,/,/g;
- $sql =~ s/,\s*/,/g;
- $sql =~ s/^\s+//;
- $sql =~ s/\s+$//;
- return $sql;
-}
-
-sub trim {
- my $str = shift or return '';
- $str =~ s/^\s+//;
- $str =~ s/\s+$//;
- return $str;
-}
-
-sub do_err {
- my $self = shift;
- my $err = shift;
- my $errtype = shift;
- my @c = caller 4;
- $err = "$err\n\n";
-# $err = $errtype ? "DIALECT ERROR: $err in $c[3]"
-# : "SQL ERROR: $err in $c[3]";
- $err = $errtype ? "DIALECT ERROR: $err"
- : "SQL ERROR: $err";
- $self->{"struct"}->{"errstr"} = $err;
- #$self->{"errstr"} = $err;
- warn $err if $self->{"PrintError"};
- die $err if $self->{"RaiseError"};
- return undef;
-}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
- SQL::Parser -- validate, parse, or build SQL strings
-
-=head1 SYNOPSIS
-
- use SQL::Parser; # CREATE A PARSER OBJECT
- my $parser = SQL::Parser->new( $dialect, \%attrs );
-
- my $success = $parser->parse( $sql_string ); # PARSE A SQL STRING &
- if ($success) { # DISPLAY RESULTING DATA
- use Data::Dumper; # STRUCTURE
- print Dumper $parser->structure;
- }
-
- $parser->feature( $class, $name, $value ); # SET OR FIND STATUS OF
- my $has_feature = $parser->feature( $class, $name ); # A PARSER FEATURE
-
- $parser->dialect( $dialect_name ); # SET OR FIND STATUS OF
- my $current_dialect = $parser->dialect; # A PARSER DIALECT
-
- print $parser->errstr; # DISPLAY CURRENT ERROR
- # STRING
-
-
-=head1 DESCRIPTION
-
- SQL::Parser is a parser, builder, and sytax validator for a
- small but useful subset of SQL (Structured Query Language). It
- accepts SQL strings and returns either a detailed error message
- if the syntax is invalid or a data structure containing the
- results of the parse if the syntax is valid. It will soon also
- work in reverse to build a SQL string from a supplied data
- structure.
-
- The module can be used in batch mode to validate a series of
- statements, or as middle-ware for DBI drivers or other related
- projects. When combined with SQL::Statement version 0.2 or
- greater, the module can be used to actually perform the SQL
- commands on a variety of file formats using DBD::AnyData, or
- DBD::CSV, or DBD::Excel.
-
- The module makes use of a variety of configuration files
- located in the SQL/Dialects directory, each of which is
- essentially a simple text file listing things like supported
- data types, reserved words, and other features specific to a
- given dialect of SQL. These features can also be turned on or
- off during program execution.
-
-=head1 SUPPORTED SQL SYNTAX
-
-This module is meant primarly as a base class for DBD drivers
-and as such concentrates on a small but useful subset of SQL 92.
-It does *not* in any way pretend to be a complete SQL 92 parser.
-The module will continue to add new supported syntax, currently,
-this is what is supported:
-
-=head2 CREATE TABLE
-
- CREATE [ {LOCAL|GLOBAL} TEMPORARY ] TABLE $table
- (
- $col_1 $col_type1 $col_constraints1,
- ...,
- $col_N $col_typeN $col_constraintsN,
- )
- [ ON COMMIT {DELETE|PRESERVE} ROWS ]
-
- * col_type must be a valid data type as defined in the
- "valid_data_types" section of the dialect file for the
- current dialect
-
- * col_constriaints may be "PRIMARY KEY" or one or both of
- "UNIQUE" and/or "NOT NULL"
-
- * IMPORTANT NOTE: temporary tables, data types and column
- constraints are checked for syntax violations but are
- currently otherwise *IGNORED* -- they are recognized by
- the parser, but not by the execution engine
-
- * The following valid ANSI SQL92 options are not currently
- supported: table constraints, named constraints, check
- constriants, reference constraints, constraint
- attributes, collations, default clauses, domain names as
- data types
-
-=head2 DROP TABLE
-
- DROP TABLE $table [ RESTRICT | CASCADE ]
-
- * IMPORTANT NOTE: drop behavior (cascade or restrict) is
- checked for valid syntax but is otherwise *IGNORED* -- it
- is recognized by the parser, but not by the execution
- engine
-
-=head2 INSERT INTO
-
- INSERT INTO $table [ ( $col1, ..., $colN ) ] VALUES ( $val1, ... $valN )
-
- * default values are not currently supported
- * inserting from a subquery is not currently supported
-
-=head2 DELETE FROM
-
- DELETE FROM $table [ WHERE search_condition ]
-
- * see "search_condition" below
-
-=head2 UPDATE
-
- UPDATE $table SET $col1 = $val1, ... $colN = $valN [ WHERE search_condition ]
-
- * default values are not currently supported
- * see "search_condition" below
-
-=head2 SELECT
-
- SELECT select_clause
- FROM from_clause
- [ WHERE search_condition ]
- [ ORDER BY $ocol1 [ASC|DESC], ... $ocolN [ASC|DESC] ]
- [ LIMIT [start,] length ]
-
- * select clause ::=
- [DISTINCT|ALL] *
- | [DISTINCT|ALL] col1 [,col2, ... colN]
- | set_function1 [,set_function2, ... set_functionN]
-
- * set function ::=
- COUNT ( [DISTINCT|ALL] * )
- | COUNT | MIN | MAX | AVG | SUM ( [DISTINCT|ALL] col_name )
-
- * from clause ::=
- table1 [, table2, ... tableN]
- | table1 NATURAL [join_type] JOIN table2
- | table1 [join_type] table2 USING (col1,col2, ... colN)
- | table1 [join_type] JOIN table2 ON table1.colA = table2.colB
-
- * join type ::=
- INNER
- | [OUTER] LEFT | RIGHT | FULL
-
- * if join_type is not specified, INNER is the default
- * if DISTINCT or ALL is not specified, ALL is the default
- * if start position is omitted from LIMIT clause, position 0 is
- the default
- * ON clauses may only contain equal comparisons and AND combiners
- * self-joins are not currently supported
- * if implicit joins are used, the WHERE clause must contain
- and equijoin condition for each table
-
-
-=head2 SEARCH CONDITION
-
- [NOT] $val1 $op1 $val1 [ ... AND|OR $valN $opN $valN ]
-
-
-=head2 OPERATORS
-
- $op = | <> | < | > | <= | >=
- | IS NULL | IS NOT NULL | LIKE | CLIKE | BETWEEN | IN
-
- The "CLIKE" operator works exactly the same as the "LIKE"
- operator, but is case insensitive. For example:
-
- WHERE foo LIKE 'bar%' # succeeds if foo is "barbaz"
- # fails if foo is "BARBAZ" or "Barbaz"
-
- WHERE foo CLIKE 'bar%' # succeeds for "barbaz", "Barbaz", and "BARBAZ"
-
-
-=head2 STRING FUNCTIONS & MATH EXPRESSIONS
-
- String functions and math expressions are supported in WHERE
- clauses, in the VALUES part of an INSERT and UPDATE
- statements. They are not currently supported in the SELECT
- statement. For example:
-
- SELECT * FROM foo WHERE UPPER(bar) = 'baz' # SUPPORTED
-
- SELECT UPPER(foo) FROM bar # NOT SUPPORTED
-
-=over
-
-=item TRIM ( [ [LEADING|TRAILING|BOTH] ['trim_char'] FROM ] string )
-
-Removes all occurrences of <trim_char> from the front, back, or
-both sides of a string.
-
- BOTH is the default if neither LEADING nor TRAILING is specified.
-
- Space is the default if no trim_char is specified.
-
- Examples:
-
- TRIM( string )
- trims leading and trailing spaces from string
-
- TRIM( LEADING FROM str )
- trims leading spaces from string
-
- TRIM( 'x' FROM str )
- trims leading and trailing x's from string
-
-=item SUBSTRING( string FROM start_pos [FOR length] )
-
-Returns the substring starting at start_pos and extending for
-"length" character or until the end of the string, if no
-"length" is supplied. Examples:
-
- SUBSTRING( 'foobar' FROM 4 ) # returns "bar"
-
- SUBSTRING( 'foobar' FROM 4 FOR 2) # returns "ba"
-
-
-=item UPPER(string) and LOWER(string)
-
-These return the upper-case and lower-case variants of the string:
-
- UPPER('foo') # returns "FOO"
- LOWER('FOO') # returns "foo"
-
-=back
-
-=head2 Identifiers (table & column names)
-
-Regular identifiers (table and column names *without* quotes around them) are case INSENSITIVE so column foo, fOo, FOO all refer to the same column.
-
-Delimited identifiers (table and column names *with* quotes around them) are case SENSITIVE so column "foo", "fOo", "FOO" each refer to different columns.
-
-A delimited identifier is *never* equal to a regular identifer (so "foo" and foo are two different columns). But don't do that :-).
-
-Remember thought that, in DBD::CSV if table names are used directly as file names, the case sensitivity depends on the OS e.g. on Windows files named foo, FOO, and fOo are the same as each other while on Unix they are different.
-
-
-=head1 METHODS
-
-=head2 new()
-
-The new() method creates a SQL::Parser object which can then be
-used to parse, validate, or build SQL strings. It takes one
-required parameter -- the name of the SQL dialect that will
-define the rules for the parser. A second optional parameter is
-a reference to a hash which can contain additional attributes of
-the parser.
-
- use SQL::Parser;
- my $parser = SQL::Parser->new( $dialect_name, \%attrs );
-
-The dialect_name parameter is a string containing any valid
-dialect such as 'ANSI', 'AnyData', or 'CSV'. See the section on
-the dialect() method below for details.
-
-The attribute parameter is a reference to a hash that can
-contain error settings for the PrintError and RaiseError
-attributes. See the section below on the parse() method for
-details.
-
-An example:
-
- use SQL::Parser;
- my $parser = SQL::Parser->new('AnyData', {RaiseError=>1} );
-
- This creates a new parser that uses the grammar rules
- contained in the .../SQL/Dialects/AnyData.pm file and which
- sets the RaiseError attribute to true.
-
-For those needing backwards compatibility with SQL::Statement
-version 0.1x and lower, the attribute hash may also contain
-feature settings. See the section "FURTHER DETAILS - Backwards
-Compatibility" below for details.
-
-
-=head2 parse()
-
-Once a SQL::Parser object has been created with the new()
-method, the parse() method can be used to parse any number of
-SQL strings. It takes a single required parameter -- a string
-containing a SQL command. The SQL string may optionally be
-terminated by a semicolon. The parse() method returns a true
-value if the parse is successful and a false value if the parse
-finds SQL syntax errors.
-
-Examples:
-
- 1) my $success = $parser->parse('SELECT * FROM foo');
-
- 2) my $sql = 'SELECT * FROM foo';
- my $success = $parser->parse( $sql );
-
- 3) my $success = $parser->parse(qq!
- SELECT id,phrase
- FROM foo
- WHERE id < 7
- AND phrase <> 'bar'
- ORDER BY phrase;
- !);
-
- 4) my $success = $parser->parse('SELECT * FRoOM foo ');
-
-In examples #1,#2, and #3, the value of $success will be true
-because the strings passed to the parse() method are valid SQL
-strings.
-
-In example #4, however, the value of $success will be false
-because the string contains a SQL syntax error ('FRoOM' instead
-of 'FROM').
-
-In addition to checking the return value of parse() with a
-variable like $success, you may use the PrintError and
-RaiseError attributes as you would in a DBI script:
-
- * If PrintError is true, then SQL syntax errors will be sent as
- warnings to STDERR (i.e. to the screen or to a file if STDERR
- has been redirected). This is set to true by default which
- means that unless you specifically turn it off, all errors
- will be reported.
-
- * If RaiseError is true, then SQL syntax errors will cause the
- script to die, (i.e. the script will terminate unless wrapped
- in an eval). This is set to false by default which means
- that unless you specifically turn it on, scripts will
- continue to operate even if there are SQL syntax errors.
-
-Basically, you should leave PrintError on or else you will not
-be warned when an error occurs. If you are simply validating a
-series of strings, you will want to leave RaiseError off so that
-the script can check all strings regardless of whether some of
-them contain SQL errors. However, if you are going to try to
-execute the SQL or need to depend that it is correct, you should
-set RaiseError on so that the program will only continue to
-operate if all SQL strings use correct syntax.
-
-IMPORTANT NOTE #1: The parse() method only checks syntax, it
-does NOT verify if the objects listed actually exist. For
-example, given the string "SELECT model FROM cars", the parse()
-method will report that the string contains valid SQL but that
-will not tell you whether there actually is a table called
-"cars" or whether that table contains a column called 'model'.
-Those kinds of verifications can be performed by the
-SQL::Statement module, not by SQL::Parser by itself.
-
-IMPORTANT NOTE #2: The parse() method uses rules as defined by
-the selected dialect configuration file and the feature()
-method. This means that a statement that is valid in one
-dialect may not be valid in another. For example the 'CSV' and
-'AnyData' dialects define 'BLOB' as a valid data type but the
-'ANSI' dialect does not. Therefore the statement 'CREATE TABLE
-foo (picture BLOB)' would be valid in the first two dialects but
-would produce a syntax error in the 'ANSI' dialect.
-
-=head2 structure()
-
-After a SQL::Parser object has been created and the parse()
-method used to parse a SQL string, the structure() method
-returns the data structure of that string. This data structure
-may be passed on to other modules (e.g. SQL::Statement) or it
-may be printed out using, for example, the Data::Dumper module.
-
-The data structure contains all of the information in the SQL
-string as parsed into its various components. To take a simple
-example:
-
- $parser->parse('SELECT make,model FROM cars');
- use Data::Dumper;
- print Dumper $parser->structure;
-
-Would produce:
-
- $VAR1 = {
- 'column_names' => [
- 'make',
- 'model'
- ],
- 'command' => 'SELECT',
- 'table_names' => [
- 'cars'
- ]
- };
-
-Please see the section "FURTHER DETAILS -- Parse structures"
-below for further examples.
-
-=head2 build()
-
-This method is in progress and should be available soon.
-
-=head2 dialect()
-
- $parser->dialect( $dialect_name ); # load a dialect configuration file
- my $dialect = $parser->dialect; # get the name of the current dialect
-
- For example:
-
- $parser->dialect('AnyData'); # loads the AnyData config file
- print $parser->dialect; # prints 'AnyData'
-
- The $dialect_name parameter may be the name of any dialect
- configuration file on your system. Use the
- $parser->list('dialects') method to see a list of available
- dialects. At a minimum it will include "ANSI", "CSV", and
- "AnyData". For backwards compatiblity 'Ansi' is accepted as a
- synonym for 'ANSI', otherwise the names are case sensitive.
-
- Loading a new dialect configuration file erases all current
- parser features and resets them to those defined in the
- configuration file.
-
- See the section above on "Dialects" for details of these
- configuration files.
-
-=head2 feature()
-
-Features define the rules to be used by a specific parser
-instance. They are divided into the following classes:
-
- * valid_commands
- * valid_options
- * valid_comparison_operators
- * valid_data_types
- * reserved_words
-
-Within each class a feature name is either enabled or
-disabled. For example, under "valid_data_types" the name "BLOB"
-may be either disabled or enabled. If it is not eneabled
-(either by being specifically disabled, or simply by not being
-specified at all) then any SQL string using "BLOB" as a data
-type will throw a syntax error "Invalid data type: 'BLOB'".
-
-The feature() method allows you to enable, disable, or check the
-status of any feature.
-
- $parser->feature( $class, $name, 1 ); # enable a feature
-
- $parser->feature( $class, $name, 0 ); # disable a feature
-
- my $feature = $parser->feature( $class, $name ); # show status of a feature
-
- For example:
-
- $parser->feature('reserved_words','FOO',1); # make 'FOO' a reserved word
-
- $parser->feature('valid_data_types','BLOB',0); # disallow 'BLOB' as a
- # data type
-
- # determine if the LIKE
- # operator is supported
- my $LIKE = $parser->feature('valid_operators','LIKE');
-
-See the section below on "Backwards Compatibility" for use of
-the feature() method with SQL::Statement 0.1x style parameters.
-
-=head2 list()
-
-=head2 errstr()
-
-=head1 FURTHER DETAILS
-
-=head2 Dialect Configuration Files
-
-These will change completely when Tim finalizes the DBI get_info method.
-
-=head2 Parse Structures
-
-Here are some further examples of the data structures returned
-by the structure() method after a call to parse(). Only
-specific details are shown for each SQL instance, not the entire
-struture.
-
- 'SELECT make,model, FROM cars'
-
- command => 'SELECT',
- table_names => [ 'cars' ],
- column_names => [ 'make', 'model' ],
-
- 'CREATE TABLE cars ( id INTEGER, model VARCHAR(40) )'
-
- column_defs => {
- id => { data_type => INTEGER },
- model => { data_type => VARCHAR(40) },
- },
-
- 'SELECT DISTINCT make FROM cars'
-
- set_quantifier => 'DISTINCT',
-
- 'SELECT MAX (model) FROM cars'
-
- set_function => {
- name => 'MAX',
- arg => 'models',
- },
-
- 'SELECT * FROM cars LIMIT 5,10'
-
- limit_clause => {
- offset => 5,
- limit => 10,
- },
-
- 'SELECT * FROM vars ORDER BY make, model DESC'
-
- sort_spec_list => [
- { make => 'ASC' },
- { model => 'DESC' },
- ],
-
- "INSERT INTO cars VALUES ( 7, 'Chevy', 'Impala' )"
-
- values => [ 7, 'Chevy', 'Impala' ],
-
-
-=head2 Backwards Compatibility
-
-This module can be used in conjunction with SQL::Statement,
-version 0.2 and higher. Earlier versions of SQL::Statement
-included a SQL::Parser as a submodule that used slightly
-different syntax than the current version. The current version
-supports all of this earlier syntax although new users are
-encouraged to use the new syntax listed above. If the syntax
-listed below is used, the module should be able to be subclassed
-exactly as it was with the older SQL::Statement versions and
-will therefore not require any modules or scripts that used it
-to make changes.
-
-In the old style, features of the parser were accessed with this
-syntax:
-
- feature('create','type_blob',1); # allow BLOB as a data type
- feature('create','type_blob',0); # disallow BLOB as a data type
- feature('select','join',1); # allow multi-table statements
-
-The same settings could be acheieved in calls to new:
-
- my $parser = SQL::Parser->new(
- 'Ansi',
- {
- create => {type_blob=>1},
- select => {join=>1},
- },
- );
-
-Both of these styles of setting features are supported in the
-current SQL::Parser.
-
-=head1 ACKNOWLEDGEMENTS
-
-*Many* thanks to Ilya Sterin who wrote most of code for the
- build() method and who assisted on the parentheses parsing code
- and who proved a great deal of support, advice, and testing
- throughout the development of the module.
-
-=head1 AUTHOR & COPYRIGHT
-
- This module is copyright (c) 2001 by Jeff Zucker.
- All rights reserved.
-
- The module may be freely distributed under the same terms as
- Perl itself using either the "GPL License" or the "Artistic
- License" as specified in the Perl README file.
-
- Jeff can be reached at: jeff at vpservices.com.
-
-=cut
+######################################################################
+package SQL::Parser;
+######################################################################
+#
+# This module is copyright (c), 2001,2005 by Jeff Zucker.
+# All rights resered.
+#
+# It may be freely distributed under the same terms as Perl itself.
+# See below for help and copyright information (search for SYNOPSIS).
+#
+######################################################################
+
+use strict;
+use warnings;
+use vars qw($VERSION);
+use constant FUNCTION_NAMES => join '|', qw( TRIM SUBSTRING );
+
+$VERSION = '1.11';
+
+BEGIN { if( $ENV{SQL_USER_DEFS} ) { require SQL::UserDefs; } }
+eval { require 'Data/Dumper.pm'; $Data::Dumper::Indent=1};
+*bug = ($@) ? sub {warn @_} : sub { print Data::Dumper::Dumper(\@_) };
+
+#############################
+# PUBLIC METHODS
+#############################
+
+sub new {
+ my $class = shift;
+ my $dialect = shift || 'ANSI';
+ $dialect = 'ANSI' if uc $dialect eq 'ANSI';
+ $dialect = 'AnyData' if uc $dialect eq 'ANYDATA' or uc $dialect eq 'CSV';
+# $dialect = 'CSV' if uc $dialect eq 'CSV';
+ if ($dialect eq 'SQL::Eval') {
+ $dialect = 'AnyData';
+ }
+ my $flags = shift || {};
+ $flags->{"dialect"} = $dialect;
+ $flags->{"PrintError"} = 1 unless defined $flags->{"PrintError"};
+ my $self = bless_me($class,$flags);
+ $self->dialect( $self->{"dialect"} );
+ $self->set_feature_flags($self->{"select"},$self->{"create"});
+ bless $self,$class;
+ $self->LOAD("LOAD SQL::Statement::Functions");
+ return $self;
+}
+
+sub parse {
+ my $self = shift;
+ my $sql = shift;
+ $self->dialect( $self->{"dialect"} ) unless $self->{"dialect_set"};
+ $sql =~ s/^\s+//;
+ $sql =~ s/\s+$//;
+ $self->{"struct"} = {};
+ $self->{"tmp"} = {};
+ $self->{"original_string"} = $sql;
+ $self->{struct}->{"original_string"} = $sql;
+
+ ################################################################
+ #
+ # COMMENTS
+
+ # C-STYLE
+ #
+ my $comment_re = $self->{"comment_re"} || '(\/\*.*?\*\/)';
+ $self->{"comment_re"} = $comment_re;
+ my $starts_with_comment;
+ if ($sql =~ /^\s*$comment_re(.*)$/s) {
+ $self->{"comment"} = $1;
+ $sql = $2;
+ $starts_with_comment=1;
+ }
+ # SQL STYLE
+ #
+ if ($sql =~ /^\s*--(.*)(\n|$)/) {
+ $self->{"comment"} = $1;
+ return 1;
+ }
+ ################################################################
+
+ $sql = $self->clean_sql($sql);
+ my($com) = $sql =~ /^\s*(\S+)\s+/s ;
+ if (!$com) {
+ return 1 if $starts_with_comment;
+ return $self->do_err("Incomplete statement!");
+ }
+ $com = uc $com;
+ $self->{"opts"}->{"valid_commands"}->{CALL}=1;
+ $self->{"opts"}->{"valid_commands"}->{LOAD}=1;
+ if ($self->{"opts"}->{"valid_commands"}->{$com}) {
+ my $rv = $self->$com($sql);
+ delete $self->{"struct"}->{"literals"};
+# return $self->do_err("No table names found!")
+# unless $self->{"struct"}->{"table_names"};
+ return $self->do_err("No command found!")
+ unless $self->{"struct"}->{"command"};
+ if ( $self->{"struct"}->{join}
+ and scalar keys %{$self->{"struct"}->{join}}==0
+ ) {
+ delete $self->{"struct"}->{join};
+ }
+ $self->replace_quoted_ids();
+ for (@{$self->{struct}->{table_names}}) {
+ push @{$self->{struct}->{org_table_names}},$_;
+ }
+#
+# UPPER CASE TABLE NAMES
+#
+my @uTables = map {uc $_ } @{$self->{struct}->{table_names}};
+#
+# REMOVE schema.table infor if present
+#
+ @uTables = map { s/^.*\.([^\.]+)$/$1/;$_} @uTables;
+$self->{struct}->{table_names} = \@uTables unless $com eq 'CREATE';
+ if ($self->{struct}->{column_names}) {
+ for (@{$self->{struct}->{column_names}}) {
+ my $cn = $_;
+ $cn = uc $cn unless $cn =~ /^"/;
+ push @{$self->{struct}->{org_col_names}},
+ $self->{struct}->{ORG_NAME}->{$cn};
+ }
+ }
+$self->{struct}->{join}->{table_order}
+ = $self->{struct}->{table_names}
+ if $self->{struct}->{join}->{table_order}
+ and scalar(@{$self->{struct}->{join}->{table_order}}) == 0;
+@{$self->{struct}->{join}->{keycols}}
+ = map {uc $_ } @{$self->{struct}->{join}->{keycols}}
+ if $self->{struct}->{join}->{keycols};
+@{$self->{struct}->{join}->{shared_cols}}
+ = map {uc $_ } @{$self->{struct}->{join}->{shared_cols}}
+ if $self->{struct}->{join}->{shared_cols};
+##
+# For RR aliases, added quoted id protection from upper casing
+my @uCols = map { ($_=~/^"/)?$_:uc $_} @{$self->{struct}->{column_names}};
+##
+$self->{struct}->{column_names} = \@uCols unless $com eq 'CREATE';
+ if ($self->{original_string} =~ /Y\.\*/) {
+#use mylibs; zwarn $self; exit;
+ }
+# use Data::Dumper; warn Dumper $self->{struct} if $com eq 'SELECT';
+ if ($com eq 'SELECT') {
+ }
+ delete $self->{struct}->{join}
+ if $self->{struct}->{join}
+ and scalar keys %{$self->{struct}->{join}}==0;
+ return $rv;
+ }
+ else {
+ $self->{struct}={};
+ if ($ENV{SQL_USER_DEFS}) {
+ return SQL::UserDefs::user_parse($self,$sql);
+ }
+ return $self->do_err("Command '$com' not recognized or not supported!");
+ }
+}
+
+sub replace_quoted_ids {
+ my $self = shift;
+ my $id = shift;
+ return $id unless $self->{struct}->{quoted_ids};
+ if ($id) {
+ if ($id =~ /^\?QI(\d+)\?$/) {
+ return '"'.$self->{struct}->{quoted_ids}->[$1].'"';
+ }
+ else {
+ return $id;
+ }
+ }
+ return unless defined $self->{struct}->{table_names};
+ my @tables = @{$self->{struct}->{table_names}};
+ for my $t(@tables) {
+ if ($t =~ /^\?QI(.+)\?$/ ) {
+ $t = '"'.$self->{struct}->{quoted_ids}->[$1].'"';
+# $t = $self->{struct}->{quoted_ids}->[$1];
+ }
+ }
+ $self->{struct}->{table_names} = \@tables;
+ delete $self->{struct}->{quoted_ids};
+}
+
+
+sub structure { shift->{"struct"} }
+sub command { my $x = shift->{"struct"}->{command} || '' }
+
+sub feature {
+ my($self,$opt_class,$opt_name,$opt_value) = @_;
+ if (defined $opt_value) {
+ if ( $opt_class eq 'select' ) {
+ $self->set_feature_flags( {"join"=>$opt_value} );
+ }
+ elsif ( $opt_class eq 'create' ) {
+ $self->set_feature_flags( undef, {$opt_name=>$opt_value} );
+ }
+ else {
+ # patch from chromatic
+ $self->{"opts"}->{$opt_class}->{$opt_name} = $opt_value;
+ # $self->{$opt_class}->{$opt_name} = $opt_value;
+ }
+ }
+ else {
+ return $self->{"opts"}->{$opt_class}->{$opt_name};
+ }
+}
+
+sub errstr { shift->{"struct"}->{"errstr"} }
+
+sub list {
+ my $self = shift;
+ my $com = uc shift;
+ return () if $com !~ /COMMANDS|RESERVED|TYPES|OPS|OPTIONS|DIALECTS/i;
+ $com = 'valid_commands' if $com eq 'COMMANDS';
+ $com = 'valid_comparison_operators' if $com eq 'OPS';
+ $com = 'valid_data_types' if $com eq 'TYPES';
+ $com = 'valid_options' if $com eq 'OPTIONS';
+ $com = 'reserved_words' if $com eq 'RESERVED';
+ $self->dialect( $self->{"dialect"} ) unless $self->{"dialect_set"};
+
+ return sort keys %{ $self->{"opts"}->{$com} } unless $com eq 'DIALECTS';
+ my $dDir = "SQL/Dialects";
+ my @dialects;
+ for my $dir(@INC) {
+ local *D;
+
+ if ( opendir(D,"$dir/$dDir") ) {
+ @dialects = grep /.*\.pm$/, readdir(D);
+ last;
+ }
+ }
+ @dialects = map { s/\.pm$//; $_} @dialects;
+ return @dialects;
+}
+
+sub dialect {
+ my($self,$dialect) = @_;
+ return $self->{"dialect"} unless $dialect;
+ return $self->{"dialect"} if $self->{dialect_set};
+ $self->{"opts"} = {};
+ my $mod = "SQL/Dialects/$dialect.pm";
+ undef $@;
+ eval {
+ require "$mod";
+ };
+ return $self->do_err($@) if $@;
+ $mod =~ s/\.pm//;
+ $mod =~ s"/"::"g;
+ my @data = split /\n/, $mod->get_config;
+ my $feature;
+ for (@data) {
+ chomp;
+ s/^\s+//;
+ s/\s+$//;
+ next unless $_;
+ if (/^\[(.*)\]$/i) {
+ $feature = lc $1;
+ $feature =~ s/\s+/_/g;
+ next;
+ }
+ my $newopt = uc $_;
+ $newopt =~ s/\s+/ /g;
+ $self->{"opts"}->{$feature}->{$newopt} = 1;
+ }
+#
+# DAA precompute the predicate operator regex's
+#
+ my @allops = keys %{ $self->{"opts"}->{"valid_comparison_operators"} };
+#
+# complement operators
+#
+ my @notops;
+ for (@allops) {
+ push (@notops, $_)
+ if /NOT/i;
+ }
+ $self->{"opts"}->{"valid_comparison_NOT_ops_regex"} =
+ '^\s*(.+)\s+('. join('|', @notops) . ')\s+(.*)\s*$'
+ if scalar @notops;
+#
+# <>, <=, >= operators
+#
+ my @compops;
+ for (@allops) {
+ push (@compops, $_)
+ if /<=|>=|<>/;
+ }
+ $self->{"opts"}->{"valid_comparison_twochar_ops_regex"} =
+ '^\s*(.+)\s+(' . join('|', @compops) . ')\s+(.*)\s*$'
+ if scalar @compops;
+#
+# everything
+#
+ $self->{"opts"}->{"valid_comparison_ops_regex"} =
+ '^\s*(.+)\s+(' . join('|', @allops) . ')\s+(.*)\s*$'
+ if scalar @allops;
+#
+# end DAA
+#
+ $self->{"dialect"} = $dialect;
+ $self->{"dialect_set"}++;
+}
+
+##################################################################
+# SQL COMMANDS
+##################################################################
+
+####################################################
+# DROP TABLE <table_name>
+####################################################
+sub DROP {
+ my $self = shift;
+ my $stmt = shift;
+ my $table_name;
+ $self->{"struct"}->{"command"} = 'DROP';
+ if ($stmt =~ /^\s*DROP\s+TABLE\s+IF\s+EXISTS\s+(.*)$/si ) {
+ $stmt = "DROP TABLE $1";
+ $self->{"struct"}->{ignore_missing_table}=1;
+ }
+ if ($stmt =~ /^\s*DROP\s+(\S+)\s+(.+)$/si ) {
+ my $com2 = $1 || '';
+ $table_name = $2;
+ if ($com2 !~ /^TABLE$/i) {
+ return $self->do_err(
+ "The command 'DROP $com2' is not recognized or not supported!"
+ );
+ }
+ $table_name =~ s/^\s+//;
+ $table_name =~ s/\s+$//;
+ if ( $table_name =~ /(\S+) (RESTRICT|CASCADE)/i) {
+ $table_name = $1;
+ $self->{"struct"}->{"drop_behavior"} = uc $2;
+ }
+ }
+ else {
+ return $self->do_err( "Incomplete DROP statement!" );
+
+ }
+ return undef unless $self->TABLE_NAME($table_name);
+ $table_name = $self->replace_quoted_ids($table_name);
+ $self->{"tmp"}->{"is_table_name"} = {$table_name => 1};
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ return 1;
+}
+
+####################################################
+# DELETE FROM <table_name> WHERE <search_condition>
+####################################################
+sub DELETE {
+ my($self,$str) = @_;
+ $self->{"struct"}->{"command"} = 'DELETE';
+ $str =~ s/^DELETE\s+FROM\s+/DELETE /i; # Make FROM optional
+ my($table_name,$where_clause) = $str =~
+ /^DELETE (\S+)(.*)$/i;
+ return $self->do_err(
+ 'Incomplete DELETE statement!'
+ ) if !$table_name;
+ return undef unless $self->TABLE_NAME($table_name);
+ $self->{"tmp"}->{"is_table_name"} = {$table_name => 1};
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ $self->{"struct"}->{"column_names"} = ['*'];
+ $where_clause =~ s/^\s+//;
+ $where_clause =~ s/\s+$//;
+ if ($where_clause) {
+ $where_clause =~ s/^WHERE\s*(.*)$/$1/i;
+ return undef unless $self->SEARCH_CONDITION($where_clause);
+ }
+ return 1;
+}
+
+##############################################################
+# SELECT
+##############################################################
+# SELECT [<set_quantifier>] <select_list>
+# | <set_function_specification>
+# FROM <from_clause>
+# [WHERE <search_condition>]
+# [ORDER BY <order_by_clause>]
+# [LIMIT <limit_clause>]
+##############################################################
+
+sub SELECT {
+ my($self,$str) = @_;
+ $self->{"struct"}->{"command"} = 'SELECT';
+ my($from_clause,$where_clause,$order_clause,$limit_clause);
+ $str =~ s/^SELECT (.+)$/$1/i;
+ if ( $str =~ s/^(.+) LIMIT (.+)$/$1/i ) { $limit_clause = $2; }
+ if ( $str =~ s/^(.+) ORDER BY (.+)$/$1/i ) { $order_clause = $2; }
+ if ( $str =~ s/^(.+?) WHERE (.+)$/$1/i ) { $where_clause = $2; }
+ if ( $str =~ s/^(.+?) FROM (.+)$/$1/i ) { $from_clause = $2; }
+
+# else {
+# return $self->do_err("Couldn't find FROM clause in SELECT!");
+# }
+# return undef unless $self->FROM_CLAUSE($from_clause);
+ my $has_from_clause = $self->FROM_CLAUSE($from_clause) if $from_clause;
+
+ return undef unless $self->SELECT_CLAUSE($str);
+
+ if ($where_clause) {
+ return undef unless $self->SEARCH_CONDITION($where_clause);
+ }
+ if ($order_clause) {
+ return undef unless $self->SORT_SPEC_LIST($order_clause);
+ }
+ if ($limit_clause) {
+ return undef unless $self->LIMIT_CLAUSE($limit_clause);
+ }
+ if ( ( $self->{"struct"}->{join}->{"clause"}
+ and $self->{"struct"}->{join}->{"clause"} eq 'ON'
+ )
+ or ( $self->{"struct"}->{"multiple_tables"}
+ and !(scalar keys %{$self->{"struct"}->{join}})
+ ) ) {
+ return undef unless $self->IMPLICIT_JOIN();
+ }
+ return 1;
+}
+
+sub IMPLICIT_JOIN {
+ my $self = shift;
+ delete $self->{"struct"}->{"multiple_tables"};
+ if ( !$self->{"struct"}->{join}->{"clause"}
+ or $self->{"struct"}->{join}->{"clause"} ne 'ON'
+ ) {
+ $self->{"struct"}->{join}->{"type"} = 'INNER';
+ $self->{"struct"}->{join}->{"clause"} = 'IMPLICIT';
+ }
+ if (defined $self->{"struct"}->{"keycols"} ) {
+ my @keys;
+ my @keys2 = @keys = @{ $self->{"struct"}->{"keycols"} };
+ $self->{"struct"}->{join}->{"table_order"} = $self->order_joins(\@keys2);
+ @{$self->{"struct"}->{join}->{"keycols"}} = @keys;
+ delete $self->{"struct"}->{"keycols"};
+ }
+ else {
+ return $self->do_err("No equijoin condition in WHERE or ON clause");
+ }
+ return 1;
+}
+
+sub EXPLICIT_JOIN {
+ my $self = shift;
+ my $remainder = shift;
+ return undef unless $remainder;
+ my($tableA,$tableB,$keycols,$jtype,$natural);
+ if ($remainder =~ /^(.+?) (NATURAL|INNER|LEFT|RIGHT|FULL|UNION|JOIN)(.+)$/s){
+ $tableA = $1;
+ $remainder = $2.$3;
+ }
+ else {
+ ($tableA,$remainder) = $remainder =~ /^(\S+) (.*)/;
+ }
+ if ( $remainder =~ /^NATURAL (.+)/) {
+ $self->{"struct"}->{join}->{"clause"} = 'NATURAL';
+ $natural++;
+ $remainder = $1;
+ }
+ if ( $remainder =~
+ /^(INNER|LEFT|RIGHT|FULL|UNION) JOIN (.+)/
+ ) {
+ $jtype = $self->{"struct"}->{join}->{"clause"} = $1;
+ $remainder = $2;
+ $jtype = "$jtype OUTER" if $jtype !~ /INNER|UNION/;
+ }
+ if ( $remainder =~
+ /^(LEFT|RIGHT|FULL) OUTER JOIN (.+)/
+ ) {
+ $jtype = $self->{"struct"}->{join}->{"clause"} = $1 . " OUTER";
+ $remainder = $2;
+ }
+ if ( $remainder =~ /^JOIN (.+)/) {
+ $jtype = 'INNER';
+ $self->{"struct"}->{join}->{"clause"} = 'DEFAULT INNER';
+ $remainder = $1;
+ }
+ if ( $self->{"struct"}->{join} ) {
+ if ( $remainder && $remainder =~ /^(.+?) USING \(([^\)]+)\)(.*)/) {
+ $self->{"struct"}->{join}->{"clause"} = 'USING';
+ $tableB = $1;
+ my $keycolstr = $2;
+ $remainder = $3;
+ @$keycols = split /,/,$keycolstr;
+ }
+ if ( $remainder && $remainder =~ /^(.+?) ON (.+)/) {
+ $self->{"struct"}->{join}->{"clause"} = 'ON';
+ $tableB = $1;
+ my $keycolstr = $2;
+ $remainder = $3;
+ if ($keycolstr =~ / OR /i ) {
+ return $self->do_err(qq~Can't use OR in an ON clause!~,1);
+ }
+ @$keycols = split / AND /i,$keycolstr;
+#zzz
+return undef unless $self->TABLE_NAME_LIST($tableA.','.$tableB);
+# $self->{"tmp"}->{"is_table_name"}->{"$tableA"} = 1;
+# $self->{"tmp"}->{"is_table_name"}->{"$tableB"} = 1;
+ for (@$keycols) {
+ my %is_done;
+ my($arg1,$arg2) = split / = /;
+ my($c1,$c2)=($arg1,$arg2);
+ $c1 =~ s/^.*\.([^\.]+)$/$1/;
+ $c2 =~ s/^.*\.([^\.]+)$/$1/;
+ if ($c1 eq $c2) {
+ return undef unless $arg1 = $self->ROW_VALUE($c1);
+ if ( $arg1->{type} eq 'column' and !$is_done{$c1}
+ ){
+ push @{$self->{struct}->{keycols}},$arg1->{value};
+ $is_done{$c1}=1;
+ }
+ }
+ else {
+ return undef unless $arg1 = $self->ROW_VALUE($arg1);
+ return undef unless $arg2 = $self->ROW_VALUE($arg2);
+ if ( $arg1->{"type"}eq 'column'
+ and $arg2->{"type"}eq 'column'){
+ push @{ $self->{"struct"}->{"keycols"} }
+ , $arg1->{"value"};
+ push @{ $self->{"struct"}->{"keycols"} }
+ , $arg2->{"value"};
+ # delete $self->{"struct"}->{"where_clause"};
+ }
+ }
+ }
+ }
+ elsif ($remainder =~ /^(.+?)$/i) {
+ $tableB = $1;
+ $remainder = $2;
+ }
+ $remainder =~ s/^\s+// if $remainder;
+ }
+
+ if ($jtype) {
+ $jtype = "NATURAL $jtype" if $natural;
+ if ($natural and $keycols) {
+ return $self->do_err(
+ qq~Can't use NATURAL with a USING or ON clause!~
+ );
+ }
+ return undef unless $self->TABLE_NAME_LIST("$tableA,$tableB");
+ $self->{"struct"}->{join}->{"type"} = $jtype;
+ $self->{"struct"}->{join}->{"keycols"} = $keycols if $keycols;
+ return 1;
+ }
+ return $self->do_err("Couldn't parse explicit JOIN!");
+}
+
+sub SELECT_CLAUSE {
+ my($self,$str) = @_;
+ return undef unless $str;
+ if ($str =~ s/^(DISTINCT|ALL) (.+)$/$2/i) {
+ $self->{"struct"}->{"set_quantifier"} = uc $1;
+ }
+ if ($str =~ /[()]/) {
+ #return undef unless $self->SET_FUNCTION_SPEC($str);
+# $self->SET_FUNCTION_SPEC($str);
+ }
+# else {
+ return undef unless $self->SELECT_LIST($str);
+# }
+}
+
+sub FROM_CLAUSE {
+ my($self,$str) = @_;
+ return undef unless $str;
+ if ($str =~ / JOIN /i ) {
+ return undef unless $self->EXPLICIT_JOIN($str);
+ }
+ else {
+ return undef unless $self->TABLE_NAME_LIST($str);
+ }
+}
+
+sub INSERT {
+ my($self,$str) = @_;
+ my $col_str;
+ $str =~ s/^INSERT\s+INTO\s+/INSERT /i; # allow INTO to be optional
+ my($table_name,$val_str) = $str =~
+ /^INSERT\s+(.+?)\s+VALUES\s+\((.+?)\)$/i;
+ if ($table_name and $table_name =~ /[()]/ ) {
+ ($table_name,$col_str,$val_str) = $str =~
+ /^INSERT\s+(.+?)\s+\((.+?)\)\s+VALUES\s+\((.+?)\)$/i;
+ }
+ return $self->do_err('No table name specified!') unless $table_name;
+ return $self->do_err('Missing values list!') unless defined $val_str;
+ return undef unless $self->TABLE_NAME($table_name);
+ $self->{"struct"}->{"command"} = 'INSERT';
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ if ($col_str) {
+ return undef unless $self->COLUMN_NAME_LIST($col_str);
+ }
+ else {
+ $self->{"struct"}->{"column_names"} = ['*'];
+ }
+ return undef unless $self->LITERAL_LIST($val_str);
+ return 1;
+}
+
+###################################################################
+# UPDATE ::=
+#
+# UPDATE <table> SET <set_clause_list> [ WHERE <search_condition>]
+#
+###################################################################
+sub UPDATE {
+ my($self,$str) = @_;
+ $self->{"struct"}->{"command"} = 'UPDATE';
+ my($table_name,$remainder) = $str =~
+ /^UPDATE (.+?) SET (.+)$/i;
+ return $self->do_err(
+ 'Incomplete UPDATE clause'
+ ) if !$table_name or !$remainder;
+ return undef unless $self->TABLE_NAME($table_name);
+ $self->{"tmp"}->{"is_table_name"} = {$table_name => 1};
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ my($set_clause,$where_clause) = $remainder =~
+ /(.*?) WHERE (.*)$/i;
+ $set_clause = $remainder if !$set_clause;
+ return undef unless $self->SET_CLAUSE_LIST($set_clause);
+ if ($where_clause) {
+ return undef unless $self->SEARCH_CONDITION($where_clause);
+ }
+ my @vals = @{$self->{"struct"}->{"values"}};
+ my $num_val_placeholders=0;
+ for my $v(@vals) {
+ $num_val_placeholders++ if $v->{"type"} eq 'placeholder';
+ }
+ $self->{"struct"}->{"num_val_placeholders"}=$num_val_placeholders;
+ return 1;
+}
+
+############
+# FUNCTIONS
+############
+sub LOAD {
+ my($self,$str) = @_;
+ $self->{"struct"}->{"command"} = 'LOAD';
+ $self->{"struct"}->{"no_execute"} = 1;
+ my($package) = $str =~ /^LOAD\s+(.+)$/;
+ $str = $package;
+ $package =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
+ my $mod = $package . '.pm';
+ $mod =~ s~::~/~g;
+ eval { require $mod; };
+ die "Couldn't load '$package': $@\n" if $@;
+ my %subs = eval '%'.$package.'::';
+ for my $sub ( keys %subs ){
+ next unless $sub =~ /^SQL_FUNCTION_([A-Z_0-9]+)$/;
+ my $funcName = uc $1;
+ $self->{opts}->{function_names}->{$funcName}=1;
+ $self->{opts}->{function_defs}->{$funcName}->{sub} = {
+ value => $package.'::'.'SQL_FUNCTION_'.$funcName ,
+ type => 'string'
+ };
+ }
+ return 1;
+}
+
+sub CREATE_RAM_TABLE {
+ my $self = shift;
+ my $stmt = shift;
+ $self->{"struct"}->{"is_ram_table"} = 1;
+ $self->{"struct"}->{"command"} = 'CREATE_RAM_TABLE';
+ my($table_name,$table_element_def,%is_col_name);
+ if ($stmt =~ /^(\S+)\s+LIKE\s*(.+)$/si ) {
+ $table_name = $1;
+ $table_element_def = $2;
+ if ($table_element_def =~ /^(.*)\s+KEEP CONNECTION\s*$/i) {
+ $table_element_def = $1;
+ $self->{struct}->{ram_table_keep_connection}=1;
+ }
+ }
+ else {
+ return $self->CREATE("CREATE TABLE $stmt");
+ }
+ return undef unless $self->TABLE_NAME($table_name);
+ for my $col(split ',',$table_element_def) {
+ push @{$self->{"struct"}->{"column_names"}},$self->ROW_VALUE($col);
+ }
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ return 1;
+}
+sub CREATE_FUNCTION {
+ my $self = shift;
+ my $stmt = shift;
+ $self->{"struct"}->{"command"} = 'CREATE_FUNCTION';
+ $self->{"struct"}->{"no_execute"} = 1;
+ my($func,$subname);
+ $stmt =~ s/\s*EXTERNAL//i;
+ if( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi) {
+ $func = trim($1);
+ $subname = trim($2);
+ }
+ $func ||= $stmt;
+ $subname ||= $func;
+ if ($func =~ /^\?QI(\d+)\?$/) {
+ $func = $self->{struct}->{quoted_ids}->[$1];
+ }
+ if ($subname =~ /^\?QI(\d+)\?$/) {
+ $subname = $self->{struct}->{quoted_ids}->[$1];
+ }
+ $self->{opts}->{function_names}->{uc $func}=1;
+ $self->{opts}->{function_defs}->{uc $func}->{sub}
+ = {value=>$subname,type=>'string'};
+# bug($self->{opts});
+ return 1;
+}
+sub CALL {
+ my $self = shift;
+ my $stmt = shift;
+ $stmt =~ s/^CALL\s+(.*)/$1/i;
+ $self->{"struct"}->{"command"} = 'CALL';
+ $self->{"struct"}->{"procedure"} = $self->ROW_VALUE($stmt);
+ return 1;
+}
+
+#########
+# CREATE
+#########
+sub CREATE {
+ my $self = shift;
+ my $stmt = shift;
+ if ($stmt =~ /^\s*CREATE\s+FUNCTION (.+)$/si ) {
+ return $self->CREATE_FUNCTION($1);
+ }
+ # if ($stmt =~ /^\s*CREATE\s+RAM\s+TABLE\s+(.+)$/si ) {
+ $stmt =~ s/^CREATE (LOCAL|GLOBAL) /CREATE /si;
+ if ($stmt =~ /^\s*CREATE\s+(TEMP|TEMPORARY)\s+TABLE\s+(.+)$/si ) {
+ $stmt = "CREATE TABLE $2";
+ $self->{"struct"}->{"is_ram_table"} = 1;
+ # $self->{"struct"}->{"command"} = 'CREATE_RAM_TABLE';
+ # return $self->CREATE_RAM_TABLE($1);
+ }
+ $self->{"struct"}->{"command"} = 'CREATE';
+ my($table_name,$table_element_def,%is_col_name);
+ # if ($stmt =~ /^CREATE (LOCAL|GLOBAL) TEMPORARY TABLE(.*)$/si ) {
+ # $self->{"struct"}->{"table_type"} = "$1 TEMPORARY";
+ # $stmt = "CREATE TABLE$2";
+ # }
+ if ($stmt =~ /^(.*) ON COMMIT (DELETE|PRESERVE) ROWS\s*$/si ) {
+ $stmt = $1;
+ $self->{"struct"}->{"commit_behaviour"} = $2;
+# return $self->do_err(
+# "Can't specify commit behaviour for permanent tables."
+# )
+# if !defined $self->{"struct"}->{"table_type"}
+# or $self->{"struct"}->{"table_type"} !~ /TEMPORARY/;
+ }
+ if ($stmt =~ /^CREATE TABLE (\S+) \((.*)\)$/si ) {
+ $table_name = $1;
+ $table_element_def = $2;
+ }
+ elsif ($stmt =~ /^CREATE TABLE (\S+) AS (.*)$/si) {
+ $table_name = $1;
+ my $subquery = $2;
+ return undef unless $self->TABLE_NAME($table_name);
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ $self->{"struct"}->{"subquery"} = $subquery;
+ return 1;
+ }
+ else {
+ return $self->do_err( "Can't find column definitions!" );
+ }
+ return undef unless $self->TABLE_NAME($table_name);
+ $table_element_def =~ s/\s+\(/(/g;
+ my $primary_defined;
+ for my $col(split ',',$table_element_def) {
+ my($name,$type,$constraints)=($col =~/\s*(\S+)\s+(\S+)\s*(.*)/);
+ if (!$type) {
+ return $self->do_err( "Column definition is missing a data type!" );
+ }
+ return undef if !($self->IDENTIFIER($name));
+# if ($name =~ /^\?QI(.+)\?$/ ) {
+ $name = $self->replace_quoted_ids($name);
+# }
+ $constraints =~ s/^\s+//;
+ $constraints =~ s/\s+$//;
+ if ($constraints) {
+ $constraints =~ s/PRIMARY KEY/PRIMARY_KEY/i;
+ $constraints =~ s/NOT NULL/NOT_NULL/i;
+ my @c = split /\s+/, $constraints;
+ my %has_c;
+ for my $constr(@c) {
+ if ( $constr =~ /^\s*(UNIQUE|NOT_NULL|PRIMARY_KEY)\s*$/i ) {
+ my $cur_c = uc $1;
+ if ($has_c{$cur_c}++) {
+ return $self->do_err(
+ qq~Duplicate column constraint: '$constr'!~
+ );
+ }
+ if ($cur_c eq 'PRIMARY_KEY' and $primary_defined++ ) {
+ return $self->do_err(
+ qq~Can't have two PRIMARY KEYs in a table!~
+ );
+ }
+ $constr =~ s/_/ /g;
+ push @{$self->{"struct"}->{"column_defs"}->{"$name"}->{"constraints"} }, $constr;
+
+ }
+ else {
+ return $self->do_err("Unknown column constraint: '$constr'!");
+ }
+ }
+ }
+ $type = uc $type;
+ my $length;
+ if ( $type =~ /(.+)\((.+)\)/ ) {
+ $type = $1;
+ $length = $2;
+ }
+ if (!$self->{"opts"}->{"valid_data_types"}->{"$type"}) {
+ return $self->do_err("'$type' is not a recognized data type!");
+ }
+ $self->{"struct"}->{"column_defs"}->{"$name"}->{"data_type"} = $type;
+ $self->{"struct"}->{"column_defs"}->{"$name"}->{"data_length"} = $length;
+ push @{$self->{"struct"}->{"column_names"}},$name;
+ #push @{$self->{"struct"}->{ORG_NAME}},$name;
+ my $tmpname = $name;
+ $tmpname = uc $tmpname unless $tmpname =~ /^"/;
+ return $self->do_err("Duplicate column names!")
+ if $is_col_name{$tmpname}++;
+
+ }
+ $self->{"struct"}->{"table_names"} = [$table_name];
+ return 1;
+}
+
+
+###############
+# SQL SUBRULES
+###############
+
+sub SET_CLAUSE_LIST {
+ my $self = shift;
+ my $set_string = shift;
+ my @sets = split /,/,$set_string;
+ my(@cols, at vals);
+ for(@sets) {
+ my($col,$val) = split / = /,$_;
+ return $self->do_err('Incomplete SET clause!') if !defined $col or !defined $val;
+ push @cols, $col;
+ push @vals, $val;
+ }
+ return undef unless $self->COLUMN_NAME_LIST(join ',', at cols);
+ return undef unless $self->LITERAL_LIST(join ',', at vals);
+ return 1;
+}
+
+sub SET_QUANTIFIER {
+ my($self,$str) = @_;
+ if ($str =~ /^(DISTINCT|ALL)\s+(.*)$/si) {
+ $self->{"struct"}->{"set_quantifier"} = uc $1;
+ $str = $2;
+ }
+ return $str;
+}
+
+#
+# DAA v1.11
+# modify to transform || strings into
+# CONCAT(<expr>); note that we
+# only xform the topmost expressions;
+# if a concat is contained within a subfunction,
+# it should get handled by ROW_VALUE()
+#
+sub transform_concat {
+ my ($obj, $colstr) = @_;
+
+ pos($colstr) = 0;
+ my $parens = 0;
+ my $spos = 0;
+ my @concats = ();
+ my $alias = ($colstr=~s/^(.+)(\s+AS\s+\S+)$/$1/) ? $2 : '';
+
+ while ($colstr=~/\G.*?([\(\)\|])/gcs) {
+ if ($1 eq '(') {
+ $parens++;
+ }
+ elsif ($1 eq ')') {
+ $parens--;
+ }
+ elsif ((! $parens) &&
+ (substr($colstr, $-[1] + 1, 1) eq '|')) {
+#
+# its a concat outside of parens, push prior string on stack
+#
+ push @concats, substr($colstr, $spos, $-[1] - $spos);
+ $spos = $+[1] + 1;
+ pos($colstr) = $spos;
+ }
+ }
+#
+# no concats, return original
+#
+ return $colstr unless scalar @concats;
+#
+# don't forget the last one!
+#
+ push @concats, substr($colstr, $spos);
+ return 'CONCAT(' . join(', ', @concats) . ")$alias";
+}
+#
+# DAA v1.10
+# improved column list extraction
+# original doesn't seem to handle
+# commas within function argument lists
+#
+# DAA v1.11
+# modify to transform || strings into
+# CONCAT(<expr-list>)
+#
+sub extract_column_list {
+ my ($self, $colstr) = @_;
+
+ my @collist = ();
+ pos($colstr) = 0;
+ my $parens = 0;
+ my $spos = 0;
+ while ($colstr=~/\G.*?([\(\),])/gcs) {
+ if ($1 eq '(') {
+ $parens++;
+ }
+ elsif ($1 eq ')') {
+ $parens--;
+ }
+ elsif (! $parens) { # its a comma outside of parens
+ push @collist, substr($colstr, $spos, $-[1] - $spos);
+ $collist[-1]=~s/^\s+//;
+ $collist[-1]=~s/\s+$//;
+ return $self->do_err('Bad column list!')
+ if ($collist[-1] eq '');
+ $spos = $+[1];
+ }
+ }
+ return $self->do_err('Unbalanced parentheses!')
+ if $parens;
+#
+# don't forget the last one!
+#
+ push @collist, substr($colstr, $spos);
+ $collist[-1]=~s/^\s+//;
+ $collist[-1]=~s/\s+$//;
+ return $self->do_err('Bad column list!')
+ if ($collist[-1] eq '');
+#
+# scan for and convert string concats to CONCAT()
+#
+ foreach (0..$#collist) {
+ $collist[$_] = $self->transform_concat($collist[$_])
+ if ($collist[$_]=~/\|\|/);
+ }
+
+ return @collist;
+}
+
+sub SELECT_LIST {
+ my $self = shift;
+ my $col_str = shift;
+ if ( $col_str =~ /^\s*\*\s*$/ ) {
+ $self->{"struct"}->{"column_names"} = ['*'];
+ return 1;
+ }
+ my @col_list = $self->extract_column_list($col_str);
+ return undef unless scalar @col_list;
+
+ my(@newcols,$newcol,%aliases,$newalias);
+ for my $col (@col_list) {
+# DAA
+# need better alias test here, since AS is a common
+# keyword that might be used in a function
+#
+ my ($fld, $alias) = ($col=~/^(.+)\s+AS\s+([A-Z]\w*)$/i)
+ ? ($1, $2)
+ : ($col, undef);
+ $col = $fld;
+ if ($col =~ /^(\S+)\.\*$/) {
+ my $table = $1;
+ my %is_table_alias = %{$self->{"tmp"}->{"is_table_alias"}};
+ $table = $is_table_alias{$table} if $is_table_alias{$table};
+ $table = $is_table_alias{"\L$table"} if $is_table_alias{"\L$table"};
+ return undef unless $self->TABLE_NAME($table);
+ $table = $self->replace_quoted_ids($table);
+ push @newcols, "$table.*";
+ }
+ else {
+ #
+ # SELECT_LIST COLUMN IS A COMPUTED COLUMN WITH A SET FUNCTION
+ #
+ $newcol = $self->SET_FUNCTION_SPEC($col);
+ #
+ # SELECT_LIST COLUMN IS A COMPUTED COLUMN WITH A NON-SET FUNCTION
+ #
+ if (!$newcol) {
+ my $func_obj = $self->ROW_VALUE($col);
+ if ( ref($func_obj) =~ /::Function$/ ){
+# die "Functions in the SELECT LIST must have an alias!\n"
+# unless defined $alias;
+ $alias ||= $func_obj->{name};
+ $newcol = uc $alias;
+ $self->{struct}->{col_obj}->{$newcol}
+ = SQL::Statement::Util::Column->new(
+ uc $alias,[],$alias,$func_obj
+ );
+ }
+ #
+ # SELECT_LIST COLUMN IS NOT A COMPUTED COLUMN
+ #
+ else {
+ return undef unless $newcol = $self->COLUMN_NAME($col);
+ }
+ }
+ $newalias = $self->COLUMN_NAME($alias||$newcol);
+ $self->{struct}->{ORG_NAME}->{$newcol} = $newalias;
+ $aliases{uc $newalias} = $newcol;
+ push @newcols, $newcol;
+ if (!$alias) {
+ $alias = $fld;
+ $alias =~ s/^.*\.([^\.]+)$/$1/;
+ }
+ if (!$self->{struct}->{col_obj}->{$newcol}) {
+ $self->{struct}->{col_obj}->{uc $newcol}
+ = SQL::Statement::Util::Column->new(
+ uc $newcol,[],$alias
+ );
+
+ }
+ }
+ }
+ $self->{"struct"}->{"column_aliases"} = \%aliases;
+ $self->{"struct"}->{"column_names"} = \@newcols;
+ return 1;
+}
+
+sub SET_FUNCTION_SPEC {
+ my($self,$col_str) = @_;
+
+ my @funcs = split /,/, $col_str;
+ my %iscol;
+ for my $func(@funcs) {
+ if ($func =~ /^(COUNT|AVG|SUM|MAX|MIN) \((.*)\)\s*$/i ) {
+ my $set_function_name = uc $1;
+ my $set_function_arg = $2;
+ my $distinct;
+ if ( $set_function_arg =~ s/(DISTINCT|ALL) (.+)$/$2/i ) {
+ $distinct = uc $1;
+ $self->{"struct"}->{"set_quantifier"} = $distinct;
+ }
+ my $count_star = 1 if $set_function_name eq 'COUNT'
+ and $set_function_arg eq '*';
+
+ my $ok = $self->COLUMN_NAME($set_function_arg)
+ if !$count_star;
+
+ return undef
+ if !$count_star and !$ok;
+
+ if ($set_function_arg !~ /^"/) {
+ $set_function_arg = uc $set_function_arg;
+ }
+
+ push @{ $self->{"struct"}->{'set_function'}}, {
+ name => $set_function_name,
+ arg => $set_function_arg,
+ distinct => $distinct,
+ };
+# push( @{ $self->{"struct"}->{"column_names"} }, $set_function_arg)
+ return $set_function_arg
+ if !$iscol{$set_function_arg}++
+; # and ($set_function_arg ne '*');
+ }
+ else {
+ return undef;
+ # return $self->do_err("Bad set function before FROM clause.");
+ }
+ }
+}
+sub LIMIT_CLAUSE {
+ my($self,$limit_clause) = @_;
+# $limit_clause = trim($limit_clause);
+ $limit_clause =~ s/^\s+//;
+ $limit_clause =~ s/\s+$//;
+
+ return 1 if !$limit_clause;
+ my($offset,$limit,$junk) = split /,/, $limit_clause;
+ return $self->do_err('Bad limit clause!')
+ if (defined $limit and $limit =~ /[^\d]/)
+ or ( defined $offset and $offset =~ /[^\d]/ )
+ or defined $junk;
+ if (defined $offset and !defined $limit) {
+ $limit = $offset;
+ undef $offset;
+ }
+ $self->{"struct"}->{"limit_clause"} = {
+ limit => $limit,
+ offset => $offset,
+ };
+ return 1;
+}
+
+sub is_number {
+ my $x=shift;
+ return 0 if !defined $x;
+ return 1 if $x =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+ return 0;
+}
+
+sub SORT_SPEC_LIST {
+ my($self,$order_clause) = @_;
+ return 1 if !$order_clause;
+ my %is_table_name = %{$self->{"tmp"}->{"is_table_name"}};
+ my %is_table_alias = %{$self->{"tmp"}->{"is_table_alias"}};
+ my @ocols;
+ my @order_columns = split ',',$order_clause;
+ for my $col(@order_columns) {
+ my $newcol;
+ my $newarg;
+ if ($col =~ /\s*(\S+)\s+(ASC|DESC)/si ) {
+ $newcol = $1;
+ $newarg = uc $2;
+ }
+ elsif ($col =~ /^\s*(\S+)\s*$/si ) {
+ $newcol = $1;
+ }
+ else {
+ return $self->do_err(
+ 'Junk after column name in ORDER BY clause!'
+ );
+ }
+ return undef if !($newcol = $self->COLUMN_NAME($newcol));
+ if ($newcol =~ /^(.+)\..+$/s ) {
+ my $table = $1;
+ if ($table =~ /^'/) {
+ if (!$is_table_name{"$table"} and !$is_table_alias{"$table"} ) {
+ return $self->do_err( "Table '$table' in ORDER BY clause "
+ . "not in FROM clause."
+ );
+ }}
+ elsif (!$is_table_name{"\L$table"} and !$is_table_alias{"\L$table"} ) {
+ return $self->do_err( "Table '$table' in ORDER BY clause "
+ . "not in FROM clause."
+ );
+ }
+ }
+ push @ocols, {$newcol => $newarg};
+ }
+ $self->{"struct"}->{"sort_spec_list"} = \@ocols;
+ return 1;
+}
+
+sub SEARCH_CONDITION {
+ my $self = shift;
+ my $str = shift;
+ $str =~ s/^\s*WHERE (.+)/$1/;
+ $str =~ s/^\s+//;
+ $str =~ s/\s+$//;
+ return $self->do_err("Couldn't find WHERE clause!") unless $str;
+#
+# DAA
+# make these OO so subclasses can override them
+#
+ $str = $self->get_btwn( $str );
+ $str = $self->get_in( $str );
+#
+# DAA
+# add another abstract method so subclasses
+# can inject their own syntax transforms
+#
+ $str = $self->transform_syntax( $str );
+
+ my $open_parens = $str =~ tr/\(//;
+ my $close_parens = $str =~ tr/\)//;
+ if ($open_parens != $close_parens) {
+ return $self->do_err("Mismatched parentheses in WHERE clause!");
+ }
+ $str = nongroup_numeric( $self->nongroup_string( $str ) );
+ my $pred = $open_parens
+ ? $self->parens_search($str,[])
+ : $self->non_parens_search($str,[]);
+ return $self->do_err("Couldn't find predicate!") unless $pred;
+ $self->{"struct"}->{"where_clause"} = $pred;
+ return 1;
+}
+
+############################################################
+# UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE
+############################################################
+
+# get BETWEEN clause
+#
+# DAA
+# rewrite to remove recursion and optimize code
+#
+sub get_btwn {
+ my $self = shift; # DAA make OO for subclassing
+ my $str = shift;
+ while ($str =~ /^(.+?)\b(NOT\s+)?BETWEEN (.+)$/i ) {
+ my $front = $1;
+ my $back = $3;
+ my $not = $2 ? 1 : undef;
+#
+# scan the front piece to determine where
+# it really starts (esp wrt parens)
+#
+ my $col = ($front=~s/^(.+\b(AND|NOT|OR))\b(.+)$/$1/i) ? $3 : $front;
+ $front = ''
+ if ($col eq $front);
+#
+# check on the number of parens
+# we've got
+#
+ my $parens = 0;
+ $parens += ($1 eq '(') ? 1 : -1
+ while ($col=~/\G.*?([\(\)])/gcs);
+
+ return $self->do_err("Unmatched right parentheses!")
+ if ($parens < 0);
+#
+# trim leading parens if any
+#
+ pos($col) = 0;
+ while ($parens && ($col=~/\G.*?([\(\)])/gcs)) {
+ return $self->do_err("Unmatched right parentheses!")
+ if ($1 eq ')');
+
+ $parens--;
+ }
+
+ $front .= substr($col, 0, pos($col));
+ $col = substr($col, pos($col));
+
+ return $self->do_err("Incomplete BETWEEN predicate!")
+ unless ($back =~ s/^(.+?) AND (.+)$/$2/i);
+ my $val1 = $1;
+
+ my $val2 = ($back =~ s/^(.+?)( (AND|OR).+)$/$2/i) ? $1 : $back;
+ $back = ''
+ if ($val2 eq $back);
+#
+# look for closing parens to match any remaining open
+# parens
+#
+ if ($parens) {
+ $parens += ($1 eq '(') ? 1 : -1
+ while ($parens && ($val2=~/\G.*?([\(\)])/gcs));
+ $back = substr($val2, pos($val2)) . $back;
+ $val2 = substr($val2, 0, pos($val2));
+ }
+ elsif ($val2=~/\G.*?([\(\)])/gcs) {
+ $parens += ($1 eq '(') ? 1 : -1
+ while (($parens >= 0) && ($val2=~/\G.*?([\(\)])/gcs));
+ $back = substr($val2, pos($val2)) . $back;
+ $val2 = substr($val2, 0, pos($val2));
+ }
+
+ $str = $not ?
+ "$front ($col <= $val1 OR $col >= $val2) $back" :
+ "$front ($col > $val1 AND $col < $val2) $back";
+ }
+ return $str;
+}
+# get IN clause
+#
+# a IN (b,c) -> (a=b OR a=c)
+# a NOT IN (b,c) -> (a<>b AND a<>c)
+#
+sub get_in {
+ my $self = shift; # DAA make OO for subclassing
+ my $str = shift;
+ my $in_inside_parens = 0;
+#
+# DAA optimize regex
+# and fix to properly track parens
+#
+ while ($str =~ /^(.+?)\b(NOT\s+)?IN \((.+)$/i ) {
+ my($col, $contents);
+ my $front = $1;
+ my $back = $3;
+ my $not = $2 ? 1 : 0;
+#
+# scan the front piece to determine where
+# it really starts (esp wrt parens)
+#
+ my $pos = ($front=~/^.+\b(AND|NOT|OR)\b(.+)$/igcs) ? $-[2] : 0;
+ pos($front) = $pos; # reset
+#
+# this can be an arbitrary expression,
+# so scan for balanced parens
+#
+ $in_inside_parens += ($1 eq '(') ? 1 : -1
+ while ($front=~/\G.*?([\(\)])/gcs);
+
+ return $self->do_err("Unmatched right parentheses during IN processing!")
+ if ($in_inside_parens < 0);
+#
+# reset scanner so we can find the true beginning
+# of the expression
+#
+ pos($front) = $pos;
+ $in_inside_parens--,
+ $pos = $+[0]
+ while ($in_inside_parens && ($front=~/\G.*?\(/gcs));
+#
+# we've isolated the left expression
+#
+ $col = substr($front, $pos);
+ $front = substr($front, 0, $pos);
+#
+# now isolate the right expression list
+#
+ $in_inside_parens = 1; # for the opening paren
+
+ $in_inside_parens += ($1 eq '(') ? 1 : -1
+ while ($in_inside_parens &&
+ ($back=~/\G.*?([\(\)])/gcs));
+
+ $contents = substr($back, 0, $+[0] - 1);
+ $back = substr($back, $+[0]);
+
+ return $self->do_err("Unmatched left parentheses during IN processing!")
+ if ($in_inside_parens > 0);
+#
+# need a better arglist extractor
+#
+# my @vals = split /,/, $contents;
+#
+ my @vals = ();
+ my $spos = 0;
+ my $parens = 0;
+ my $epos = 0;
+ while ($contents=~/\G.*?([\(\),])/gcs) {
+ $epos = $+[0];
+ push(@vals, substr($contents, $spos, $epos - $spos - 1)),
+ $spos = $epos,
+ next
+ unless ($parens or ($1 ne ','));
+ $parens += ($1 eq '(') ? 1 : -1;
+ }
+#
+# don't forget the last argument
+#
+ $epos = length($contents),
+ push(@vals, substr($contents, $spos, $epos - $spos))
+ if ($spos != length($contents));
+
+ my ($op, $combiner) = $not ? ('<>', ' AND ') : ('=', ' OR ');
+ @vals = map { "$col $op $_" } @vals;
+ $str = "$front (" . join($combiner, @vals) . ") $back";
+ $str =~ s/\s+/ /g;
+#
+# DAA
+# removed recursion
+#
+# return $self->get_in($str);
+ }
+ $str =~ s/^\s+//;
+ $str =~ s/\s+$//;
+ $str =~ s/\(\s+/(/;
+ $str =~ s/\s+\)/)/;
+ return $str;
+}
+
+# groups clauses by nested parens
+#
+# DAA
+# rewrite to correct paren scan
+# and optimize code, and remove
+# recursion
+#
+sub parens_search {
+ my $self = shift;
+ my $str = shift;
+ my $predicates = shift;
+ my $index = scalar @$predicates;
+
+ # to handle WHERE (a=b) AND (c=d)
+ # but needs escape space to not foul up AND/OR
+
+# locate all open parens
+# locate all close parens
+# apply non_paren_search to contents of
+# inner parens
+
+ my $lparens = ($str=~tr/\(//);
+ my $rparens = ($str=~tr/\)//);
+ return $self->do_err('Unmatched ' .
+ (($lparens > $rparens) ? 'left' : 'right') .
+ ' parentheses!')
+ unless ($lparens == $rparens);
+
+ return $self->non_parens_search($str, $predicates)
+ unless $lparens;
+
+ my @lparens = ();
+ while ($str=~/\G.*?([\(\)])/gcs) {
+ push(@lparens, $-[1]),
+ next
+ if ($1 eq '(');
+#
+# got a close paren, so pop the position of matching
+# left paren and extract the expression, removing the
+# parens
+#
+ my $pos = pop @lparens;
+ my $predlen = $+[1] - $pos;
+ my $pred = substr($str, $pos+1, $predlen - 2);
+#
+# note that this will pass thru any prior ^$index^ xlation,
+# so we don't need to recurse to recover the predicate
+#
+ substr($str, $pos, $predlen) = $pred,
+ pos($str) = $pos + length($pred),
+ next
+ unless ($pred =~ / (AND|OR) /i );
+#
+# handle AND/OR
+#
+ push(@$predicates, substr($str, $pos+1, $predlen-2));
+ my $replacement = "^$#$predicates^";
+ substr($str, $pos, $predlen) = $replacement;
+ pos($str) = $pos + length($replacement);
+ }
+
+ return $self->non_parens_search($str,$predicates);
+}
+
+# creates predicates from clauses that either have no parens
+# or ANDs or have been previously grouped by parens and ANDs
+#
+# DAA
+# rewrite to fix paren scanning
+#
+sub non_parens_search {
+ my $self = shift;
+ my $str = shift;
+ my $predicates = shift;
+ my $neg = 0;
+ my $nots = {};
+
+ $neg = 1,
+ $nots = { pred => 1}
+ if ( $str =~ s/^NOT (\^.+)$/$1/i );
+
+ my( $pred1, $pred2, $op );
+ my $and_preds =[];
+ ($str,$and_preds) = group_ands($str);
+ $str = $and_preds->[$1]
+ if $str =~ /^\s*~(\d+)~\s*$/;
+
+ return $self->non_parens_search($$predicates[$1], $predicates)
+ if ($str=~/^\s*\^(\d+)\^\s*$/);
+
+ if ($str=~/\G(.*?)\s+(AND|OR)\s+(.*)$/igcs) {
+ ($pred1, $op, $pred2) = ($1, $2, $3);
+
+ if ($pred1=~/^\s*\^(\d+)\^\s*$/) {
+ $pred1 = $self->non_parens_search($$predicates[$1],$predicates);
+ }
+ else {
+ $pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
+ $pred1 = $self->non_parens_search($pred1,$predicates);
+ }
+#
+# handle pred2 as a full predicate
+#
+ $pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g;
+ $pred2 = $self->non_parens_search($pred2,$predicates);
+
+ return {
+ neg => $neg,
+ nots => $nots,
+ arg1 => $pred1,
+ op => uc $op,
+ arg2 => $pred2,
+ };
+ }
+#
+# terminal predicate
+# need to check for singleton functions here
+#
+ my $xstr = $str;
+ my ($k,$v);
+ if ($str=~/^\s*([A-Z]\w*)\s*\[/gcs) {
+#
+# we've got a function, check if its a singleton
+#
+ my $parens = 1;
+ my $spos = $-[1];
+ my $epos = 0;
+ $epos = $-[1],
+ $parens += ($1 eq '[') ? 1 : -1
+ while (($parens > 0) && ($str=~/\G.*?([\[\]])/gcs));
+ $k = substr($str, $spos, $epos - $spos + 1);
+ $k=~s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
+#
+# for now we assume our parens are balanced
+# now look for a predicate operator and a right operand
+#
+ $v = $1,
+ $v=~s/\?(\d+)\?/$self->{struct}{literals}[$1]/g
+ if ($str =~ /\G\s+\S+\s*(.+)\s*$/gcs);
+ }
+ else {
+ $xstr =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g;
+ ($k,$v) = $xstr =~ /^(\S+?)\s+\S+\s*(.+)\s*$/;
+ }
+ push @{ $self->{struct}{where_cols}{$k}}, $v
+ if defined $k;
+ return $self->PREDICATE($str);
+}
+
+# groups AND clauses that aren't already grouped by parens
+#
+sub group_ands{
+ my $str = shift;
+ my $and_preds = shift || [];
+ return($str,$and_preds)
+ unless $str =~ / AND / and $str =~ / OR /;
+
+ return $str,$and_preds
+ unless ($str =~ /^(.*?) AND (.*)$/i );
+
+ my($front, $back)=($1,$2);
+ my $index = scalar @$and_preds;
+ $front = $1
+ if ($front =~ /^.* OR (.*)$/i );
+
+ $back = $1
+ if ($back =~ /^(.*?) (OR|AND) .*$/i );
+
+ my $newpred = "$front AND $back";
+ push @$and_preds, $newpred;
+ $str =~ s/\Q$newpred/~$index~/i;
+ return group_ands($str,$and_preds);
+}
+
+# replaces string function parens with square brackets
+# e.g TRIM (foo) -> TRIM[foo]
+#
+# DAA update to support UDFs
+# and remove recursion
+#
+sub nongroup_string {
+ my $self = shift;
+ my $str = shift;
+#
+# add in any user defined functions
+#
+ my $f = FUNCTION_NAMES;
+ $f .= '|' . uc $_
+ foreach (keys %{$self->{opts}{function_names}});
+#
+# we need a scan here to permit arbitrarily nested paren
+# arguments to functions
+#
+ my $parens = 0;
+ my $pos;
+ my @lparens = ();
+ while ($str=~/\G.*?((($f)\s*\()|[\(\)])/igcs) {
+ if ($1 eq ')') {
+#
+# close paren, see if any pending function open
+# paren matches it
+#
+ $parens--;
+ $pos = $+[0],
+ substr($str, $+[0]-1, 1) = ']',
+ pos($str) = $pos,
+ pop @lparens
+ if (@lparens && ($lparens[-1] == $parens));
+ }
+ elsif ($1 eq '(') {
+#
+# just an open paren, count it and go on
+#
+ $parens++;
+ }
+ else {
+#
+# new function definition, capture its open paren
+# also uppercase the function name
+#
+ $pos = $+[0];
+ substr($str, $-[3], length($3)) = uc $3;
+ substr($str, $+[0]-1, 1) = '[';
+ pos($str) = $pos;
+ push @lparens, $parens;
+ $parens++;
+ }
+ }
+
+# return $self->do_err('Unmatched ' .
+# (($parens > 0) ? 'left' : 'right') . ' parentheses!')
+# if $parens;
+#
+# DAA
+# remove scoped recursion
+#
+# return ( $str =~ /($f)\s*\(/i ) ?
+# nongroup_string($str) : $str;
+ return $str;
+}
+
+# replaces math parens with square brackets
+# e.g (4-(6+7)*9) -> MATH[4-MATH[6+7]*9]
+#
+sub nongroup_numeric {
+ my $str = shift;
+ my $has_op;
+#
+# DAA
+# optimize regex
+#
+ if ( $str =~ /\(([\w \*\/\+\-\[\]\?]+)\)/ ) {
+ my $match = $1;
+ if ($match !~ /(LIKE |IS|BETWEEN|IN)/i ) {
+ my $re = quotemeta($match);
+ $str =~ s/\($re\)/MATH\[$match\]/;
+ }
+ else {
+ $has_op++;
+ }
+ }
+#
+# DAA
+# remove scoped recursion
+#
+ return ( !$has_op and $str =~ /\(([\w \*\/\+\-\[\]\?]+)\)/ ) ?
+ nongroup_numeric($str) : $str;
+}
+############################################################
+
+
+#########################################################
+# LITERAL_LIST ::= <literal> [,<literal>]
+#########################################################
+sub LITERAL_LIST {
+ my $self = shift;
+ my $str = shift;
+ my @tokens = split /,/, $str;
+ my @values;
+ for my $tok(@tokens) {
+ my $val = $self->ROW_VALUE($tok);
+ return $self->do_err(
+ qq('$tok' is not a valid value or is not quoted!)
+ ) unless $val;
+ push @values, $val;
+ }
+ $self->{"struct"}->{"values"} = \@values;
+ return 1;
+}
+
+
+###################################################################
+# LITERAL ::= <quoted_string> | <question mark> | <number> | NULL
+###################################################################
+sub LITERAL {
+ my $self = shift;
+ my $str = shift;
+#
+# DAA
+# strip parens (if any)
+#
+ $str = $1
+ while ($str=~/^\s*\(\s*(.+)\s*\)\s*$/);
+
+ return 'null' if $str =~ /^NULL$/i; # NULL
+# return 'empty_string' if $str =~ /^~E~$/i; # NULL
+ if ($str eq '?') {
+ $self->{struct}->{num_placeholders}++;
+ return 'placeholder';
+ }
+# return 'placeholder' if $str eq '?'; # placeholder question mark
+ return 'string' if $str =~ /^'.*'$/s; # quoted string
+ return 'number' if $str =~ # number
+ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
+ return undef;
+}
+###################################################################
+# PREDICATE
+###################################################################
+sub PREDICATE {
+ my $self = shift;
+ my $str = shift;
+
+ my($arg1, $op, $arg2, $opexp);
+
+ $opexp = $self->{opts}{valid_comparison_NOT_ops_regex},
+ ($arg1,$op,$arg2) = $str =~ /$opexp/i
+ if $self->{opts}{valid_comparison_NOT_ops_regex};
+
+ $opexp = $self->{opts}{valid_comparison_twochar_ops_regex},
+ ($arg1,$op,$arg2) = $str =~ /$opexp/i
+ if (!defined($op) && $self->{opts}{valid_comparison_twochar_ops_regex});
+
+ $opexp = $self->{opts}{valid_comparison_ops_regex},
+ ($arg1,$op,$arg2) = $str =~ /$opexp/i
+ if (!defined($op) && $self->{opts}{valid_comparison_ops_regex});
+
+ $op = uc $op;
+
+ #
+ ### USER-DEFINED PREDICATE
+ #
+ $arg1 = $str,
+
+ $op = 'USER_DEFINED',
+ $arg2 = '' unless (defined $arg1 && defined $op && defined $arg2);
+
+# my $uname = $self->is_func($arg1);
+# if (!$uname) {
+ # $arg1 =~ s/^(\S+).*$/$1/;
+# return $self->do_err("Bad predicate: '$arg1'!");
+# }
+
+ my $negated = 0; # boolean value showing if predicate is negated
+ my %not; # hash showing elements modified by NOT
+ #
+ # e.g. "NOT bar = foo" -> %not = (arg1=>1)
+ # "bar NOT LIKE foo" -> %not = (op=>1)
+ # "NOT bar NOT LIKE foo" -> %not = (arg1=>1,op=>1);
+ # "NOT bar IS NOT NULL" -> %not = (arg1=>1,op=>1);
+ # "bar = foo" -> %not = undef;
+ #
+ $not{arg1}++
+ if ( $arg1 =~ s/^NOT (.+)$/$1/i );
+
+ $not{op}++
+ if ( $op =~ s/^(.+) NOT$/$1/i
+ || $op =~ s/^NOT (.+)$/$1/i );
+
+ $negated = 1
+ if %not and scalar keys %not == 1;
+
+ return undef
+ unless $arg1 = $self->ROW_VALUE($arg1);
+
+ if ($op ne 'USER_DEFINED') { # USER-PREDICATE;
+ return undef
+ unless $arg2 = $self->ROW_VALUE($arg2);
+ }
+
+ push(@{ $self->{"struct"}->{"keycols"} }, $arg1->{"value"}),
+ push(@{ $self->{"struct"}->{"keycols"} }, $arg2->{"value"})
+ if ( ref($arg1)eq 'HASH' and ($arg1->{"type"}||'') eq 'column'
+ and ($arg2->{"type"}||'') eq 'column'
+ and $op eq '=');
+
+ return {
+ neg => $negated,
+ nots => \%not,
+ arg1 => $arg1,
+ op => $op,
+ arg2 => $arg2,
+ };
+}
+
+sub undo_string_funcs {
+ my $self = shift;
+ my $str = shift;
+ my $f = FUNCTION_NAMES;
+#
+# don't forget our UDFs
+#
+ $f .= '|' . uc $_
+ foreach (keys %{$self->{opts}{function_names}});
+#
+# eliminate recursion:
+# we have to scan for closing brackets, since we may
+# have intervening MATH elements with brackets
+#
+ my $brackets = 0;
+ my $pos;
+ my @lbrackets = ();
+ while ($str=~/\G.*?((($f)\s*\[)|[\[\]])/igcs) {
+ if ($1 eq ']') {
+#
+# close paren, see if any pending function open
+# paren matches it
+#
+ $brackets--;
+ $pos = $+[0],
+ substr($str, $+[0]-1, 1) = ')',
+ pos($str) = $pos,
+ pop @lbrackets
+ if (@lbrackets && ($lbrackets[-1] == $brackets));
+ }
+ elsif ($1 eq '[') {
+#
+# just an open paren, count it and go on
+#
+ $brackets++;
+ }
+ else {
+#
+# new function definition, capture its open paren
+# also uppercase the function name
+#
+ $pos = $+[0];
+ substr($str, $-[3], length($3)) = uc $3;
+ substr($str, $+[0]-1, 1) = '(';
+ pos($str) = $pos;
+ push @lbrackets, $brackets;
+ $brackets++;
+ }
+ }
+
+# return undo_string_funcs($str)
+# if ($str =~ /($f)\[/);
+
+ return $str;
+}
+
+sub undo_math_funcs {
+ my $str = shift;
+#
+# eliminate recursion
+#
+ 1 while ($str =~ s/MATH\[([^\]\[]+?)\]/($1)/);
+
+# return undo_math_funcs($str)
+# if ($str =~ /MATH\[/);
+
+ return $str;
+}
+#
+# DAA
+# need better nested function/parens handling
+#
+sub extract_func_args {
+ my ($self, $value) = @_;
+
+ my @final_args = ();
+ my $spos = 0;
+ my $parens = 0;
+ my $epos = 0;
+ my $delim = 0;
+ while ($value=~/\G.*?([\(\),])/gcs) {
+ $epos = $+[0];
+ $delim = $1;
+ push(@final_args,
+ $self->ROW_VALUE(substr($value,$spos,$epos-$spos-1))),
+ $spos = $epos,
+ next
+ unless ($parens or ($delim ne ','));
+
+ $parens += ($delim eq '(') ? 1 : -1
+ unless ($delim eq ',');
+ }
+#
+# don't forget the last argument
+#
+ $epos = length($value),
+ push(@final_args,
+ $self->ROW_VALUE(substr($value, $spos, $epos - $spos)))
+ if ($spos != length($value));
+ return @final_args;
+}
+
+###################################################################
+# ROW_VALUE ::= <literal> | <column_name>
+###################################################################
+sub ROW_VALUE {
+ my $self = shift;
+ my $str = shift;
+
+ $str=~s/^\s+//;
+ $str=~s/\s+$//;
+ $str = $self->undo_string_funcs($str);
+ $str = undo_math_funcs($str);
+
+ # USER-DEFINED FUNCTION
+ #
+ my $user_func_name = $str;
+ my $user_func_args = '';
+#
+# DAA
+# need better paren check here
+#
+# if ($str =~ /^(\S+)\s*(.*)\s*$/ ) {
+ if ($str =~ /^([^\s\(]+)\s*(.*)\s*$/ ) {
+ $user_func_name = uc $1;
+ $user_func_args = $2;
+#
+# convert operator-like function to
+# parenthetical format
+#
+ if ($self->{opts}->{function_names}->{$user_func_name}
+ and $user_func_args !~ /^\(.*\)$/) {
+ $str = "$user_func_name ($user_func_args)";
+ }
+ }
+ else {
+ $user_func_name =~ s/^(\S+).*$/$1/;
+ }
+ if ( $self->{opts}->{function_names}->{uc $user_func_name}
+ and $user_func_name !~ /(TRIM|SUBSTRING)/i
+ ) {
+ my($name, $value) = ($user_func_name,'');
+ if ($str =~ /^(\S+)\s*\((.+)\)\s*$/i ) {
+ $name = uc $1;
+ $value = $2;
+ }
+ if ($self->{opts}->{function_names}->{$name}) {
+
+#
+# DAA
+# need a better argument extractor, since it can
+# contain arbitrary (possibly parenthesized)
+# expressions/functions
+#
+# if ($value =~ /\(/ ) {
+# $value = $self->ROW_VALUE($value);
+# }
+# my @args = split ',',$value;
+
+ my @final_args = $self->extract_func_args($value);
+ my $usr_sub = $self->{opts}->{"function_defs"}->{$name}->{"sub"}
+ if $self->{opts}->{function_defs}
+ and $self->{opts}->{function_defs}->{$name};
+ $self->{struct}->{procedure} = {};
+ use SQL::Statement::Util;
+ return SQL::Statement::Util::Function->new(
+ $name,
+ $usr_sub->{value},
+ \@final_args,
+ ) if $usr_sub;
+# return {
+# type => 'function',
+# name => $name,
+# value => {
+# value => \@final_args,
+# type => 'multiple_args',
+# },
+# usr_sub => $usr_sub,
+# };
+ }
+ }
+ my $type;
+
+ # MATH
+ #
+ if ($str =~ /[\*\+\-\/]/ ) {
+ my @vals;
+ my $i=-1;
+ $str =~ s/([^\s\*\+\-\/\)\(]+)/push @vals,$1;$i++;"?$i?"/ge;
+ my @newvalues;
+ for (@vals) {
+ my $val = $self->ROW_VALUE($_);
+ if ($val && $val->{"type"} !~ /number|column|placeholder/) {
+ return $self->do_err(qq[
+ String '$val' not allowed in Numeric expression!
+ ]);
+ }
+ push @newvalues,$val;
+ }
+ return {
+ type => 'function',
+ name => 'numeric_exp',
+ str => $str,
+ vals => \@newvalues,
+ }
+ }
+
+ # SUBSTRING (value FROM start [FOR length])
+ #
+ if ($str =~ /^SUBSTRING \((.+?) FROM (.+)\)\s*$/i ) {
+ my $name = 'SUBSTRING';
+ my $start = $2;
+ my $value = $self->ROW_VALUE($1);
+ my $length;
+ if ($start =~ /^(.+?) FOR (.+)$/i) {
+ $start = $1;
+ $length = $2;
+ $length = $self->ROW_VALUE($length);
+ }
+ $start = $self->ROW_VALUE($start);
+ $str =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
+ return $self->do_err(
+ "Can't use a string as a SUBSTRING position: '$str'!")
+ if $start->{"type"} eq 'string'
+ or ($start->{"length"} and $start->{"length"}->{"type"} eq 'string');
+ return undef unless $value;
+ return $self->do_err(
+ "Can't use a number in SUBSTRING: '$str'!")
+ if $value->{"type"} eq 'number';
+ return {
+ "type" => 'function',
+ "name" => $name,
+ "value" => $value,
+ "start" => $start,
+ "length" => $length,
+ };
+ }
+
+ # TRIM ( [ [TRAILING|LEADING|BOTH] ['char'] FROM ] value )
+ #
+ if ($str =~ /^(TRIM) \((.+)\)\s*$/i ) {
+ my $name = uc $1;
+ my $value = $2;
+ my($trim_spec,$trim_char);
+ if ($value =~ /^(.+) FROM ([^\(\)]+)$/i ) {
+ my $front = $1;
+ $value = $2;
+ if ($front =~ /^\s*(TRAILING|LEADING|BOTH)(.*)$/i ) {
+ $trim_spec = uc $1;
+ $trim_char = $2;
+ $trim_char =~ s/^\s+//;
+ $trim_char =~ s/\s+$//;
+ undef $trim_char if length($trim_char)==0;
+ }
+ else {
+ $trim_char = $front;
+ $trim_char =~ s/^\s+//;
+ $trim_char =~ s/\s+$//;
+ }
+ }
+ $trim_char ||= '';
+ $trim_char =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
+ $value = $self->ROW_VALUE($value);
+ return undef unless $value;
+ $str =~ s/\?(\d+)\?/$self->{"struct"}->{"literals"}->[$1]/g;
+ my $value_type = $value->{type} if ref $value eq 'HASH';
+ $value_type = $value->[0] if ref $value eq 'ARRAY';
+ return $self->do_err(
+ "Can't use a number in TRIM: '$str'!")
+ if $value_type and $value_type eq 'number';
+ return {
+ type => 'function',
+ name => $name,
+ value => $value,
+ trim_spec => $trim_spec,
+ trim_char => $trim_char,
+ };
+ }
+
+ # UNKNOWN FUNCTION
+ if ( $str =~ /^(\S+) \(/ ) {
+ die "Unknown function '$1'\n";
+ }
+
+ # STRING CONCATENATION
+ #
+ if ($str =~ /\|\|/ ) {
+ my @vals = split / \|\| /,$str;
+ my @newvals;
+ for my $val(@vals) {
+ my $newval = $self->ROW_VALUE($val);
+ return undef unless $newval;
+ return $self->do_err(
+ "Can't use a number in string concatenation: '$str'!")
+ if $newval->{"type"} eq 'number';
+ push @newvals,$newval;
+ }
+ return {
+ type => 'function',
+ name => 'str_concat',
+ value => \@newvals,
+ };
+ }
+
+ # NULL, PLACEHOLDER, NUMBER
+ #
+ if ( $type = $self->LITERAL($str) ) {
+ undef $str if $type eq 'null';
+# if ($type eq 'empty_string') {
+# $str = '';
+# $type = 'string';
+# }
+ $str = '' if $str and $str eq q('');
+ return { type => $type, value => $str };
+ }
+
+ # QUOTED STRING LITERAL
+ #
+ if ($str =~ /\?(\d+)\?/) {
+ return { type =>'string',
+ value => $self->{"struct"}->{"literals"}->[$1] };
+ }
+ # COLUMN NAME
+ #
+ return undef unless $str = $self->COLUMN_NAME($str);
+ if ( $str =~ /^(.*)\./ && !$self->{"tmp"}->{"is_table_name"}->{"\L$1"}
+ and !$self->{"tmp"}->{"is_table_alias"}->{"\L$1"} ) {
+ return $self->do_err(
+ "Table '$1' in WHERE clause not in FROM clause!"
+ );
+ }
+# push @{ $self->{"struct"}->{"where_cols"}},$str
+# unless $self->{"tmp"}->{"where_cols"}->{"$str"};
+ $self->{"tmp"}->{"where_cols"}->{"$str"}++;
+ return { type => 'column', value => $str };
+}
+
+###############################################
+# COLUMN NAME ::= [<table_name>.] <identifier>
+###############################################
+
+sub COLUMN_NAME {
+ my $self = shift;
+ my $str = shift;
+ my($table_name,$col_name);
+ if ( $str =~ /^\s*(\S+)\.(\S+)$/s ) {
+ if (!$self->{"opts"}->{"valid_options"}->{"SELECT_MULTIPLE_TABLES"}) {
+ return $self->do_err('Dialect does not support multiple tables!');
+ }
+ $table_name = $1;
+ $col_name = $2;
+ return undef unless $table_name = $self->TABLE_NAME($table_name);
+ $table_name = $self->replace_quoted_ids($table_name);
+ my $ref;
+ if ($table_name =~ /^"/) { #"
+ if (!$self->{"tmp"}->{"is_table_name"}->{"$table_name"}
+ and !$self->{"tmp"}->{"is_table_alias"}->{"$table_name"}
+ ) {
+ $self->do_err(
+ "Table '$table_name' referenced but not found in FROM list!"
+ );
+ return undef;
+ }
+ }
+ elsif (!$self->{"tmp"}->{"is_table_name"}->{"\L$table_name"}
+ and !$self->{"tmp"}->{"is_table_alias"}->{"\L$table_name"}
+ ) {
+ $self->do_err(
+ "Table '$table_name' referenced but not found in FROM list!"
+ );
+ return undef;
+ }
+ }
+ else {
+ $col_name = $str;
+ }
+ $col_name =~ s/^\s+//;
+ $col_name =~ s/\s+$//;
+# my $user_func = $col_name;
+# $user_func =~ s/^(\S+).*$/$1/;
+# undef $user_func unless $self->{opts}->{function_names}->{uc $user_func};
+# if (!$user_func) {
+ return undef unless $col_name eq '*'
+ or $self->IDENTIFIER($col_name);
+# }
+ #
+ # MAKE COL NAMES ALL UPPER CASE UNLESS IS DELIMITED IDENTIFIER
+ my $orgcol = $col_name;
+
+ if ($col_name =~ /^\?QI(\d+)\?$/) {
+ $col_name = $self->replace_quoted_ids($col_name);
+ }
+ else {
+ $col_name = uc $col_name unless $self->{struct}->{command} eq 'CREATE'
+ ##############################################
+ #
+ # JZ addition to RR's alias patch
+ #
+ or $col_name =~ /^"/;
+
+ }
+ #
+ $col_name = $self->{struct}->{column_aliases}->{$col_name}
+ if $self->{struct}->{column_aliases}->{$col_name};
+# $orgcol = $self->replace_quoted_ids($orgcol);
+ ##############################################
+
+ if ($table_name) {
+ my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"};
+ $table_name = $alias if defined $alias;
+ $table_name = uc $table_name;
+ $col_name = "$table_name.$col_name";
+ }
+ return $col_name;
+}
+
+#########################################################
+# COLUMN NAME_LIST ::= <column_name> [,<column_name>...]
+#########################################################
+sub COLUMN_NAME_LIST {
+ my $self = shift;
+ my $col_str = shift;
+ my @col_list = split ',',$col_str;
+ if (!(scalar @col_list)) {
+ return $self->do_err('Missing column name list!');
+ }
+ my @newcols;
+ my $newcol;
+ for my $col(@col_list) {
+ $col =~ s/^\s+//;
+ $col =~ s/\s+$//;
+# return undef if !($newcol = $self->COLUMN_NAME(trim($col)));
+ return undef if !($newcol = $self->COLUMN_NAME($col));
+ push @newcols, $newcol;
+ }
+ $self->{"struct"}->{"column_names"} = \@newcols;
+ return 1;
+}
+
+
+#####################################################
+# TABLE_NAME_LIST := <table_name> [,<table_name>...]
+#####################################################
+sub TABLE_NAME_LIST {
+ my $self = shift;
+ my $table_name_str = shift;
+ my %aliases = ();
+ my @tables;
+ $table_name_str =~ s/(\?\d+\?),/$1:/g; # fudge commas in functions
+ my @table_names = split ',', $table_name_str;
+ if ( scalar @table_names > 1
+ and !$self->{"opts"}->{"valid_options"}->{'SELECT_MULTIPLE_TABLES'}
+ ) {
+ return $self->do_err('Dialect does not support multiple tables!');
+ }
+ my %is_table_alias;
+ for my $table_str(@table_names) {
+ $table_str =~ s/(\?\d+\?):/$1,/g; # unfudge commas in functions
+ $table_str =~ s/\s+\(/\(/g; # fudge spaces in functions
+ my($table,$alias);
+ my(@tstr) = split /\s+/,$table_str;
+ if (@tstr == 1) { $table = $tstr[0]; }
+ elsif (@tstr == 2) { $table = $tstr[0]; $alias = $tstr[1]; }
+ elsif (@tstr == 3) {
+ return $self->do_err("Can't find alias in FROM clause!")
+ unless uc($tstr[1]) eq 'AS';
+ $table = $tstr[0]; $alias = $tstr[2];
+ }
+ else {
+ return $self->do_err("Can't find table names in FROM clause!")
+ }
+ $table =~ s/\(/ \(/g; # unfudge spaces in functions
+ my $u_name = $table;
+ $u_name =~ s/^(\S+)\s*(.*$)/$1/;
+ my $u_args=$2;
+# $u_name = uc $u_name;
+# if ($self->{opts}->{function_names}->{$u_name}) {
+ if ($u_name = $self->is_func($u_name) ) {
+# my $u_func = $self->ROW_VALUE($table);
+ $u_args = " $u_args" if $u_args;
+ my $u_func = $self->ROW_VALUE($u_name.$u_args);
+ $self->{"struct"}->{"table_func"}->{$u_name} = $u_func;
+ $self->{"struct"}->{"temp_table"} = 1;
+ $table = $u_name;
+ }
+ else {
+ return undef unless $self->TABLE_NAME($table);
+ }
+ $table = $self->replace_quoted_ids($table);
+ push @tables, $table;
+ if ($alias) {
+ return undef unless $self->TABLE_NAME($alias);
+ $alias = $self->replace_quoted_ids($alias);
+ if ($alias =~ /^"/) {
+ push @{$aliases{$table}},"$alias";
+ $is_table_alias{"$alias"}=$table;
+ }
+ else {
+ push @{$aliases{$table}},"\L$alias";
+ $is_table_alias{"\L$alias"}=$table;
+ }
+ }
+ }
+ my %is_table_name = map { lc $_ => 1 } @tables;
+ $self->{"tmp"}->{"is_table_alias"} = \%is_table_alias;
+ $self->{"tmp"}->{"is_table_name"} = \%is_table_name;
+ $self->{"struct"}->{"table_names"} = \@tables;
+ $self->{"struct"}->{"table_alias"} = \%aliases;
+ $self->{"struct"}->{"multiple_tables"} = 1 if @tables > 1;
+ return 1;
+}
+
+sub is_func(){
+ my($self,$name) =@_;
+ $name =~ s/^(\S+).*$/$1/;
+ return $name if $self->{opts}->{function_names}->{$name};
+ return uc $name if $self->{opts}->{function_names}->{uc $name};
+}
+
+#############################
+# TABLE_NAME := <identifier>
+#############################
+sub TABLE_NAME {
+ my $self = shift;
+ my $table_name = shift;
+ if( $table_name =~ /^(.+?)\.([^\.]+)$/ ) {
+ my $schema = $1; # ignored
+ $table_name = $2;
+ }
+ if ($table_name =~ /\s*(\S+)\s+\S+/s) {
+ return $self->do_err("Junk after table name '$1'!");
+ }
+ $table_name =~ s/\s+//s;
+ if (!$table_name) {
+ return $self->do_err('No table name specified!');
+ }
+ return $table_name if $self->IDENTIFIER($table_name);
+# return undef if !($self->IDENTIFIER($table_name));
+# return 1;
+}
+
+
+###################################################################
+# IDENTIFIER ::= <alphabetic_char> { <alphanumeric_char> | _ }...
+#
+# and must not be a reserved word or over 128 chars in length
+###################################################################
+sub IDENTIFIER {
+ my $self = shift;
+ my $id = shift;
+ if ($id =~ /^\?QI(.+)\?$/ ) {
+ return 1;
+ }
+ return 1 if $id =~ /^".+?"$/s; # QUOTED IDENTIFIER
+ if( $id =~ /^(.+)\.([^\.]+)$/ ) {
+ my $schema = $1; # ignored
+ $id = $2;
+ }
+ my $err = "Bad table or column name '$id' "; # BAD CHARS
+ if ($id =~ /\W/) {
+ $err .= "has chars not alphanumeric or underscore!";
+ return $self->do_err( $err );
+ }
+ if ($id =~ /^_/ or $id =~ /^\d/) { # BAD START
+ $err .= "starts with non-alphabetic character!";
+ return $self->do_err( $err );
+ }
+ if ( length $id > 128 ) { # BAD LENGTH
+ $err .= "contains more than 128 characters!";
+ return $self->do_err( $err );
+ }
+ $id = uc $id;
+ if ( $self->{"opts"}->{"reserved_words"}->{$id} ) { # BAD RESERVED WORDS
+ $err .= "is a SQL reserved word!";
+ return $self->do_err( $err );
+ }
+ return 1;
+}
+
+########################################
+# PRIVATE METHODS AND UTILITY FUNCTIONS
+########################################
+sub order_joins {
+ my $self = shift;
+ my $links = shift;
+ for my $link(@$links) {
+ if ($link !~ /\./) {
+ return [];
+ }
+ }
+ @$links = map { s/^(.+)\..*$/$1/; $1; } @$links;
+ my @all_tables;
+ my %relations;
+ my %is_table;
+ while (@$links) {
+ my $t1 = shift @$links;
+ my $t2 = shift @$links;
+ return undef unless defined $t1 and defined $t2;
+ push @all_tables, $t1 unless $is_table{$t1}++;
+ push @all_tables, $t2 unless $is_table{$t2}++;
+ $relations{$t1}{$t2}++;
+ $relations{$t2}{$t1}++;
+ }
+ my @tables = @all_tables;
+ my @order = shift @tables;
+ my %is_ordered = ( $order[0] => 1 );
+ my %visited;
+ while(@tables) {
+ my $t = shift @tables;
+ my @rels = keys %{$relations{$t}};
+ for my $t2(@rels) {
+ next unless $is_ordered{$t2};
+ push @order, $t;
+ $is_ordered{$t}++;
+ last;
+ }
+ if (!$is_ordered{$t}) {
+ push @tables, $t if $visited{$t}++ < @all_tables;
+ }
+ }
+ return $self->do_err(
+ "Unconnected tables in equijoin statement!"
+ ) if @order < @all_tables;
+ return \@order;
+}
+
+sub bless_me {
+ my $class = shift;
+ my $self = shift || {};
+ return bless $self, $class;
+}
+
+# PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW
+#
+#
+sub set_feature_flags {
+ my($self,$select,$create) = @_;
+ if (defined $select) {
+ delete $self->{"select"};
+ $self->{"opts"}->{"valid_options"}->{"SELECT_MULTIPLE_TABLES"} =
+ $self->{"opts"}->{"select"}->{join} = $select->{join};
+ }
+ if (defined $create) {
+ delete $self->{"create"};
+ for my $key(keys %$create) {
+ my $type = $key;
+ $type =~ s/type_(.*)/\U$1/;
+ $self->{"opts"}->{"valid_data_types"}->{"$type"} =
+ $self->{"opts"}->{"create"}->{"$key"} = $create->{"$key"};
+ }
+ }
+}
+
+sub clean_sql {
+ my $self = shift;
+ my $sql = shift;
+ my $fields;
+ my $i=-1;
+ my $e = '\\';
+ $e = quotemeta($e);
+
+ #
+ # patch from cpan at goess.org, adds support for col2=''
+ #
+ #
+ # $sql =~ s~'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge;
+ $sql =~ s~(?<!')'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge;
+ #
+ @$fields = map { s/''/\\'/g; $_ } @$fields;
+ if ( $sql =~ tr/[^\\]'// % 2 == 1 ) {
+ $sql =~ s/^.*\?(.+)$/$1/;
+ die "Mismatched single quote before: '$sql'\n";
+ }
+ if ($sql =~ /\?\?(\d)\?/) {
+ $sql = $fields->[$1];
+ die "Mismatched single quote: '$sql\n";
+ }
+ @$fields = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$fields;
+
+ #
+ # From Steffen G. to correctly return newlines from $dbh->quote;
+ #
+ @$fields = map { s/([^\\])\\r/$1\r/g; $_ } @$fields;
+ @$fields = map { s/([^\\])\\n/$1\n/g; $_ } @$fields;
+
+ $self->{"struct"}->{"literals"} = $fields;
+
+ my $qids;
+ $i=-1;
+ $e = q/""/;
+# $sql =~ s~"(([^"$e]|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
+ $sql =~ s~"(([^"]|"")+)"~push(@$qids,$1);$i++;"?QI$i?"~ge;
+ #@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids;
+ $self->{"struct"}->{"quoted_ids"} = $qids if $qids;
+
+# $sql =~ s~'(([^'\\]|\\.)+)'~push(@$fields,$1);$i++;"?$i?"~ge;
+# @$fields = map { s/\\'/'/g; s/^'(.*)'$/$1/; $_} @$fields;
+#print "$sql [@$fields]\n";# if $sql =~ /SELECT/;
+
+## before line 1511
+ my $comment_re = $self->{"comment_re"};
+# if ( $sql =~ s/($comment_re)//gs) {
+# $self->{"comment"} = $1;
+# }
+ if ( $sql =~ /(.*)$comment_re$/s) {
+ $sql = $1;
+ $self->{"comment"} = $2;
+ }
+ if ($sql =~ /^(.*)--(.*)(\n|$)/) {
+ $sql = $1;
+ $self->{"comment"} = $2;
+ }
+
+ $sql =~ s/\n/ /g;
+ $sql =~ s/\s+/ /g;
+ $sql =~ s/(\S)\(/$1 (/g; # ensure whitespace before (
+ $sql =~ s/\)(\S)/) $1/g; # ensure whitespace after )
+ $sql =~ s/\(\s*/(/g; # trim whitespace after (
+ $sql =~ s/\s*\)/)/g; # trim whitespace before )
+ #
+ # $sql =~ s/\s*\(/(/g; # trim whitespace before (
+ # $sql =~ s/\)\s*/)/g; # trim whitespace after )
+ for my $op( qw( = <> < > <= >= \|\|) ) {
+ $sql =~ s/(\S)$op/$1 $op/g;
+ $sql =~ s/$op(\S)/$op $1/g;
+ }
+ $sql =~ s/< >/<>/g;
+ $sql =~ s/< =/<=/g;
+ $sql =~ s/> =/>=/g;
+ $sql =~ s/\s*,/,/g;
+ $sql =~ s/,\s*/,/g;
+ $sql =~ s/^\s+//;
+ $sql =~ s/\s+$//;
+ return $sql;
+}
+
+sub trim {
+ my $str = shift or return '';
+ $str =~ s/^\s+//;
+ $str =~ s/\s+$//;
+ return $str;
+}
+
+sub do_err {
+ my $self = shift;
+ my $err = shift;
+ my $errtype = shift;
+ my @c = caller 4;
+ $err = "$err\n\n";
+# $err = $errtype ? "DIALECT ERROR: $err in $c[3]"
+# : "SQL ERROR: $err in $c[3]";
+ $err = $errtype ? "DIALECT ERROR: $err"
+ : "SQL ERROR: $err";
+ $self->{"struct"}->{"errstr"} = $err;
+ #$self->{"errstr"} = $err;
+ warn $err if $self->{"PrintError"};
+ die $err if $self->{"RaiseError"};
+ return undef;
+}
+#
+# DAA
+# abstract method so subclasses can provide
+# their own syntax transformations
+#
+sub transform_syntax {
+ my ($self, $str) = @_;
+ return $str;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ SQL::Parser -- validate and parse SQL strings
+
+=head1 SYNOPSIS
+
+ use SQL::Parser; # CREATE A PARSER OBJECT
+ my $parser = SQL::Parser->new( $dialect, \%attrs );
+
+ my $success = $parser->parse( $sql_string ); # PARSE A SQL STRING &
+ if ($success) { # DISPLAY RESULTING DATA
+ use Data::Dumper; # STRUCTURE
+ print Dumper $parser->structure;
+ }
+
+ $parser->feature( $class, $name, $value ); # SET OR FIND STATUS OF
+ my $has_feature = $parser->feature( $class, $name ); # A PARSER FEATURE
+
+ $parser->dialect( $dialect_name ); # SET OR FIND STATUS OF
+ my $current_dialect = $parser->dialect; # A PARSER DIALECT
+
+ print $parser->errstr; # DISPLAY CURRENT ERROR
+ # STRING
+
+
+=head1 DESCRIPTION
+
+ SQL::Parser is a parser and sytax validator for a
+ small but useful subset of SQL (Structured Query Language). It
+ accepts SQL strings and returns either a detailed error message
+ if the syntax is invalid or a data structure containing the
+ results of the parse if the syntax is valid.
+
+ The module can be used in batch mode to validate a series of
+ statements, or as middle-ware for DBI drivers or other related
+ projects. When combined with SQL::Statement version 0.2 or
+ greater, the module can be used to actually perform the SQL
+ commands on a variety of file formats using DBD::AnyData, or
+ DBD::CSV, or DBD::Excel.
+
+ The module makes use of a variety of configuration files
+ located in the SQL/Dialects directory, each of which is
+ essentially a simple text file listing things like supported
+ data types, reserved words, and other features specific to a
+ given dialect of SQL. These features can also be turned on or
+ off during program execution.
+
+=head1 SUPPORTED SQL SYNTAX
+
+This module is meant primarly as a base class for DBD drivers
+and as such concentrates on a small but useful subset of SQL 92.
+It does *not* in any way pretend to be a complete SQL 92 parser.
+The module will continue to add new supported syntax, currently,
+this is what is supported:
+
+=head2 Summary of supported SQL syntax
+
+B<SQL Statements>
+
+ CREATE [TEMP] TABLE <table> <column_def_clause>
+ CREATE [TEMP] TABLE <table> AS <select statement>
+ CREATE [TEMP] TABLE <table> AS IMPORT()
+ CREATE FUNCTION <user_defined_function> [ NAME <perl_subroutine> ]
+ DELETE FROM <table> [<where_clause>]
+ DROP TABLE [IF EXISTS] <table>
+ INSERT [INTO] <table> [<column_list>] VALUES <value_list>
+ LOAD <user_defined_functions_module>
+ SELECT <function>
+ SELECT <select_clause>
+ <from_clause>
+ [<where_clause>]
+ [ ORDER BY ocol1 [ASC|DESC], ... oclN [ASC|DESC]] ]
+ [ LIMIT [start,] length ]
+ UPDATE <table> SET <set_clause> [<where_clause>]
+
+B<Explict Join Qualifiers>
+
+ NATURAL, INNER, OUTER, LEFT, RIGHT, FULL
+
+B<Built-in Functions>
+
+ * Aggregate : MIN, MAX, AVG, SUM, COUNT
+ * Date/Time : CURRENT_DATE, CURRENT_TIME, CURRENT_TIMESTAMP
+ * String : CHAR_LENGTH, CONCAT, COALESCE, DECODE, LOWER, POSITION,
+ REGEX, REPLACE, SOUNDEX, SUBSTRING, TRIM, UPPER
+
+B<Special Utility Functions>
+
+ * IMPORT - imports a table from an external RDBMS or perl structure
+ * RUN - prepares & executes statements in a file of SQL statements
+
+B<Operators and Predicates>
+
+ = , <> , < , > , <= , >= , IS [NOT] NULL , LIKE , CLIKE , IN , BETWEEN
+
+B<Identifiers> and B<Aliases>
+
+ * regular identifiers are case insensitive (though see note on table names)
+ * delimited identifiers (inside double quotes) are case sensitive
+ * column and table aliases are supported
+
+B<Concatenation>
+
+ * use either ANSI SQL || or the CONCAT() function
+ * e.g. these are the same: {foo || bar} {CONCAT(foo,bar)}
+
+B<Comments>
+
+ * comments must occur before or after statements, can't be embedded
+ * SQL-style single line -- and C-style multi-line /* */ comments are supported
+
+B<NULLs>
+
+ * currently NULLs and empty strings are identical, but this will change
+ * use {col IS NULL} to find NULLs, not {col=''} (though both currently work)
+
+See below for further details.
+
+=head2 CREATE TABLE
+
+Creates permanenet and in-memory tables.
+
+ CREATE [TEMP] TABLE <table_name> ( <column_definitions> )
+ CREATE [TEMP] TABLE <table_name> AS <select statement>
+ CREATE [TEMP] TABLE <table_name> AS IMPORT()
+
+Column definitions are standard SQL column names, types, and constraints, see L<Column Definitions>.
+
+ # create a permanent table
+ #
+ $dbh->do("CREATE TABLE qux (id INT PRIMARY KEY,word VARCHAR(30))");
+
+The "AS SELECT" clause creates and populates the new table using the data and column structure specified in the select statement.
+
+ # create and populate a table from a query to two other tables
+ #
+ $dbh->do("CREATE TABLE qux AS SELECT id,word FROM foo NATURAL JOIN bar");
+
+If the optional keyword TEMP (or its synonym TEMPORARY) is used, the table will be an in-memory table, available for the life of the current database handle or until a DROP TABLE command is issued.
+
+ # create a temporary table
+ #
+ $dbh->do("CREATE TEMP TABLE qux (id INT PRIMARY KEY,word VARCHAR(30))");
+
+TEMP tables can be modified with SQL commands but the updates are not automatically reflected back to any permanent tables they may be associated with. To save a TEMP table - just use an AS SELECT clause:
+
+ $dbh = DBI->connect( 'dbi:CSV:' );
+ $dbh->do("CREATE TEMP TABLE qux_temp AS (id INT, word VARCHAR(30))");
+ #
+ # ... modify qux_temp with INSERT, UPDATE, DELETE statements, then save it
+ #
+ $dbh->do("CREATE TABLE qux_permanent AS SELECT * FROM qux_temp");
+
+Tables, both temporary and permanent may also be created directly from perl arrayrefs and from heterogeneous queries to any DBI accessible data source, see the IMPORT() function.
+
+
+ CREATE [ {LOCAL|GLOBAL} TEMPORARY ] TABLE $table
+ (
+ $col_1 $col_type1 $col_constraints1,
+ ...,
+ $col_N $col_typeN $col_constraintsN,
+ )
+ [ ON COMMIT {DELETE|PRESERVE} ROWS ]
+
+ * col_type must be a valid data type as defined in the
+ "valid_data_types" section of the dialect file for the
+ current dialect
+
+ * col_constriaints may be "PRIMARY KEY" or one or both of
+ "UNIQUE" and/or "NOT NULL"
+
+ * IMPORTANT NOTE: temporary tables, data types and column
+ constraints are checked for syntax violations but are
+ currently otherwise *IGNORED* -- they are recognized by
+ the parser, but not by the execution engine
+
+ * The following valid ANSI SQL92 options are not currently
+ supported: table constraints, named constraints, check
+ constriants, reference constraints, constraint
+ attributes, collations, default clauses, domain names as
+ data types
+
+=head2 DROP TABLE
+
+ DROP TABLE $table [ RESTRICT | CASCADE ]
+
+ * IMPORTANT NOTE: drop behavior (cascade or restrict) is
+ checked for valid syntax but is otherwise *IGNORED* -- it
+ is recognized by the parser, but not by the execution
+ engine
+
+=head2 INSERT INTO
+
+ INSERT INTO $table [ ( $col1, ..., $colN ) ] VALUES ( $val1, ... $valN )
+
+ * default values are not currently supported
+ * inserting from a subquery is not currently supported
+
+=head2 DELETE FROM
+
+ DELETE FROM $table [ WHERE search_condition ]
+
+ * see "search_condition" below
+
+=head2 UPDATE
+
+ UPDATE $table SET $col1 = $val1, ... $colN = $valN [ WHERE search_condition ]
+
+ * default values are not currently supported
+ * see "search_condition" below
+
+=head2 SELECT
+
+ SELECT select_clause
+ FROM from_clause
+ [ WHERE search_condition ]
+ [ ORDER BY $ocol1 [ASC|DESC], ... $ocolN [ASC|DESC] ]
+ [ LIMIT [start,] length ]
+
+ * select clause ::=
+ [DISTINCT|ALL] *
+ | [DISTINCT|ALL] col1 [,col2, ... colN]
+ | set_function1 [,set_function2, ... set_functionN]
+
+ * set function ::=
+ COUNT ( [DISTINCT|ALL] * )
+ | COUNT | MIN | MAX | AVG | SUM ( [DISTINCT|ALL] col_name )
+
+ * from clause ::=
+ table1 [, table2, ... tableN]
+ | table1 NATURAL [join_type] JOIN table2
+ | table1 [join_type] table2 USING (col1,col2, ... colN)
+ | table1 [join_type] JOIN table2 ON table1.colA = table2.colB
+
+ * join type ::=
+ INNER
+ | [OUTER] LEFT | RIGHT | FULL
+
+ * if join_type is not specified, INNER is the default
+ * if DISTINCT or ALL is not specified, ALL is the default
+ * if start position is omitted from LIMIT clause, position 0 is
+ the default
+ * ON clauses may only contain equal comparisons and AND combiners
+ * self-joins are not currently supported
+ * if implicit joins are used, the WHERE clause must contain
+ and equijoin condition for each table
+
+=head2 SEARCH CONDITION
+
+ [NOT] $val1 $op1 $val1 [ ... AND|OR $valN $opN $valN ]
+
+
+=head2 OPERATORS
+
+ $op = | <> | < | > | <= | >=
+ | IS NULL | IS NOT NULL | LIKE | CLIKE | BETWEEN | IN
+
+ The "CLIKE" operator works exactly the same as the "LIKE"
+ operator, but is case insensitive. For example:
+
+ WHERE foo LIKE 'bar%' # succeeds if foo is "barbaz"
+ # fails if foo is "BARBAZ" or "Barbaz"
+
+ WHERE foo CLIKE 'bar%' # succeeds for "barbaz", "Barbaz", and "BARBAZ"
+
+=head2 BUILT-IN AND USER-DEFINED FUNCTIONS
+
+ There are many built-in functions and you can also create your
+ own new functions from perl subroutines. See L<SQL::Statement::Functions>
+ for documentation of functions.
+
+=head2 Identifiers (table & column names)
+
+Regular identifiers (table and column names *without* quotes around them)
+are case INSENSITIVE so column foo, fOo, FOO all refer to the same column.
+
+Delimited identifiers (table and column names *with* quotes around them) are
+case SENSITIVE so column "foo", "fOo", "FOO" each refer to different columns.
+
+A delimited identifier is *never* equal to a regular identifer (so "foo" and
+foo are two different columns). But don't do that :-).
+
+Remember thought that, in DBD::CSV if table names are used directly as file
+names, the case sensitivity depends on the OS e.g. on Windows files named foo,
+FOO, and fOo are the same as each other while on Unix they are different.
+
+=head2 Special Utility SQL Functions
+
+=head3 IMPORT()
+
+Imports the data and structure of a table from an external data source into a permanent or temporary table.
+
+ $dbh->do("CREATE TABLE qux AS IMPORT(?)",{},$oracle_sth);
+
+ $dbh->do("CREATE TABLE qux AS IMPORT(?)",{},$AoA);
+
+ $dbh->do("CREATE TABLE qux AS IMPORT(?)",{},$AoH);
+
+IMPORT() can also be used anywhere that table_names can:
+
+ $sth=$dbh->prepare("
+ SELECT * FROM IMPORT(?) AS T1 NATURAL JOIN IMPORT(?) AS T2 WHERE T1.id ...
+ ");
+ $sth->execute( $pg_sth, $mysql_sth );
+
+The IMPORT() function imports the data and structure of a table from an external data source. The IMPORT() function is always used with a placeholder parameter which may be 1) a prepared and executed statement handle for any DBI accessible data source; or 2) an AoA whose first row is column names and whose succeeding rows are data 3) an AoH.
+
+The IMPORT() function may be used in the AS clause of a CREATE statement, and in the FROM clause of any statement. When used in a FROM clause, it should be used with a column alias e.g. SELECT * FROM IMPORT(?) AS TableA WHERE ...
+
+You can also write your own IMPORT() functions to treat anything as a data source. See User-Defined Function in L<SQL::Statement::Functions>.
+
+Examples:
+
+ # create a CSV file from an Oracle query
+ #
+ $dbh = DBI->connect('dbi:CSV:');
+ $oracle_sth = $oracle_dbh->prepare($any_oracle_query);
+ $oracle_sth->execute(@params);
+ $dbh->do("CREATE TABLE qux AS IMPORT(?)",{},$oracle_sth);
+
+ # create an in-memory table from an AoA
+ #
+ $dbh = DBI->connect( 'dbi:File:' );
+ $arrayref = [['id','word'],[1,'foo'],[2,'bar'],];
+ $dbh->do("CREATE TEMP TABLE qux AS IMPORT(?)",{},$arrayref);
+
+ # query a join of a PostgreSQL table and a MySQL table
+ #
+ $dbh = DBI->connect( 'dbi:File:' );
+ $pg_dbh = DBI->connect( ... DBD::pg connect params );
+ $mysql_dbh = DBI->connect( ... DBD::mysql connect params );
+ $pg_sth = $pg_dbh->prepare( ... any pg query );
+ $pg_sth = $pg_dbh->prepare( ... any mysql query );
+ #
+ $sth=$dbh->prepare("
+ SELECT * FROM IMPORT(?) AS T1 NATURAL JOIN IMPORT(?) AS T2
+ ");
+ $sth->execute( $pg_sth, $mysql_sth );
+
+=head3 RUN()
+
+Run SQL statements from a user supplied file.
+
+ RUN( sql_file )
+
+If the file contains non-SELECT statements such as CREATE and INSERT, use the RUN() function with $dbh->do(). For example, this prepares and executes all of the SQL statements in a file called "populate.sql":
+
+ $dbh->do(" CALL RUN( 'populate.sql') ");
+
+If the file contains SELECT statements, the RUN() function may be used anywhere a table name may be used, for example, if you have a file called "query.sql" containing "SELECT * FROM Employee", then these two lines are exactly the same:
+
+ my $sth = $dbh->prepare(" SELECT * FROM Employee ");
+
+ my $sth = $dbh->prepare(" SELECT * FROM RUN( 'query.sql' ) ");
+
+If the file contains a statement with placeholders, the values for the placehoders can be passed in the call to $sth->execute() as normal. If the query.sql file contains "SELECT id,name FROM x WHERE id=?", then these two are the same:
+
+ my $sth = $dbh->prepare(" SELECT id,name FROM x WHERE id=?");
+ $sth->execute(64);
+
+ my $sth = $dbh->prepare(" SELECT * FROM RUN( 'query.sql' ) ");
+ $sth->execute(64);
+
+B<Note> This function assumes that the SQL statements in the file are separated by a semi-colon+newline combination (/;\n/). If you wish to use different separators or import SQL from a different source, just over-ride the RUN() function with your own user-defined-function.
+
+=head1 METHODS
+
+=head2 new()
+
+The new() method creates a SQL::Parser object which can then be
+used to parse, validate, or build SQL strings. It takes one
+required parameter -- the name of the SQL dialect that will
+define the rules for the parser. A second optional parameter is
+a reference to a hash which can contain additional attributes of
+the parser.
+
+ use SQL::Parser;
+ my $parser = SQL::Parser->new( $dialect_name, \%attrs );
+
+The dialect_name parameter is a string containing any valid
+dialect such as 'ANSI', 'AnyData', or 'CSV'. See the section on
+the dialect() method below for details.
+
+The attribute parameter is a reference to a hash that can
+contain error settings for the PrintError and RaiseError
+attributes. See the section below on the parse() method for
+details.
+
+An example:
+
+ use SQL::Parser;
+ my $parser = SQL::Parser->new('AnyData', {RaiseError=>1} );
+
+ This creates a new parser that uses the grammar rules
+ contained in the .../SQL/Dialects/AnyData.pm file and which
+ sets the RaiseError attribute to true.
+
+For those needing backwards compatibility with SQL::Statement
+version 0.1x and lower, the attribute hash may also contain
+feature settings. See the section "FURTHER DETAILS - Backwards
+Compatibility" below for details.
+
+
+=head2 parse()
+
+Once a SQL::Parser object has been created with the new()
+method, the parse() method can be used to parse any number of
+SQL strings. It takes a single required parameter -- a string
+containing a SQL command. The SQL string may optionally be
+terminated by a semicolon. The parse() method returns a true
+value if the parse is successful and a false value if the parse
+finds SQL syntax errors.
+
+Examples:
+
+ 1) my $success = $parser->parse('SELECT * FROM foo');
+
+ 2) my $sql = 'SELECT * FROM foo';
+ my $success = $parser->parse( $sql );
+
+ 3) my $success = $parser->parse(qq!
+ SELECT id,phrase
+ FROM foo
+ WHERE id < 7
+ AND phrase <> 'bar'
+ ORDER BY phrase;
+ !);
+
+ 4) my $success = $parser->parse('SELECT * FRoOM foo ');
+
+In examples #1,#2, and #3, the value of $success will be true
+because the strings passed to the parse() method are valid SQL
+strings.
+
+In example #4, however, the value of $success will be false
+because the string contains a SQL syntax error ('FRoOM' instead
+of 'FROM').
+
+In addition to checking the return value of parse() with a
+variable like $success, you may use the PrintError and
+RaiseError attributes as you would in a DBI script:
+
+ * If PrintError is true, then SQL syntax errors will be sent as
+ warnings to STDERR (i.e. to the screen or to a file if STDERR
+ has been redirected). This is set to true by default which
+ means that unless you specifically turn it off, all errors
+ will be reported.
+
+ * If RaiseError is true, then SQL syntax errors will cause the
+ script to die, (i.e. the script will terminate unless wrapped
+ in an eval). This is set to false by default which means
+ that unless you specifically turn it on, scripts will
+ continue to operate even if there are SQL syntax errors.
+
+Basically, you should leave PrintError on or else you will not
+be warned when an error occurs. If you are simply validating a
+series of strings, you will want to leave RaiseError off so that
+the script can check all strings regardless of whether some of
+them contain SQL errors. However, if you are going to try to
+execute the SQL or need to depend that it is correct, you should
+set RaiseError on so that the program will only continue to
+operate if all SQL strings use correct syntax.
+
+IMPORTANT NOTE #1: The parse() method only checks syntax, it
+does NOT verify if the objects listed actually exist. For
+example, given the string "SELECT model FROM cars", the parse()
+method will report that the string contains valid SQL but that
+will not tell you whether there actually is a table called
+"cars" or whether that table contains a column called 'model'.
+Those kinds of verifications can be performed by the
+SQL::Statement module, not by SQL::Parser by itself.
+
+IMPORTANT NOTE #2: The parse() method uses rules as defined by
+the selected dialect configuration file and the feature()
+method. This means that a statement that is valid in one
+dialect may not be valid in another. For example the 'CSV' and
+'AnyData' dialects define 'BLOB' as a valid data type but the
+'ANSI' dialect does not. Therefore the statement 'CREATE TABLE
+foo (picture BLOB)' would be valid in the first two dialects but
+would produce a syntax error in the 'ANSI' dialect.
+
+=head2 structure()
+
+After a SQL::Parser object has been created and the parse()
+method used to parse a SQL string, the structure() method
+returns the data structure of that string. This data structure
+may be passed on to other modules (e.g. SQL::Statement) or it
+may be printed out using, for example, the Data::Dumper module.
+
+The data structure contains all of the information in the SQL
+string as parsed into its various components. To take a simple
+example:
+
+ $parser->parse('SELECT make,model FROM cars');
+ use Data::Dumper;
+ print Dumper $parser->structure;
+
+Would produce:
+
+ $VAR1 = {
+ 'column_names' => [
+ 'make',
+ 'model'
+ ],
+ 'command' => 'SELECT',
+ 'table_names' => [
+ 'cars'
+ ]
+ };
+
+Please see the section "FURTHER DETAILS -- Parse structures"
+below for further examples.
+
+=head2 build()
+
+This method is in progress and should be available soon.
+
+=head2 dialect()
+
+ $parser->dialect( $dialect_name ); # load a dialect configuration file
+ my $dialect = $parser->dialect; # get the name of the current dialect
+
+ For example:
+
+ $parser->dialect('AnyData'); # loads the AnyData config file
+ print $parser->dialect; # prints 'AnyData'
+
+ The $dialect_name parameter may be the name of any dialect
+ configuration file on your system. Use the
+ $parser->list('dialects') method to see a list of available
+ dialects. At a minimum it will include "ANSI", "CSV", and
+ "AnyData". For backwards compatiblity 'Ansi' is accepted as a
+ synonym for 'ANSI', otherwise the names are case sensitive.
+
+ Loading a new dialect configuration file erases all current
+ parser features and resets them to those defined in the
+ configuration file.
+
+ See the section above on "Dialects" for details of these
+ configuration files.
+
+=head2 feature()
+
+Features define the rules to be used by a specific parser
+instance. They are divided into the following classes:
+
+ * valid_commands
+ * valid_options
+ * valid_comparison_operators
+ * valid_data_types
+ * reserved_words
+
+Within each class a feature name is either enabled or
+disabled. For example, under "valid_data_types" the name "BLOB"
+may be either disabled or enabled. If it is not eneabled
+(either by being specifically disabled, or simply by not being
+specified at all) then any SQL string using "BLOB" as a data
+type will throw a syntax error "Invalid data type: 'BLOB'".
+
+The feature() method allows you to enable, disable, or check the
+status of any feature.
+
+ $parser->feature( $class, $name, 1 ); # enable a feature
+
+ $parser->feature( $class, $name, 0 ); # disable a feature
+
+ my $feature = $parser->feature( $class, $name ); # show status of a feature
+
+ For example:
+
+ $parser->feature('reserved_words','FOO',1); # make 'FOO' a reserved word
+
+ $parser->feature('valid_data_types','BLOB',0); # disallow 'BLOB' as a
+ # data type
+
+ # determine if the LIKE
+ # operator is supported
+ my $LIKE = $parser->feature('valid_operators','LIKE');
+
+See the section below on "Backwards Compatibility" for use of
+the feature() method with SQL::Statement 0.1x style parameters.
+
+=head2 list()
+
+=head2 errstr()
+
+=head1 FURTHER DETAILS
+
+=head2 Dialect Configuration Files
+
+These will change completely when Tim finalizes the DBI get_info method.
+
+=head2 Parse Structures
+
+Here are some further examples of the data structures returned
+by the structure() method after a call to parse(). Only
+specific details are shown for each SQL instance, not the entire
+struture.
+
+ 'SELECT make,model, FROM cars'
+
+ command => 'SELECT',
+ table_names => [ 'cars' ],
+ column_names => [ 'make', 'model' ],
+
+ 'CREATE TABLE cars ( id INTEGER, model VARCHAR(40) )'
+
+ column_defs => {
+ id => { data_type => INTEGER },
+ model => { data_type => VARCHAR(40) },
+ },
+
+ 'SELECT DISTINCT make FROM cars'
+
+ set_quantifier => 'DISTINCT',
+
+ 'SELECT MAX (model) FROM cars'
+
+ set_function => {
+ name => 'MAX',
+ arg => 'models',
+ },
+
+ 'SELECT * FROM cars LIMIT 5,10'
+
+ limit_clause => {
+ offset => 5,
+ limit => 10,
+ },
+
+ 'SELECT * FROM vars ORDER BY make, model DESC'
+
+ sort_spec_list => [
+ { make => 'ASC' },
+ { model => 'DESC' },
+ ],
+
+ "INSERT INTO cars VALUES ( 7, 'Chevy', 'Impala' )"
+
+ values => [ 7, 'Chevy', 'Impala' ],
+
+
+=head2 Backwards Compatibility
+
+This module can be used in conjunction with SQL::Statement,
+version 0.2 and higher. Earlier versions of SQL::Statement
+included a SQL::Parser as a submodule that used slightly
+different syntax than the current version. The current version
+supports all of this earlier syntax although new users are
+encouraged to use the new syntax listed above. If the syntax
+listed below is used, the module should be able to be subclassed
+exactly as it was with the older SQL::Statement versions and
+will therefore not require any modules or scripts that used it
+to make changes.
+
+In the old style, features of the parser were accessed with this
+syntax:
+
+ feature('create','type_blob',1); # allow BLOB as a data type
+ feature('create','type_blob',0); # disallow BLOB as a data type
+ feature('select','join',1); # allow multi-table statements
+
+The same settings could be acheieved in calls to new:
+
+ my $parser = SQL::Parser->new(
+ 'Ansi',
+ {
+ create => {type_blob=>1},
+ select => {join=>1},
+ },
+ );
+
+Both of these styles of setting features are supported in the
+current SQL::Parser.
+
+=head2 Subclassing SQL::Parser
+
+In the event you need to either extend or modify SQL::Parser's
+default behavior, the following methods may be overriden
+to modify the behavior:
+
+=over
+
+=item C<$self->E<gt>C<get_btwn($string)>
+
+Processes the BETWEEN...AND... predicates; default converts to
+2 range predicates.
+
+=item C<$self->E<gt>C<get_in($string)>
+
+Process the IN (...list...) predicates; default converts to
+a series of OR'd '=' predicate, or AND'd '<>' predicates for
+NOT IN.
+
+=item C<$self->E<gt>C<transform_syntax($string)>
+
+Abstract method; default simply returns the original string.
+Called after get_btwn() and get_in(), but before any further
+predicate processing is applied. Possible uses include converting
+other predicate syntax not recognized by SQL::Parser into user-defined
+functions.
+
+=back
+
+=head1 TO-DO
+
+ * add support for database.schema.table.column # perlguy at perlguy.com
+ * add support for precision in types e.g. DECIMAL(1,6) # PodMaster
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Jochen Wiedmann for writing the original module. Thanks to Ilya Sterin for support in the early stages of my redesign of the module. Thanks to Dean Arnold for extensive patching, support, and suggetions. Thanks to Dan Wright for patches and suggestions. See also the changes file for thanks to the dozens of people who have helped along the way.
+
+=head1 AUTHOR & COPYRIGHT
+
+ This module is copyright (c) 2001,2005 by Jeff Zucker.
+ All rights reserved.
+
+ The module may be freely distributed under the same terms as
+ Perl itself using either the "GPL License" or the "Artistic
+ License" as specified in the Perl README file.
+
+ Jeff can be reached at: jzuckerATcpan.org
+
+=cut
Copied: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Functions.pm (from rev 888, packages/libsql-statement-perl/branches/upstream/current/lib/SQL/Statement/Functions.pm)
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Statement/GetInfo.pm
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/lib/SQL/Statement/RAM.pm (from rev 888, packages/libsql-statement-perl/branches/upstream/current/lib/SQL/Statement/RAM.pm)
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Statement/RAM.pm
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Util.pm (from rev 888, packages/libsql-statement-perl/branches/upstream/current/lib/SQL/Statement/Util.pm)
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Util.pm
___________________________________________________________________
Name: svn:executable
+ *
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm 2005-04-05 22:52:12 UTC (rev 889)
@@ -7,12 +7,14 @@
#
# See below for help (search for SYNOPSIS)
#########################################################################
-
use strict;
use SQL::Parser;
use SQL::Eval;
-use vars qw($VERSION $numexp $s2pops $arg_num $dlm $warg_num $HAS_DBI);
+use SQL::Statement::RAM;
+use vars qw($VERSION $numexp $s2pops $arg_num $dlm $warg_num $HAS_DBI $DEBUG);
BEGIN {
+ eval { require 'Data/Dumper.pm'; $Data::Dumper::Indent=1};
+ *bug = ($@) ? sub {warn @_} : sub { print Data::Dumper::Dumper(\@_) };
eval { require 'DBI.pm' };
$HAS_DBI = 1 unless $@;
*is_number = ($HAS_DBI)
@@ -29,8 +31,7 @@
#use locale;
-$VERSION = '1.09';
-
+$VERSION = '1.11';
$dlm = '~';
$arg_num=0;
$warg_num=0;
@@ -74,14 +75,15 @@
my $parser_dialect = $flags->{"dialect"} || 'AnyData';
$parser_dialect = 'AnyData' if $parser_dialect =~ /^(CSV|Excel)$/;
- if (!ref($parser) or (ref($parser) and ref($parser) !~ /^SQL::Parser/)) {
- # if (!ref($parser)) {
-# print "NEW PARSER\n";
+ # Dean Arnold improvement to allow better subclassing
+ # if (!ref($parser) or (ref($parser) and ref($parser) !~ /^SQL::Parser/)) {
+ if ( !ref($parser)
+ or ( ref($parser)
+ and ( !$parser->isa('SQL::Parser') )
+ )
+ ){
$parser = new SQL::Parser($parser_dialect,$flags);
}
-# unless ref $parser and ref $parser =~ /^SQL::Parser/;
-# $parser = new SQL::Parser($parser_dialect,$flags) ;
-
if ($] < 5.005 ) {
$numexp = exists $self->{"text_numbers"}
? '^([+-]?|\s+)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$'
@@ -126,7 +128,6 @@
SQL::Statement::Limit->new( $self->{"limit_clause"} );
}
my $max_placeholders = $self->{num_placeholders} || 0;
- #print $self->command, " [$max_placeholders]\n";
if ($max_placeholders) {
for my $i(0..$max_placeholders-1) {
$self->{"params"}->[$i] = SQL::Statement::Param->new($i);
@@ -148,8 +149,17 @@
}
}
for (@$columns) {
- push @{ $self->{"columns"} },
- SQL::Statement::Column->new($_,$tables);
+ my $newcol = $_;
+ my $col_obj = delete $self->{col_obj}->{$newcol};
+ if ($col_obj and ref($col_obj)=~/::Column$/ ) {
+ $self->{"computed_column"}->{$newcol} = $col_obj
+ if defined $col_obj->function;
+ $newcol = $col_obj;
+ }
+ else {
+ $newcol = SQL::Statement::Column->new($newcol,$tables);
+ }
+ push @{ $self->{"columns"} }, $newcol;
}
for (@$tables) {
push @{ $self->{"tables"} },
@@ -174,13 +184,15 @@
sub execute {
my($self, $data, $params) = @_;
+ ($self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'},
+ $self->{'data'}) = (0,0,[]) and return 'OEO' if $self->{no_execute};
+ $self->{procedure}->{data}=$data if $self->{procedure};
$self->{'params'}= $params;
my($table, $msg);
my($command) = $self->command();
return $self->do_err( 'No command found!') unless $command;
($self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'},
$self->{'data'}) = $self->$command($data, $params);
-#=pod
my $names = $self->{NAME};
@$names = map {
my $org = $self->{ORG_NAME}->{$_}; # from the file header
@@ -190,16 +202,18 @@
$org;
} @$names if $self->{asterisked_columns};
$names = $self->{org_col_names} unless $self->{asterisked_columns};
-
- $self->{NAME} = $names;
-if ($command eq 'SELECT') {
-#use mylibs; zwarn $self;
-#print "\n\n";
-#print "[" . ($self->{asterisked_columns}||'') . "]";
-#print "~@$names~" if $names;
-#print "\n\n";
+ my $newnames;
+#
+# DAA
+# for (0..$#{@$names}) {
+ my @orgnames=@{$names} if $names;
+ for my $i(0..$#$names) {
+ my $newname = $orgnames[$i];
+ $newname = $self->{columns}->[$i]->display_name
+ if $self->{columns}->[$i]->can('display_name');
+ push @$newnames,$newname;
}
-#=cut
+ $self->{NAME} = $newnames;
my $tables;
@$tables = map {$_->{"name"}} @{ $self->{"tables"} };
delete $self->{'tables'}; # Force closing the tables
@@ -219,8 +233,71 @@
(0, 0);
}
+# defunct, leave temporarily as comparison
+sub CREATE_RAM_TABLE {
+ my($self, $data, $params) = @_;
+ my $tname = $self->{table_names}->[0];
+ my $tables = $data->{Database}->{sql_ram_tables} || {};
+ if ($tables->{uc $tname}) {
+ die "Cannot create table $tname: Already exists";
+ }
+ my($data_tbl) = shift @{ $self->{params} };
+ my $col_names = [];
+ if (ref $data_tbl eq 'ARRAY') {
+ $col_names = shift @$data_tbl;
+ }
+ elsif (ref($data_tbl) =~ /::db$/) {
+ my $sql = shift @{ $self->{params} } || die "No SQL query supplied!\n";
+ my @params = @{ $self->{params} };
+ @params = () unless @params;
+ my $sth = $data_tbl->prepare($sql);
+ $sth->execute(@params);
+ my $data_ary = $sth->fetchall_arrayref;
+ $col_names = $sth->{NAME};
+ $data_tbl->disconnect unless $self->{ram_table_keep_connection};
+ $data_tbl = $data_ary;
+ }
+ else {
+ die "RAM tables must supply an AoA or a dbh\n";
+ }
+ my $ramTable = SQL::Statement::RAM->new(
+ $tname, $col_names, $data_tbl
+ );
+ $ramTable->{all_cols} ||= $col_names;
+ $data->{Database}->{sql_ram_tables}->{uc $tname} = $ramTable;
+ my($eval,$foo) = $self->open_tables($data, 1, 1);
+ return undef unless $eval;
+ (0, 0);
+}
sub CREATE ($$$) {
my($self, $data, $params) = @_;
+ # CREATE TABLE AS ...
+ if (my $subquery = $self->{subquery}) {
+ my $sth;
+ # AS IMPORT
+ if ($subquery =~ /^IMPORT/i) {
+ $sth = $data->{Database}->prepare("SELECT * FROM $subquery");
+ $sth->execute(@$params);
+ }
+ # AS SELECT
+ else {
+ $sth = $data->{Database}->prepare($subquery);
+ $sth->execute();
+ }
+ my $tbl_data = $sth->{f_stmt}->{data};
+ my $tbl_name = $self->tables(0)->name;
+ my @tbl_cols = map {$_->name} $sth->{f_stmt}->columns;
+ my $create_sql = "CREATE TABLE $tbl_name ";
+ $create_sql = "CREATE TEMP TABLE $tbl_name "
+ if $self->{"is_ram_table"};
+ my @coldefs = map { "$_ TEXT" } @tbl_cols;
+ $create_sql .= '('.join(',', at coldefs).')';
+ $data->{Database}->do($create_sql);
+ my $colstr = ('?,')x at tbl_cols;
+ my $insert_sql = "INSERT INTO $tbl_name VALUES($colstr)";
+ $data->{Database}->do($insert_sql,{},@$_) for @$tbl_data;
+ return (0,0);
+ }
my($eval,$foo) = $self->open_tables($data, 1, 1);
return undef unless $eval;
$eval->params($params);
@@ -234,6 +311,16 @@
(0, 0);
}
+sub CALL {
+ my($self, $data, $params) = @_;
+ my $dbh = $data->{Database};
+ $self->{procedure}->{data} = $data;
+ ( $self->{'NUM_OF_ROWS'} ,
+ $self->{'NUM_OF_FIELDS'} ,
+ $self->{'data'}
+ ) = $self->get_row_value($self->{procedure});
+}
+
sub DROP ($$$) {
my($self, $data, $params) = @_;
if ($self->{ignore_missing_table}) {
@@ -325,16 +412,12 @@
sub UPDATE ($$$) {
my($self, $data, $params) = @_;
my $valnum = $self->{num_val_placeholders};
-#print "@$params -- $valnum\n";
if ($valnum) {
-#print "[$valnum]";
-#my @val_params;
my @val_params = splice @$params, 0,$valnum;
@$params = (@$params, at val_params);
# my @where_params = $params->[$valnum+1..scalar @$params-1];
# @$params = (@where_params, at val_params);
}
-#print "@$params\n"; exit;
my($eval,$all_cols) = $self->open_tables($data, 0, 1);
return undef unless $eval;
$eval->params($params);
@@ -349,17 +432,21 @@
$array = $self->{fetched_value};
}
my $param_num =$arg_num;
- #print $param_num;
- #print $eval->param($param_num); print "@$params"; exit;
- #$arg_num = 0;
my $col_nums = $eval->{"tables"}->{"$tname"}->{"col_nums"} ;
my $cols;
%$cols = reverse %{ $col_nums };
my $rowhash;
- #print "$tname -- @$rowary\n";
- for (sort keys %$cols) {
- $rowhash->{$cols->{$_}} = $array->[$_];
+ ####################################
+ # Dan Wright
+ ####################################
+ # for (keys %$cols) {
+ # $rowhash->{$cols->{$_}} = $array->[$_];
+ # }
+ while (my($name, $number) = each %$col_nums ) {
+ $rowhash->{$name} = $array->[$number];
}
+ ####################################
+
for ($i = 0; $i < $self->columns(); $i++) {
$col = $self->columns($i);
$val = $self->row_values($i);
@@ -408,7 +495,25 @@
#
if ($display_combine eq 'NAMED') {
@display_cols = $self->columns;
- @display_cols = map {$_->table . $dlm . $_->name} @display_cols;
+#
+# DAA
+# need to get to $self's table objects to get the name
+#
+# @display_cols = map {$_->table . $dlm . $_->name} @display_cols;
+# @display_cols = map {$_->table->{NAME} . $dlm . $_->name} @display_cols;
+
+ my @tbls = $self->tables;
+ my %tables = ();
+
+ $tables{$_->name} = $_
+ foreach (@tbls);
+
+ foreach (0..$#display_cols) {
+ $display_cols[$_] =
+ ($display_cols[$_]->table ?
+ $tables{$display_cols[$_]->table}->name : '') .
+ $dlm . $display_cols[$_]->name;
+ }
}
# IF ASTERISKED COLUMNS AND NOT NATURAL OR USING
@@ -445,10 +550,8 @@
# @shared = map {s/^[^_]*_(.+)$/$1/; $_} @keycols;
# @shared = grep !$is_shared{$_}++, @shared
}
- #print "<@display_cols>\n";
$self->{"join"}->{"shared_cols"} = \@shared;
$self->{"join"}->{"display_cols"} = \@display_cols;
- # print "@shared : @display_cols\n";
}
sub JOIN {
@@ -478,7 +581,8 @@
for my $table(@tables) {
my @cols = @{ $eval->table($table->{name})->col_names };
for (@cols) {
- push @all_cols, $table . $dlm . $_;
+ push @all_cols, $table->{name} . $dlm . $_;
+# push @all_cols, $table . $dlm . $_;
}
}
$self->find_join_columns(@all_cols);
@@ -497,6 +601,8 @@
$tableB = $tableB->{name} if ref $tableB;
my $tableAobj = $eval->table($tableA);
my $tableBobj = $eval->table($tableB);
+ $tableAobj->{NAME} ||= $tableA;
+ $tableBobj->{NAME} ||= $tableB;
$self->join_2_tables($data,$params,$tableAobj,$tableBobj);
for my $next_table(@tables) {
$tableAobj = $self->{"join"}->{"table"};
@@ -510,7 +616,6 @@
sub join_2_tables {
my($self, $data, $params, $tableAobj, $tableBobj) = @_;
- #print "<< ".$self->{"cur_table"}." >>\n" if $self->{"cur_table"};
my $tableA = $tableAobj->{"NAME"};
my $tableB = $tableBobj->{"NAME"};
my $share_type = 'IMPLICIT';
@@ -663,9 +768,24 @@
);
}
+sub run_functions{
+ my($self, $data, $params) = @_;
+ my @row=();
+ for my $col($self->columns) {
+ my $val = $self->get_row_value(
+ $self->{computed_column}->{$col->name}->{function}
+
+ );
+ push @row, $val;
+ }
+ (1,scalar @row, [\@row]);
+}
+
sub SELECT ($$) {
my($self, $data, $params) = @_;
$self->{"params"} ||= $params;
+ return $self->run_functions($data,$params)
+ if @{$self->{table_names}} == 0;
my($eval,$all_cols,$tableName,$table);
if (defined $self->{"join"} ) {
return $self->JOIN($data,$params) if !defined $self->{"join"}->{"table"};
@@ -688,16 +808,21 @@
my $numFields = 0;
my %columns;
my @names;
- if ($self->{"join"}) {
- @names = @{ $table->col_names };
- for my $col(@names) {
- $columns{$tableName}->{"$col"} = $numFields++;
- push(@$cList, $table->column_num($col));
- }
- }
- else {
+ my %funcs =();
+#
+# DAA
+#
+# lets just disable this and see where it leads...
+#
+# if ($self->{"join"}) {
+# @names = @{ $table->col_names };
+# for my $col(@names) {
+# $columns{$tableName}->{"$col"} = $numFields++;
+# push(@$cList, $table->column_num($col));
+# }
+# }
+# else {
foreach my $column ($self->columns()) {
- #next unless defined $column and ref $column;
if (ref($column) eq 'SQL::Statement::Param') {
my $val = $eval->param($column->num());
if ($val =~ /(.*)\.(.*)/) {
@@ -709,26 +834,43 @@
}
} else {
($col, $tbl) = ($column->name(), $column->table());
- }
- if ($col eq '*') {
- $ar = $table->col_names();
+ }
+ if ($col eq '*') {
+ $ar = $table->col_names();
+ for ($i = 0; $i < @$ar; $i++) {
+ my $cName = $ar->[$i];
+ $columns{$tbl}->{"$cName"} = $numFields++;
+ $c = SQL::Statement::Column->new({'table' => $tableName,
+ 'column' => $cName});
+ push(@$cList, $i);
+ push(@names, $cName);
+ }
+ } else {
+ $tbl ||= '';
+ $columns{$tbl}->{"$col"} = $numFields++;
+ #
+ # handle functions in select list
+ #
+#
+# DAA
+#
+# check for a join temp table; if so, check if we can locate
+# the column in its delimited set
+#
+ my $cnum = (($tableName eq '~tmp') && ($tbl ne '')) ?
+ $table->column_num($tbl . $dlm . $col) :
+ $table->column_num($col);
-#@$ar = map {lc $_} @$ar;
- for ($i = 0; $i < @$ar; $i++) {
- my $cName = $ar->[$i];
- $columns{$tbl}->{"$cName"} = $numFields++;
- $c = SQL::Statement::Column->new({'table' => $tableName,
- 'column' => $cName});
- push(@$cList, $i);
- push(@names, $cName);
- }
- } else {
- $columns{$tbl}->{"$col"} = $numFields++;
- push(@$cList, $table->column_num($col));
- push(@names, $col);
- }
- }
- }
+ if (!defined $cnum) {
+ $funcs{$col} = $column->{function};
+ $cnum = $col;
+ }
+ push(@$cList, $cnum );
+ # push(@$cList, $table->column_num($col));
+ push(@names, $col);
+ }
+ }
+# }
$cList = [] unless defined $cList;
$self->{'NAME'} = \@names;
if ($self->{"join"}) {
@@ -781,7 +923,6 @@
}
}
$tbl ||= $self->colname2table($col);
- #print "$tbl~\n";
next if exists($columns{$tbl}->{"$col"});
$pos = $table->column_num($col) unless defined $pos;
push(@extraSortCols, $pos);
@@ -793,23 +934,18 @@
$e = $table;
}
while (my $array = $table->fetch_row($data)) {
- if ($self->eval_where($e,$tableName,$array)) {
+ if ($self->eval_where($e,$tableName,$array,\%funcs)) {
$array = $self->{fetched_value} if $self->{fetched_from_key};
# Note we also include the columns from @extraSortCols that
# have to be ripped off later!
- my @row;
- # if (!scalar @$cList or !scalar @extraSortCols) {
- # @row = @$array;
- # }
- # else {
- @extraSortCols = () unless @extraSortCols;
- #print "[$_]" for @$cList; print "\n";
-
- @row = map { defined $_ and defined $array->[$_] ? $array->[$_] : undef } (@$cList, @extraSortCols);
+ @extraSortCols = () unless @extraSortCols;
+ my @row = map { (defined $_ and /^\d+$/ and defined $array->[$_])
+ ? $array->[$_]
+ : $self->{func_vals}->{$_} ;
+ } (@$cList, @extraSortCols);
push(@$rows, \@row);
return (scalar(@$rows),scalar @{$self->{column_names}},$rows)
if $self->{fetched_from_key};
- # }
}
}
if (@order_by) {
@@ -820,7 +956,6 @@
$tbl = 'shared' if $table->is_shared($col);
$tbl ||= $self->colname2table($col);
}
- #print $table->col_table(0),'~',$tbl,'~',$_->column(); exit;
$tbl ||= $self->colname2table($col);
($columns{$tbl}->{"$col"}, $_->desc())
} @order_by;
@@ -885,11 +1020,23 @@
}
}
}
- if ($self->{"join"}) {
+#
+# DAA
+#
+# why is this needed at this point ?
+# shouldn't we just use the names as given ?
+# or do we need to provide fully qualified names ?
+#
+# JZ : this is needed for all explicit joins, to trim the fields
+#
+ my $has_computed_columns = scalar keys %{$self->{computed_column}}
+ if $self->{computed_column};
+ if ( $self->{"join"}
+ and $self->{asterisked_columns}
+ and !$has_computed_columns) {
my @final_cols = @{$self->{"join"}->{"display_cols"}};
@final_cols = map {$table->column_num($_)} @final_cols;
my @names = map { $self->{"NAME"}->[$_]} @final_cols;
-# my @names = map { $self->{"REAL_NAME"}->[$_]} @final_cols;
$numFields = scalar @names;
$self->{"NAME"} = \@names;
my $i = -1;
@@ -898,6 +1045,27 @@
@{ $rows->[$i] } = @$row[@final_cols];
}
}
+ elsif ($self->{"join"} and $has_computed_columns) {
+ my @final_cols = map {$table->column_num($_)}
+ @{$self->{"join"}->{"display_cols"}};
+ my %col_map = ();
+
+ $col_map{$self->{NAME}[$_]} = $_
+ foreach (0..$#{$self->{NAME}});
+
+ foreach (0..$#final_cols) {
+ next if defined($final_cols[$_]);
+#
+# must be computed column, lookup its position in
+# row
+#
+ my $col = $self->{join}{display_cols}[$_];
+ $col = substr($col, 1)
+ if (substr($col, 0, 1) eq $dlm);
+ $final_cols[$_] = $col_map{$col};
+ }
+ }
+###################################################################
if (defined $self->{"limit_clause"}) {
my $offset = $self->{"limit_clause"}->offset || 0;
my $limit = $self->{"limit_clause"}->limit || 0;
@@ -988,40 +1156,63 @@
my $eval = shift;
my $tname = shift;
my $rowary = shift;
+ my $funcs = shift || ();
$tname ||= $self->tables(0)->name();
- my $where = $self->{"where_clause"} || return 1;
my $cols;
my $col_nums;
- if ($self->{"join"}) {
- $col_nums = $eval->{"col_nums"};
- }
- else {
- $col_nums = $eval->{"tables"}->{"$tname"}->{"col_nums"} ;
- }
+ $col_nums = $self->{join} ? $eval->{col_nums}
+ : $eval->{tables}->{$tname}->{col_nums} ;
+
%$cols = reverse %{ $col_nums };
+ ####################################
+ # Dan Wright
+ ####################################
my $rowhash;
- #print "$tname -- @$rowary\n";
- for (sort keys %$cols) {
- $rowhash->{$cols->{$_}} = $rowary->[$_];
+ while (my($name, $number) = each %$col_nums ) {
+ $rowhash->{$name} = $rowary->[$number];
}
+ ####################################
+ my($f,$fval);
+ $rowhash->{$f} = $self->{func_vals}->{$f}
+ = $self->get_row_value( $fval, $eval, $rowhash )
+ while ( ($f,$fval) = each %$funcs);
+
my @truths;
$arg_num=0;
+ my $where = $self->{"where_clause"} || return 1;
return $self->process_predicate ($where,$eval,$rowhash);
}
+
sub process_predicate {
my($self,$pred,$eval,$rowhash) = @_;
- if ($pred->{op} eq 'OR') {
- my $match1 = $self->process_predicate($pred->{"arg1"},$eval,$rowhash);
- return 1 if $match1 and !$pred->{"neg"};
- my $match2 = $self->process_predicate($pred->{"arg2"},$eval,$rowhash);
+ if ($pred->{op}eq'USER_DEFINED' and !$pred->{arg2}) {
+ my $match = $self->get_row_value( $pred->{"arg1"}, $eval, $rowhash );
if ($pred->{"neg"}) {
- return (!$match1 and !$match2) ? 1 : 0;
+ $match = $match ? 0 : 1;
}
- else {
- return $match2 ? 1 : 0;
- }
+ return $match;
}
+ if ($pred->{op} eq 'OR') {
+ #
+ # From Dan Wright
+ #
+ # Demorgan's law: ^(A OR B) = ^A AND ^B
+ #
+ # We can always return if match1 is true. We short-circuit the OR
+ # with a true value, or short-circuit the AND with a false value on
+ # negation.
+ my $match1 = $self->process_predicate($pred->{"arg1"},$eval,$rowhash);
+ return $pred->{'neg'} ? 0 : 1 if $match1;
+
+ my $match2 = $self->process_predicate($pred->{"arg2"},$eval,$rowhash);
+
+ # Same logic applies for short-circuit on the second argument.
+ return $pred->{'neg'} ? 0 : 1 if $match2;
+
+ # Neither short circuit caught, both arguments were false.
+ return $pred->{'neg'} ? 1 : 0;
+ }
elsif ($pred->{op} eq 'AND') {
my $match1 = $self->process_predicate($pred->{"arg1"},$eval,$rowhash);
if ($pred->{"neg"}) {
@@ -1042,29 +1233,32 @@
my $val1 = $self->get_row_value( $pred->{"arg1"}, $eval, $rowhash );
my $val2 = $self->get_row_value( $pred->{"arg2"}, $eval, $rowhash );
my $op = $pred->{op};
+ #
+ # currently we treat NULL and '' as the same
+ # eventually fix
+ #
+
+ # always true
if ("DBD or AnyData") {
- if ( $op !~ /^IS/i and (
- !defined $val1 or $val1 eq '' or
- !defined $val2 or $val2 eq ''
- )) {
+ if ( $op !~ /^IS/i and (
+ !defined $val1 or $val1 eq '' or
+ !defined $val2 or $val2 eq ''
+ )) {
$op = $s2pops->{"$op"}->{'s'};
- }
- else {
- if (defined $val1 and defined $val2 and $op !~ /^IS/i ) {
-# $op = ( $val1 =~ $numexp && $val2 =~ $numexp )
- $op = ( is_number($val1,$val2) )
+ }
+ elsif (defined $val1 and defined $val2 and $op !~ /^IS/i ) {
+ $op = ( is_number($val1) and is_number($val2) )
? $s2pops->{"$op"}->{'n'}
: $s2pops->{"$op"}->{'s'};
- }
- }
- }
+ }
+ }
+ # someday ...
else {
if (defined $val1 and defined $val2 and $op !~ /^IS/i ) {
-# $op = ( $val1 =~ $numexp && $val2 =~ $numexp )
- $op = ( is_number($val1,$val2) )
+ $op = ( is_number($val1) and is_number($val2) )
? $s2pops->{"$op"}->{'n'}
: $s2pops->{"$op"}->{'s'};
- }
+ }
}
my $neg = $pred->{"neg"};
if (ref $eval !~ /TempTable/) {
@@ -1088,8 +1282,41 @@
sub is_matched {
my($self,$val1,$op,$val2)=@_;
- #print "[$val1] [$op] [$val2]\n";
+ return (!defined $val1 or $val1 eq '') ? 1 : 0 if ($op eq 'IS');
+ $val1 = '' unless defined $val1;
+ $val2 = '' unless defined $val2;
+ return undef unless (defined $val1 and defined $val2);
+ $val2 = quotemeta($val2),
+ $val2 =~ s/\\%/.*/g,
+ $val2 =~ s/_/./g
+ if (($op eq 'LIKE') || ($op eq 'CLIKE'));
+ return 0 if ( !$self->{"alpha_compare"} && (
+ ($op eq 'lt') ||
+ ($op eq 'gt') ||
+ ($op eq 'le') ||
+ ($op eq 'ge')
+ ));
+ return ($op eq 'LIKE' ) ? ($val1 =~ /^$val2$/s) :
+ ($op eq 'CLIKE' ) ? ($val1 =~ /^$val2$/si) :
+ ($op eq 'RLIKE' ) ? ($val1 =~ /$val2/is) :
+ ($op eq '<' ) ? ($val1 < $val2) :
+ ($op eq '>' ) ? ($val1 > $val2) :
+ ($op eq '==') ? ($val1 == $val2) :
+ ($op eq '!=') ? ($val1 != $val2) :
+ ($op eq '<=') ? ($val1 <= $val2) :
+ ($op eq '>=') ? ($val1 >= $val2) :
+ ($op eq 'lt') ? ($val1 lt $val2) :
+ ($op eq 'gt') ? ($val1 gt $val2) :
+ ($op eq 'eq') ? ($val1 eq $val2) :
+ ($op eq 'ne') ? ($val1 ne $val2) :
+ ($op eq 'le') ? ($val1 le $val2) :
+ ($op eq 'ge') ? ($val1 ge $val2) :
+ 0;
+}
+sub is_matched_old {
+ my($self,$val1,$op,$val2)=@_;
+ ### return unless $val1; screws up null comparison, why was this here?
# if DBD::CSV or AnyData
if ($op eq 'IS') {
return 1 if (!defined $val1 or $val1 eq '');
@@ -1097,8 +1324,6 @@
}
$val1 = '' unless defined $val1;
$val2 = '' unless defined $val2;
- # else
-#print "$val1 ~ $op ~ $val2\n";
if ($op eq 'IS') {
return defined $val1 ? 0 : 1;
}
@@ -1111,7 +1336,6 @@
if ( !$self->{"alpha_compare"} && $op =~ /lt|gt|le|ge/ ) {
return 0;
}
- # print "[$val1] [$val2]\n";
if ($op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; }
if ($op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; }
if ($op eq 'RLIKE' ) { return $val1 =~ /$val2/is; }
@@ -1129,6 +1353,11 @@
if ($op eq 'ge') { return $val1 ge $val2; }
}
+sub data {
+ my($self) = @_;
+ $self->{data} ||= [];
+ return $self->{data};
+}
sub open_tables {
my($self, $data, $createMode, $lockMode) = @_;
my @call = caller 4;
@@ -1144,24 +1373,42 @@
for ( @tables) {
$count++;
my $name = $_->{"name"};
- undef $@;
- eval{
- my $open_name = $self->{org_table_names}->[$count];
- if ($caller && $caller =~ /^DBD::AnyData/) {
- $caller .= '::Statement' if $caller !~ /::Statement/;
- $t->{"$name"} = $caller->open_table($data, $open_name,
- $createMode, $lockMode);
- }
- else {
- $t->{"$name"} = $self->open_table($data, $open_name,
- $createMode, $lockMode);
- }
+ if( $name =~ /^(.+)\.([^\.]+)$/ ) {
+ my $schema = $1; # ignored
+ $name = $_->{name} = $2;
+ }
+ if (my $u_func = $self->{"table_func"}->{ uc $name}) {
+ $t->{"$name"} = $self->get_user_func_table($name,$u_func);
+ }
+ elsif ($data->{Database}->{sql_ram_tables}->{uc $name}) {
+ $t->{"$name"} = $data->{Database}->{sql_ram_tables}->{uc $name};
+ $t->{"$name"}->{index}=0;
+ }
+ elsif ( $self->{"is_ram_table"} or !($self->can('open_table'))) {
+ $t->{"$name"} = $data->{Database}->{sql_ram_tables}->{uc $name}
+ = SQL::Statement::RAM->new( uc $name, [], [] );
+ }
+ else {
+ undef $@;
+ eval{
+ my $open_name = $self->{org_table_names}->[$count];
+ if ($caller && $caller =~ /^DBD::AnyData/) {
+ $caller .= '::Statement' if $caller !~ /::Statement/;
+ $t->{"$name"} = $caller->open_table($data, $open_name,
+ $createMode, $lockMode);
+ }
+ else {
+ $t->{"$name"} = $self->open_table($data, $open_name,
+ $createMode, $lockMode);
+ }
- };
- my $err = $t->{"$name"}->{errstr};
- return $self->do_err($err) if $err;
- return $self->do_err($@) if $@;
+ };
+ my $err = $t->{"$name"}->{errstr};
+ return $self->do_err($err) if $err;
+ return $self->do_err($@) if $@;
+ }
my @cnames;
+#$DEBUG=1;
for my $c(@{$t->{"$name"}->{"col_names"}}) {
my $newc;
if ($c =~ /^"/) {
@@ -1175,6 +1422,9 @@
push @cnames, $newc;
$self->{ORG_NAME}->{$newc}=$c;
}
+#
+# set the col_num => col_obj hash for the table
+#
my $col_nums;
my $i=0;
for (@cnames) {
@@ -1182,10 +1432,8 @@
}
$t->{"$name"}->{"col_nums"} = $col_nums; # upper cased
$t->{"$name"}->{"col_names"} = \@cnames;
-#use mylibs; zwarn $t->{$name};
+
my $tcols = $t->{"$name"}->col_names;
-# @$tcols = map{lc $_} @$tcols ;
- ###z @$tcols = map{$name.'.'.$_} @$tcols ;
my @newcols;
for (@$tcols) {
next unless defined $_;
@@ -1195,7 +1443,9 @@
}
@c = ( @c, @newcols );
}
- my $all_cols = $self->{all_cols} || [];
+ my $all_cols = $self->{all_cols}
+ || [ map {$_->{name} }@{$self->{columns}} ]
+ || [];
@$all_cols = (@$all_cols, at c);
$self->{all_cols} = $all_cols;
return SQL::Eval->new({'tables' => $t}), \@c;
@@ -1205,23 +1455,14 @@
my( $self, $eval, $all_cols ) = @_;
$all_cols ||= [];
my @tmp_cols = @$all_cols;
-# my @tmp_cols = map{lc $_} @$all_cols;
my $usr_cols;
my $cnum=0;
my @tmpcols = $self->columns;
-
-###z
-# for (@tmpcols) {
-# $_->{"table"} = lc $_->{"table"};
-# }
-#use mylibs; print $self->command; zwarn \@tmpcols;
-###z
for my $c(@tmpcols) {
if ($c->{"name"} eq '*' and defined $c->{"table"}) {
return $self->do_err("Can't find table ". $c->{"table"})
unless $eval->{"tables"}->{$c->{"table"}};
my $tcols = $eval->{"tables"}->{$c->{"table"}}->col_names;
-# @$tcols = map{lc $_} @$tcols ;
return $self->do_err("Couldn't find column names!")
unless $tcols and ref $tcols eq 'ARRAY' and @$tcols;
for (@$tcols) {
@@ -1231,14 +1472,13 @@
}
}
else {
- push @$usr_cols, SQL::Statement::Column->new( $c->{"name"},
- [$c->{"table"}]
- );
+ $c = SQL::Statement::Column->new( $c->{"name"},[$c->{"table"}])
+ unless ref($c) and ref($c)=~/::Column/;
+ push @$usr_cols, $c;
}
}
$self->{"columns"} = $usr_cols;
@tmpcols = map {$_->{name}} @$usr_cols;
-# @tmpcols = map {lc $_->{name}} @$usr_cols;
my $fully_qualified_cols=[];
my %col_exists = map {$_=>1} @tmp_cols;
@@ -1271,7 +1511,8 @@
###endnew
#print "Content-type: text/html\n\n"; print $self->command; print "$col!!!<p>";
if ( $col eq '*' and $num_tables == 1) {
- $table ||= $self->tables->[0]->{"name"};
+ # $table ||= $self->tables->[0]->{"name"};
+ $table ||= $self->tables(0)->{"name"};
if (ref $table eq 'SQL::Statement::Table') {
$table = $table->name;
}
@@ -1324,9 +1565,8 @@
}
}
else {
-#print "[$c~$col]\n";
-#use mylibs; zwarn \%col_exists;
- if (!$table) {
+ my $col_obj = $self->{computed_column}->{$c};
+ if (!$table and !$col_obj) {
return $self->do_err("Ambiguous column name '$c'")
if $is_duplicate{$c};
return $self->do_err("No such column '$c'")
@@ -1334,30 +1574,22 @@
$table = $short_exists{"$c"};
$col = $c;
}
- else {
- if ($self->command eq 'SELECT') {
-#print "$table.$col\n";
-#if ($col_exists{qq/$table."/.$self->{ORG_NAME}->{$col}.qq/"/}) {
-# $col = q/"/.$self->{ORG_NAME}->{$col}.q/"/;
-#}
-#print qq/$table."$col"/;
-# use mylibs; zwarn $self->{ORG_NAME};
- }
-#use mylibs; zwarn \%col_exists;
-#print "<$table . $col>";
+ elsif (!$col_obj) {
+ my $is_user_def = 1 if $self->{opts}->{function_defs}->{$col};
return $self->do_err("No such column '$table.$col'")
unless $col_exists{"$table.$col"}
- or $col_exists{"\L$table.".$col};
-;# or $col_exists{qq/$table."/.$self->{ORG_NAME}->{$col}.qq/"/}
+ or $col_exists{"\L$table.".$col}
+ or $is_user_def;
+
;
}
- next if $is_fully->{"$table.$col"};
+ next if $table and $col and $is_fully->{"$table.$col"};
####
$self->{"columns"}->[$i]->{"name"} = $col;
####
$self->{"columns"}->[$i]->{"table"} = $table;
- push @$fully_qualified_cols, "$table.$col";
- $is_fully->{"$table.$col"}++;
+ push @$fully_qualified_cols, "$table.$col" if $table and $col;
+ $is_fully->{"$table.$col"}++ if $table and $col;
}
if ( $col eq '*' and defined $table) {
my @newcols;
@@ -1367,12 +1599,38 @@
$self->{"columns"} = \@newcols;
}
}
-#use mylibs; zwarn $fully_qualified_cols;
-
+ # NON-AGGREGATE FUNCTIONS in SELECT LIST
+ for my $i(0..$#{$self->{columns}}) {
+ my $fcname = $self->{columns}->[$i]->name;
+ if (my $col_func = $self->{computed_column}->{$fcname}) {
+ $self->{columns}->[$i] = $col_func;
+ }
+ }
+=pod
+ if ( my $funcs = $self->{select_procedure} ) {
+ for my $i(0..$#{$self->{columns}}) {
+ my $fcname = $self->{columns}->[$i]->name;
+ if (my $col_func=$funcs->{$fcname}) {
+ $self->{columns}->[$i]->{function} =
+ my $alias = $self->{ORG_NAME}->{$fcname};
+ SQL::Statement::Func->new($col_func,$alias);
+ #
+ # USE THE ALIAS FOR THE NAME OF CONSTRUCTED COLUMNS
+ #
+ #$self->{columns}->[$i]->{name}=$self->{ORG_NAME}->{$fcname};
+ $self->{columns}->[$i]->{name}=$alias;
+ }
+ }
+ }
+=cut
+ #
+ # CLEAN parser's {strcut} - no longer needed
+ #
+ delete $self->{opts};
+ delete $self->{select_procedure};
return $fully_qualified_cols;
}
-
sub distinct {
my $self = shift;
return 1 if $self->{"set_quantifier"}
@@ -1380,6 +1638,10 @@
return 0;
}
+sub column_names {
+ my($self)=@_;
+ my @cols = map{$_->name}$self->columns
+}
sub command { shift->{"command"} }
sub params {
@@ -1414,11 +1676,63 @@
}
+=pod
+
+ if (ref $structure eq ) {
+ }
+
+=cut
+
sub get_row_value {
my($self,$structure,$eval,$rowhash) = @_;
- my $type = $structure->{"type"};
- $type = $structure->{"name"} if $type and $type eq 'function';
+# bug($self) unless defined $structure;
+ $structure = '' unless defined $structure;
+ return $rowhash->{$structure} unless ref $structure;
+ my $type = $structure->{"type"} if ref $structure eq 'HASH';
+ $type ||='';
+
+ #################################################################
+ #
+ # USER FUNCTIONS
+ #
+ # if the function hasn't been made into a S::S::Func object yet,
+ # we create a new singlton S::S::Func object, otherwise
+ # we use the existing S::S::Func object
+ #
+ use SQL::Statement::Util;
+ if ( $type eq 'function' and $structure->{name} !~ /(TRIM|SUBSTRING)/i ){
+ $self->{loaded_function}->{$structure->{name}}
+ ||= SQL::Statement::Util::Function->new($structure);
+ $structure = $self->{loaded_function}->{$structure->{name}};
+ }
+ #
+ # Add the arguments from the S::S::Func object to an argslist
+ # then call the function sending the cached sth, the current
+ # rowhash, and the arguments list
+ #
+ if ( ref($structure) =~ /::Function/ ) {
+ my @argslist=();
+ for my $arg(@{$structure->args}) {
+ push @argslist, $self->get_row_value($arg,$eval,$rowhash);
+ }
+ return $structure->run(
+ $self->{procedure}->{data},
+ $rowhash,
+ @argslist
+ );
+# my $sub = $structure->func;
+# return $structure->class->$sub(
+# $self->{procedure}->{data},
+# $rowhash,
+# @argslist
+# );
+ }
+ # end of USER FUNCTIONS
+ #
+ #################################################################
+
return undef unless $type;
+ $type = $structure->{name} if $type eq 'function'; # needed for TRIM+SUBST
for ( $type ) {
/string|number|null/ &&do { return $structure->{"value"} };
/column/ &&do {
@@ -1435,20 +1749,15 @@
return $rowhash->{"$val"};
};
/placeholder/ &&do {
- my $val;
- if ($self->{"join"}) {
- $val = $self->params($arg_num);
- }
- else {
- $val = $eval->param($arg_num);
- }
-
- #my @params = $self->params;
- #die "@params";
- #print "$val ~ $arg_num\n";
- $arg_num++;
-#print "<$arg_num>";
- return $val;
+ my $val;
+ if ($self->{"join"} or !$eval or ref($eval) =~ /Statement$/) {
+ $val = $self->params($arg_num);
+ }
+ else {
+ $val = $eval->param($arg_num);
+ }
+ $arg_num++;
+ return $val;
};
/str_concat/ &&do {
my $valstr ='';
@@ -1463,11 +1772,9 @@
my @vals = @{ $structure->{"vals"} };
my $str = $structure->{"str"};
for my $i(0..$#vals) {
-# use mylibs; zwarn $rowhash;
my $val = $self->get_row_value($vals[$i],$eval,$rowhash);
return $self->do_err(
qq{Bad numeric expression '$vals[$i]->{"value"}'!}
-# ) unless defined $val and $val =~ $numexp;
) unless defined $val and is_number($val);
$str =~ s/\?$i\?/$val/;
}
@@ -1475,21 +1782,21 @@
$str =~ s/^([\)\(+\-\*\/0-9]+)$/$1/; # untaint
return eval $str;
};
-
-#z my $vtype = $structure->{"value"}->{"type"};
- my $vtype = $structure->{"type"};
+#zzz
+ my $vtype = $structure->{"value"}->{"type"};
+# my $vtype = $structure->{"type"};
#z
+ my $value = $structure->{"value"}->{"value"} if ref $structure->{"value"} eq 'HASH';
- my $value = $structure->{"value"}->{"value"};
+### FOR USER-FUNCS
+### my $val_type = $structure->{value}->{type}
+### if ref $structure->{"value"} eq 'HASH';
+###
$value = $self->get_row_value($structure->{"value"},$eval,$rowhash)
if $vtype eq 'function';
- /UPPER/ &&do {
- return uc $value;
- };
- /LOWER/ &&do {
- return lc $value;
- };
+
/TRIM/ &&do {
+
my $trim_char = $structure->{"trim_char"} || ' ';
my $trim_spec = $structure->{"trim_spec"} || 'BOTH';
$trim_char = quotemeta($trim_char);
@@ -1508,24 +1815,70 @@
return substr($value,$start-1,$offset)
if length $value >= $start-2+$offset;
};
+=pod
+ ### USER-FUNCTIONS
+ my $newvalue;
+ if ($val_type and $val_type eq 'multiple_args') {
+ my $args = $structure->{value}->{value};
+ for (@$args) {
+ push @$newvalue, $self->get_row_value($_,$eval,$rowhash);
+ }
+ }
+ $newvalue = [$newvalue] unless ref $newvalue;
+ my $usub = $structure->{usr_sub}->{value};
+ return undef unless $usub;
+ my($class,$sub) = $usub =~ /^(.*::)([^:]+$)/;
+ if (!$sub) {
+ $class = 'main';
+ $sub = $usub;
+ }
+ $class = 'main' if $class eq '::';
+ $class =~ s/::$//;
+ eval { require "$class.pm" }
+ unless $class eq 'SQL::Statement::Functions' or $class eq 'main';
+ die $@ if $@;
+ die "Can't find subroutine $class"."::$sub\n" unless $class->can($sub);
+ # $structure->{data} is $sth and contains $dbh, so passed to subs;
+ $structure->{data} ||= $self->{procedure}->{data};
+ return $class->$sub($structure->{data},$rowhash,@$newvalue);
+=cut
}
}
+#
+# $num_of_cols = $stmt->columns() # number of columns
+# @cols = $stmt->columns() # array of S::S::Column objects
+# $col = $stmt->columns($cnum) # S::S::Column obj for col number $cnum
+# $col = $stmt->columns($cname) # S::S::Column obj for col named $cname
+#
sub columns {
my $self = shift;
- my $col_num = shift;
+ my $col = shift;
if (!$self->{"columns"}) { return 0; }
- if (defined $col_num ) {
- return $self->{"columns"}->[$col_num];
+ if (defined $col and $col =~ /^\d+$/) { # arg1 = a number
+ return $self->{"columns"}->[$col];
}
- if (wantarray) {
+ elsif (defined $col) { # arg1 = string
+ for my $c(@{$self->{"columns"}}) {
+ return $c if $c->name eq $col;
+ }
+ }
+ if (wantarray) { # no arg1, array context
return @{$self->{"columns"}};
}
- else {
+ else { # no arg1,no array context
return scalar @{ $self->{"columns"} };
}
}
+sub colname2colnum{
+ my $self = shift;
+ my $colname = shift;
+ if (!$self->{"columns"}) { return undef; }
+ for my $i(0..$#{$self->{"columns"}}) {
+ return $i if $self->{columns}->[$i]->name eq $colname;
+ }
+}
sub colname2table {
my $self = shift;
my $col_name = shift;
@@ -1533,46 +1886,13 @@
my $found_table;
for my $full_col(@{$self->{all_cols}}) {
my($table,$col) = $full_col =~ /^(.+)\.(.+)$/;
- next unless $col eq $col_name;
+ next unless ($col||'') eq $col_name;
$found_table = $table;
last;
}
return $found_table;
}
-sub colname2tableOLD {
- my $self = shift;
- my $col_name = shift;
- return undef unless defined $col_name;
- my $found;
- my $table;
- my $name;
- my @cur_cols;
-print "<$col_name>";
- for my $c(@{$self->{"columns"}}) {
- $name = $c->{"name"};
-print "[$name]\n";
- $table = $c->{"table"};
- push @cur_cols,$name;
- next unless $name eq $col_name;
- $found++;
- last;
- }
- #print "$table - $name - $col_name\n";
- undef $table unless $found;
- return $table;
- #print "$col_name $table @cur_cols\n";
- if ($found and $found > 1) {
- for (@{$self->{"join"}->{"keycols"}}) {
- return 'shared' if /^$col_name$/;
- }
- # return $self->do_err("Ambiguous column name '$col_name'!");
- }
-
- # print "$table ~ $col_name ~ @cur_cols\n";
- return $table;
-}
-
sub verify_order_cols {
my $self = shift;
my $table = shift;
@@ -1715,7 +2035,19 @@
return $self->{where_clause};
}
+sub get_user_func_table {
+ my($self,$name,$u_func) = @_;
+ my($data_aryref) =$self->get_row_value($u_func,$self,{});
+ my $col_names = shift @$data_aryref;
+ my $tempTable = SQL::Statement::TempTable->new(
+ $name, $col_names, $col_names, $data_aryref
+ );
+ $tempTable->{all_cols} ||= $col_names;
+ return $tempTable;
+}
+#use SQL::Statement::Func;
+
package SQL::Statement::Op;
sub new {
@@ -1767,6 +2099,7 @@
package SQL::Statement::TempTable;
+use base 'SQL::Eval::Table';
sub new {
my $class = shift;
@@ -1787,7 +2120,6 @@
table => $table,
NAME => $name,
};
- # use mylibs; zwarn $self; exit;
return bless $self, $class;
}
sub is_shared {my($s,$colname)=@_;return $s->{"is_shared"}->{"$colname"}}
@@ -1805,7 +2137,6 @@
}
sub fetch_row { my $s=shift; return shift @{ $s->{"table"} } }
-
package SQL::Statement::Order;
sub new ($$) {
@@ -1874,6 +2205,8 @@
return bless $self, $class;
}
+sub value { shift->{"value"} }
+sub type { shift->{"type"} }
sub name { shift->{"name"} }
sub table { shift->{"table"} }
@@ -2642,11 +2975,11 @@
Email: joe at ispsoft.de
Phone: +49 7123 14887
-The current version is Copyright (c) 2001 by
+The current version is Copyright (c) 2001,2005 by
Jeff Zucker
- Email: jeff at vpservices.com
+ Email: jzuckerATcpan.org
All rights reserved.
Property changes on: packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t (from rev 888, packages/libsql-statement-perl/branches/upstream/current/t)
Deleted: packages/libsql-statement-perl/trunk/test.pl
===================================================================
--- packages/libsql-statement-perl/trunk/test.pl 2005-04-05 22:50:51 UTC (rev 888)
+++ packages/libsql-statement-perl/trunk/test.pl 2005-04-05 22:52:12 UTC (rev 889)
@@ -1,146 +0,0 @@
-#!/usr/local/bin/perl -w
-use strict;
-$|=1;
-use lib './lib';
-use SQL::Statement;
-print "[SQL::Statement $SQL::Statement::VERSION]\n";
-my $parser = SQL::Parser->new('ANSI',{RaiseError=>1});
-my $count;
-my @data;
-for (<DATA>) {
- chomp;
- last if /^#/;
- next if /^\s*\/\*/;
- next if /^\s*$/;
- push @data,$_;
-}
-for my $sql(@data) {
- $count++;
- printf "%2d...",$count;
- my $stmt = SQL::Statement->new($sql,$parser);
- #
- # NOTE: RaiseError is on so the program will die here
- # if the SQL can't be parsed
- #
- print "ok! ";
- if ($count % 8 == 0) {
- print "\n";
- }
-}
-__DATA__
- /* DROP TABLE */
-DROP TABLE foo
-DROP TABLE foo CASCADE
-DROP TABLE foo RESTRICT
- /* DELETE */
-DELETE FROM foo
-DELETE FROM foo WHERE id < 7
- /* UPDATE */
-UPDATE foo SET bar = 7
-UPDATE foo SET bar = 7 WHERE id > 7
- /* INSERT */
-INSERT INTO foo VALUES ( 'baz', 7, NULL )
-INSERT INTO foo (col1,col2,col7) VALUES ( 'baz', 7, NULL )
- /* CREATE TABLE */
-CREATE TABLE foo ( id INT )
-CREATE LOCAL TEMPORARY TABLE foo (id INT)
-CREATE LOCAL TEMPORARY TABLE foo (id INT) ON COMMIT DELETE ROWS
-CREATE LOCAL TEMPORARY TABLE foo (id INT) ON COMMIT PRESERVE ROWS
-CREATE GLOBAL TEMPORARY TABLE foo (id INT)
-CREATE GLOBAL TEMPORARY TABLE foo (id INT) ON COMMIT DELETE ROWS
-CREATE GLOBAL TEMPORARY TABLE foo (id INT) ON COMMIT PRESERVE ROWS
-CREATE TABLE foo ( id INTEGER, phrase VARCHAR(40) )
-CREATE TABLE foo ( id INTEGER UNIQUE, phrase VARCHAR(40) UNIQUE )
-CREATE TABLE foo ( id INTEGER PRIMARY KEY, phrase VARCHAR(40) UNIQUE )
-CREATE TABLE foo ( id INTEGER PRIMARY KEY, phrase VARCHAR(40) NOT NULL )
-CREATE TABLE foo ( id INTEGER NOT NULL, phrase VARCHAR(40) NOT NULL )
-CREATE TABLE foo ( id INTEGER UNIQUE NOT NULL, phrase VARCHAR(40) )
- /* JOINS */
-SELECT Lnum,Llet,Ulet FROM zLower NATURAL INNER JOIN zUpper
-SELECT Lnum,Llet,Ulet FROM zLower NATURAL LEFT JOIN zUpper
-SELECT Lnum,Llet,Ulet FROM zLower NATURAL RIGHT JOIN zUpper
-SELECT Lnum,Llet,Ulet FROM zLower NATURAL FULL JOIN zUpper
-SELECT Lnum,Llet,Ulet FROM zLower INNER JOIN zUpper ON Lnum = Unum
-SELECT Lnum,Llet,Ulet FROM zLower LEFT JOIN zUpper ON Lnum = Unum
-SELECT Lnum,Llet,Ulet FROM zLower RIGHT JOIN zUpper ON Lnum = Unum
-SELECT Lnum,Llet,Ulet FROM zLower FULL JOIN zUpper ON Lnum = Unum
-SELECT Lnum,Llet,Ulet FROM zLower INNER JOIN zUpper USING(num)
-SELECT Lnum,Llet,Ulet FROM zLower LEFT JOIN zUpper USING(num)
-SELECT Lnum,Llet,Ulet FROM zLower RIGHT JOIN zUpper USING(num)
-SELECT Lnum,Llet,Ulet FROM zLower FULL JOIN zUpper USING(num)
-SELECT Lnum,Llet,Ulet FROM zLower,zUpper WHERE Lnum = Unum
-SELECT * FROM zLower NATURAL INNER JOIN zUpper
-SELECT * FROM zLower NATURAL LEFT JOIN zUpper
-SELECT * FROM zLower NATURAL RIGHT JOIN zUpper
-SELECT * FROM zLower NATURAL FULL JOIN zUpper
-SELECT * FROM zLower INNER JOIN zUpper ON Lnum = Unum
-SELECT * FROM zLower LEFT JOIN zUpper ON Lnum = Unum
-SELECT * FROM zLower RIGHT JOIN zUpper ON Lnum = Unum
-SELECT * FROM zLower FULL JOIN zUpper ON Lnum = Unum
-SELECT * FROM zLower INNER JOIN zUpper USING(num)
-SELECT * FROM zLower LEFT JOIN zUpper USING(num)
-SELECT * FROM zLower RIGHT JOIN zUpper USING(num)
-SELECT * FROM zLower FULL JOIN zUpper USING(num)
-SELECT * FROM zLower,zUpper WHERE Lnum = Unum
- /* SELECT COLUMNS */
-SELECT id, phrase FROM foo
-SELECT * FROM foo
-SELECT DISTINCT * FROM foo
-SELECT ALL * FROM foo
-SELECT A.*,B.* FROM A,B WHERE A.id=B.id
- /* SET FUNCTIONS */
-SELECT MAX(foo) FROM bar
-SELECT MIN(foo) FROM bar
-SELECT AVG(foo) FROM bar
-SELECT SUM(foo) FROM bar
-SELECT COUNT(foo) FROM foo
-SELECT COUNT(*) FROM foo
-SELECT SUM(DISTINCT foo) FROM bar
-SELECT SUM(ALL foo) FROM bar
- /* ORDER BY */
-SELECT * FROM foo ORDER BY bar
-SELECT * FROM foo ORDER BY bar, baz
-SELECT * FROM foo ORDER BY bar DESC
-SELECT * FROM foo ORDER BY bar ASC
- /* LIMIT */
-SELECT * FROM foo LIMIT 5
-SELECT * FROM foo LIMIT 0, 5
-SELECT * FROM foo LIMIT 5, 10
- /* STRING FUNCTIONS */
-SELECT * FROM foo WHERE UPPER(phrase) = 'bar'
-SELECT * FROM foo WHERE LOWER(phrase) = 'bar'
-SELECT * FROM foo WHERE TRIM( str ) = 'bar'S
-SELECT * FROM foo WHERE TRIM( LEADING FROM str ) = 'bar'
-SELECT * FROM foo WHERE TRIM( TRAILING FROM str ) = 'bar'
-SELECT * FROM foo WHERE TRIM( BOTH FROM str ) = 'bar'
-SELECT * FROM foo WHERE TRIM( LEADING ';' FROM str ) = 'bar'
-SELECT * FROM foo WHERE TRIM( UPPER(phrase) ) = 'bar'
-SELECT * FROM foo WHERE TRIM( LOWER(phrase) ) = 'bar'
-SELECT * FROM foo WHERE blat= SUBSTRING(bar FROM 3 FOR 6)
-SELECT * FROM foo WHERE blat= SUBSTRING(bar FROM 3)
-UPDATE foo SET bar='baz', bop=7, bump=bar+8, blat=SUBSTRING(bar FROM 3 FOR 6)
- /* TABLE NAME ALIASES */
-SELECT * FROM test as T1
-SELECT * FROM test T1
-SELECT T1.id, T2.num FROM test as T1 JOIN test2 as T2 USING(id)
-SELECT id FROM test as T1 WHERE T1.num < 7
-SELECT id FROM test as T1 ORDER BY T1.num
-SELECT a.x,b.y FROM foo AS a, bar b WHERE a.baz = b.bop ORDER BY a.blat
- /* NUMERIC EXPRESSIONS */
-SELECT * FROM foo WHERE 1 = 0 AND baz < (6*foo+11-r)
- /* CASE OF IDENTIFIERS */
-SELECT ID, phRase FROM tEst AS tE WHERE te.id < 3 ORDER BY TE.phrasE
- /* PARENS */
-SELECT * FROM ztable WHERE NOT data IN ('one','two')
-SELECT * from ztable WHERE (aaa > 'AAA')
-SELECT * from ztable WHERE sev = 50 OR sev = 60
-SELECT * from ztable WHERE (sev = 50 OR sev = 60)
-SELECT * from ztable WHERE sev IN (50,60)
-SELECT * from ztable WHERE rc > 200 AND ( sev IN(50,60) )
-SELECT * FROM ztable WHERE data NOT IN ('one','two')
-SELECT * from ztable WHERE (aaa > 'AAA') AND (zzz < 'ZZZ')
-SELECT * from ztable WHERE (sev IN(50,60))
- /* NOT */
-SELECT * FROM foo WHERE NOT bar = 'baz' AND bop = 7 OR NOT blat = bar
-SELECT * FROM foo WHERE NOT bar = 'baz' AND NOT bop = 7 OR NOT blat = bar
-SELECT * FROM foo WHERE NOT bar = 'baz' AND NOT bop = 7 OR blat IS NOT NULL
More information about the Pkg-perl-cvs-commits
mailing list