r958 - 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:13 UTC 2005
Author: gwolf
Date: 2005-04-23 00:56:07 +0000 (Sat, 23 Apr 2005)
New Revision: 958
Added:
packages/libsql-statement-perl/trunk/MANIFEST.SKIP
packages/libsql-statement-perl/trunk/META.yml
packages/libsql-statement-perl/trunk/lib/SQL/Statement/Embed.pod
packages/libsql-statement-perl/trunk/lib/SQL/Statement/Structure.pod
packages/libsql-statement-perl/trunk/lib/SQL/Statement/Syntax.pod
packages/libsql-statement-perl/trunk/t/00error.t
packages/libsql-statement-perl/trunk/t/02executeDirect.t
packages/libsql-statement-perl/trunk/t/03executeDBD.t
packages/libsql-statement-perl/trunk/t/05create.t
packages/libsql-statement-perl/trunk/t/06group.t
packages/libsql-statement-perl/trunk/t/07case.t
packages/libsql-statement-perl/trunk/t/08join.t
packages/libsql-statement-perl/trunk/t/09ops.t
packages/libsql-statement-perl/trunk/t/10limit.t
packages/libsql-statement-perl/trunk/t/11functions.t
packages/libsql-statement-perl/trunk/t/12eval.t
packages/libsql-statement-perl/trunk/t/13call.t
packages/libsql-statement-perl/trunk/t/14allcols.t
packages/libsql-statement-perl/trunk/t/SQLtest.pm
Removed:
packages/libsql-statement-perl/trunk/t/02execute.t
packages/libsql-statement-perl/trunk/t/03join.t
packages/libsql-statement-perl/trunk/t/05create.pl
Modified:
packages/libsql-statement-perl/trunk/Changes
packages/libsql-statement-perl/trunk/MANIFEST
packages/libsql-statement-perl/trunk/debian/changelog
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/Parser.pm
packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm
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/01prepare.t
packages/libsql-statement-perl/trunk/t/04names.t
Log:
New upstream version
Modified: packages/libsql-statement-perl/trunk/Changes
===================================================================
--- packages/libsql-statement-perl/trunk/Changes 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/Changes 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,6 +1,42 @@
Changes log for Perl extension SQL::Statement
+Version 1.13, released 18 April, 2005
+----------------------------------------
+ * pod fixes
+Version 1.12, released 18 April, 2005
+----------------------------------------
+ * added support for GROUP BY
+ (several people sent suggestions for this in the past, please email me
+ so I can credit you, sorry I lost the names)
+
+ * added support for true LIMIT - if a LIMIT clause is specified and
+ no ORDER BY clause is specified, the SELECT will stop searching
+ when the limit is reached; with an ORDER BY clause it will still
+ search the entire table because we can only ORDER a set; using
+ LIMIT without an ORDER BY will greatly increase speed
+
+ * added support for CREATE/DROP keyword|operator|type|function
+
+ * optimized process_predicate to only look up scalars once
+
+ * completely re-wrote the POD
+
+ * fixed bug in primary key search optimization
+ thanks for bug report and test scripts: Jim Lambert, <jimlambrtATmac.com>
+
+ * fixed problem with all_cols slowing inserts
+ thanks for patch and test Cosimo Streppone <cosimoATcpan.org>
+
+ * cleaned up case of temp table column names
+ thanks for bug report: Dan Wright
+
+ * added a META.YML and extra tests
+
+Version 1.11, released 28 March, 2005
+----------------------------------------
+ * fixed bug in "CREATE TABLE AS ..."
+
Version 1.10, released 27 March, 2005
----------------------------------------
* added support for CREATE TABLE AS SELECT ... and CREATE TABLE AS IMPORT()
Modified: packages/libsql-statement-perl/trunk/MANIFEST
===================================================================
--- packages/libsql-statement-perl/trunk/MANIFEST 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/MANIFEST 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,5 +1,7 @@
Changes
MANIFEST
+MANIFEST.SKIP
+META.yml
Makefile.PL
README
lib/SQL/Eval.pm
@@ -8,9 +10,26 @@
lib/SQL/Dialects/ANSI.pm
lib/SQL/Dialects/AnyData.pm
lib/SQL/Dialects/CSV.pm
+lib/SQL/Statement/Embed.pod
lib/SQL/Statement/Functions.pm
lib/SQL/Statement/GetInfo.pm
lib/SQL/Statement/RAM.pm
+lib/SQL/Statement/Structure.pod
+lib/SQL/Statement/Syntax.pod
+lib/SQL/Statement/Util.pm
+t/00error.t
t/01prepare.t
-t/02execute.t
-t/03join.t
+t/02executeDirect.t
+t/03executeDBD.t
+t/04names.t
+t/05create.t
+t/06group.t
+t/07case.t
+t/08join.t
+t/09ops.t
+t/10limit.t
+t/11functions.t
+t/12eval.t
+t/13call.t
+t/14allcols.t
+t/SQLtest.pm
Copied: packages/libsql-statement-perl/trunk/MANIFEST.SKIP (from rev 956, packages/libsql-statement-perl/branches/upstream/current/MANIFEST.SKIP)
Copied: packages/libsql-statement-perl/trunk/META.yml (from rev 956, packages/libsql-statement-perl/branches/upstream/current/META.yml)
Modified: packages/libsql-statement-perl/trunk/debian/changelog
===================================================================
--- packages/libsql-statement-perl/trunk/debian/changelog 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/debian/changelog 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,3 +1,9 @@
+libsql-statement-perl (1.13-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Gunnar Wolf <gwolf at debian.org> Fri, 22 Apr 2005 19:47:18 -0500
+
libsql-statement-perl (1.11-1) unstable; urgency=low
* New upstream release
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Dialects/ANSI.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Dialects/ANSI.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Dialects/ANSI.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,20 +1,5 @@
package SQL::Dialects::ANSI;
-
-=head1 NAME
-
- SQL::Dialects::ANSI -- ANSI config file for SQL::Parse
-
-=head1 SYNOPSIS
-
- see SQL::Parse, SQL::Squish
-
-=head1 DESCRIPTION
-
- The makemaker police say i gotta have one of these
-
-=cut
-
sub get_config {
return <<EOC;
[VALID COMMANDS]
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Dialects/AnyData.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Dialects/AnyData.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Dialects/AnyData.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,20 +1,5 @@
package SQL::Dialects::AnyData;
-
-=head1 NAME
-
- SQL::Dialects::AnyData -- AnyData config file for SQL::Parse
-
-=head1 SYNOPSIS
-
- see SQL::Parse, SQL::Squish
-
-=head1 DESCRIPTION
-
- The makemaker police say i gotta have one of these
-
-=cut
-
sub get_config {
return <<EOC;
[VALID COMMANDS]
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Dialects/CSV.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Dialects/CSV.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Dialects/CSV.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,20 +1,5 @@
package SQL::Dialects::CSV;
-
-=head1 NAME
-
- SQL::Dialects::CSV -- CSV config file for SQL::Parse
-
-=head1 SYNOPSIS
-
- see SQL::Parse, SQL::Squish
-
-=head1 DESCRIPTION
-
- The makemaker police say i gotta have one of these
-
-=cut
-
sub get_config {
return <<EOC;
[VALID COMMANDS]
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Parser.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -15,7 +15,7 @@
use vars qw($VERSION);
use constant FUNCTION_NAMES => join '|', qw( TRIM SUBSTRING );
-$VERSION = '1.11';
+$VERSION = '1.13';
BEGIN { if( $ENV{SQL_USER_DEFS} ) { require SQL::UserDefs; } }
eval { require 'Data/Dumper.pm'; $Data::Dumper::Indent=1};
@@ -138,12 +138,12 @@
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;
+
+ undef $self->{struct}->{set_function}
+ unless $self->{struct}->{has_set_functions};
return $rv;
}
else {
@@ -260,9 +260,20 @@
$newopt =~ s/\s+/ /g;
$self->{"opts"}->{$feature}->{$newopt} = 1;
}
+ $self->create_op_regexen();
+ $self->{"dialect"} = $dialect;
+ $self->{"dialect_set"}++;
+}
+
+sub create_op_regexen {
+ my($self)=@_;
#
# DAA precompute the predicate operator regex's
#
+# JZ moved this into a sub so it can be called from both
+# dialect() and from CREATE_OPERATOR and DROP_OPERATOR
+# since those also modify the available operators
+#
my @allops = keys %{ $self->{"opts"}->{"valid_comparison_operators"} };
#
# complement operators
@@ -295,8 +306,6 @@
#
# end DAA
#
- $self->{"dialect"} = $dialect;
- $self->{"dialect_set"}++;
}
##################################################################
@@ -309,6 +318,12 @@
sub DROP {
my $self = shift;
my $stmt = shift;
+ my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE';
+ if ($stmt =~ /^\s*DROP\s+($features)\s+(.+)$/si ) {
+ my($sub,$arg) = ($1,$2);
+ $sub = 'DROP_' . $sub;
+ return $self->$sub($arg);
+ }
my $table_name;
$self->{"struct"}->{"command"} = 'DROP';
if ($stmt =~ /^\s*DROP\s+TABLE\s+IF\s+EXISTS\s+(.*)$/si ) {
@@ -380,10 +395,11 @@
sub SELECT {
my($self,$str) = @_;
$self->{"struct"}->{"command"} = 'SELECT';
- my($from_clause,$where_clause,$order_clause,$limit_clause);
+ my($from_clause,$where_clause,$order_clause,$groupby_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/^(.+) GROUP BY (.+)$/$1/i ) { $groupby_clause = $2; }
if ( $str =~ s/^(.+?) WHERE (.+)$/$1/i ) { $where_clause = $2; }
if ( $str =~ s/^(.+?) FROM (.+)$/$1/i ) { $from_clause = $2; }
@@ -398,6 +414,9 @@
if ($where_clause) {
return undef unless $self->SEARCH_CONDITION($where_clause);
}
+ if ($groupby_clause) {
+ return undef unless $self->GROUPBY_LIST($groupby_clause);
+ }
if ($order_clause) {
return undef unless $self->SORT_SPEC_LIST($order_clause);
}
@@ -414,7 +433,13 @@
}
return 1;
}
-
+sub GROUPBY_LIST {
+ my($self,$gclause) = @_;
+ return 1 if !$gclause;
+ my @cols = split /,/,$gclause;
+ $self->{struct}->{group_by} = \@cols;
+ return 1;
+}
sub IMPLICIT_JOIN {
my $self = shift;
delete $self->{"struct"}->{"multiple_tables"};
@@ -489,7 +514,7 @@
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;
@@ -700,7 +725,6 @@
$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 {
@@ -711,17 +735,83 @@
$self->{"struct"}->{"procedure"} = $self->ROW_VALUE($stmt);
return 1;
}
+sub CREATE_TYPE {
+ my($self,$type)=@_;
+ $self->{"struct"}->{"command"} = 'CREATE_TYPE';
+ $self->{"struct"}->{"no_execute"} = 1;
+ $self->feature('valid_data_types',uc $type,1);
+}
+sub DROP_TYPE {
+ my($self,$type)=@_;
+ $self->{"struct"}->{"command"} = 'DROP_TYPE';
+ $self->{"struct"}->{"no_execute"} = 1;
+ $self->feature('valid_data_types',uc $type,0);
+}
+sub CREATE_KEYWORD {
+ my($self,$type)=@_;
+ $self->{"struct"}->{"command"} = 'CREATE_KEYWORD';
+ $self->{"struct"}->{"no_execute"} = 1;
+ $self->feature('reserved_words',uc $type,1);
+}
+sub DROP_KEYWORD {
+ my($self,$type)=@_;
+ $self->{"struct"}->{"command"} = 'DROP_KEYWORD';
+ $self->{"struct"}->{"no_execute"} = 1;
+ $self->feature('reserved_words',uc $type,0);
+}
+sub CREATE_OPERATOR {
+ my($self,$stmt)=@_;
+ $self->{"struct"}->{"command"} = 'CREATE_OPERATOR';
+ $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'};
+
+ $self->feature('valid_comparison_operators',uc $func,1);
+ $self->create_op_regexen();
+
+}
+sub DROP_OPERATOR {
+ my($self,$type)=@_;
+ $self->{"struct"}->{"command"} = 'DROP_OPERATOR';
+ $self->{"struct"}->{"no_execute"} = 1;
+ $self->feature('valid_comparison_operators',uc $type,0);
+ $self->create_op_regexen();
+}
+
#########
# CREATE
#########
sub CREATE {
my $self = shift;
my $stmt = shift;
- if ($stmt =~ /^\s*CREATE\s+FUNCTION (.+)$/si ) {
- return $self->CREATE_FUNCTION($1);
+ my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE';
+ if ($stmt =~ /^\s*CREATE\s+($features)\s+(.+)$/si ) {
+ my($sub,$arg) = ($1,$2);
+ $sub = 'CREATE_' . uc $sub;
+ return $self->$sub($arg);
}
- # if ($stmt =~ /^\s*CREATE\s+RAM\s+TABLE\s+(.+)$/si ) {
+# if ($stmt =~ /^\s*CREATE\s+FUNCTION (.+)$/si ) {
+# return $self->CREATE_FUNCTION($1);
+# }
+# if ($stmt =~ /^\s*CREATE\s+TYPE\s+(.+)$/si ) {
+# return $self->CREATE_TYPE($1);
+# }
$stmt =~ s/^CREATE (LOCAL|GLOBAL) /CREATE /si;
if ($stmt =~ /^\s*CREATE\s+(TEMP|TEMPORARY)\s+TABLE\s+(.+)$/si ) {
$stmt = "CREATE TABLE $2";
@@ -990,7 +1080,9 @@
#
if (!$newcol) {
my $func_obj = $self->ROW_VALUE($col);
- if ( ref($func_obj) =~ /::Function$/ ){
+ if ( ref($func_obj) =~ /::Function$/
+or (ref($func_obj)eq 'HASH'and $func_obj->{type}and $func_obj->{type}eq'function')
+){
# die "Functions in the SELECT LIST must have an alias!\n"
# unless defined $alias;
$alias ||= $func_obj->{name};
@@ -1000,6 +1092,7 @@
uc $alias,[],$alias,$func_obj
);
}
+
#
# SELECT_LIST COLUMN IS NOT A COMPUTED COLUMN
#
@@ -1052,21 +1145,23 @@
return undef
if !$count_star and !$ok;
+
if ($set_function_arg !~ /^"/) {
$set_function_arg = uc $set_function_arg;
}
+ $self->{struct}->{has_set_functions}=1;
+
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 {
+ push @{ $self->{"struct"}->{'set_function'}}, {name => $func};
return undef;
# return $self->do_err("Bad set function before FROM clause.");
}
@@ -1726,23 +1821,22 @@
if ( $op =~ s/^(.+) NOT$/$1/i
|| $op =~ s/^NOT (.+)$/$1/i );
- $negated = 1
- if %not and scalar keys %not == 1;
+ $negated = 1 if %not and scalar keys %not == 1;
- return undef
- unless $arg1 = $self->ROW_VALUE($arg1);
+ return undef unless $arg1 = $self->ROW_VALUE($arg1);
- if ($op ne 'USER_DEFINED') { # USER-PREDICATE;
- return undef
- unless $arg2 = $self->ROW_VALUE($arg2);
+ if ($op ne 'USER_DEFINED') { # USER-PREDICATE;
+ return undef unless $arg2 = $self->ROW_VALUE($arg2);
}
+ else {
+# $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,
@@ -2130,13 +2224,18 @@
}
$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) {
+ my $user_func = $col_name;
+ $user_func =~ s/^(\S+).*$/$1/;
+ if ($col_name =~ /(TRIM|SUBSTRING)/i) {
+ # ?
+ }
+ else {
+ 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;
@@ -2534,404 +2633,171 @@
=head1 SYNOPSIS
use SQL::Parser; # CREATE A PARSER OBJECT
- my $parser = SQL::Parser->new( $dialect, \%attrs );
+ my $parser = SQL::Parser->new();
- 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.
+SQL::Parser is part of the SQL::Statement distribution and, most interaction with the parser should be done through SQL::Statement. The methods shown above create and modify a parser object. To use the parser object to parse SQL and to examine the resulting structure, you should use SQL::Statement.
- 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.
+B<Important Note>: Previously SQL::Parser had its own hash-based interface for parsing, but that is now deprecated and will eventually be phased out in favor of the object-oriented parsing interface of SQL::Statement. If you are unable to transition some features to the new interface or have concerns about the phase out, please contact Jeff. See L<The Parse Structure> for details of the now-deprecated hash method if you still need them.
- 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 METHODS
-=head1 SUPPORTED SQL SYNTAX
+=head2 new()
-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:
+Create a new parser object
-=head2 Summary of supported SQL syntax
+ use SQL::Parser;
+ my $parser = SQL::Parser->new();
-B<SQL Statements>
+The new() method creates a SQL::Parser object which can then be
+used to parse and validate the syntax of SQL strings. It takes two
+optional parameters - 1) the name of the SQL dialect that will define
+the syntax rules for the parser and 2) a reference to a hash which can
+contain additional attributes of the parser. If no dialect is specified,
+'AnyData' is the default.
- 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>]
+ use SQL::Parser;
+ my $parser = SQL::Parser->new( $dialect_name, \%attrs );
-B<Explict Join Qualifiers>
+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.
- NATURAL, INNER, OUTER, LEFT, RIGHT, FULL
+The attribute parameter is a reference to a hash that can
+contain error settings for the PrintError and RaiseError
+attributes.
-B<Built-in Functions>
+An example:
- * 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
+ use SQL::Parser;
+ my $parser = SQL::Parser->new('AnyData', {RaiseError=>1} );
-B<Special Utility Functions>
+ 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.
- * 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>
+=head2 dialect()
- = , <> , < , > , <= , >= , IS [NOT] NULL , LIKE , CLIKE , IN , BETWEEN
+ $parser->dialect( $dialect_name ); # load a dialect configuration file
+ my $dialect = $parser->dialect; # get the name of the current dialect
-B<Identifiers> and B<Aliases>
+ For example:
- * 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
+ $parser->dialect('AnyData'); # loads the AnyData config file
+ print $parser->dialect; # prints 'AnyData'
-B<Concatenation>
+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.
- * use either ANSI SQL || or the CONCAT() function
- * e.g. these are the same: {foo || bar} {CONCAT(foo,bar)}
+Loading a new dialect configuration file erases all current
+parser features and resets them to those defined in the
+configuration file.
-B<Comments>
+=head2 feature()
- * comments must occur before or after statements, can't be embedded
- * SQL-style single line -- and C-style multi-line /* */ comments are supported
+Features define the rules to be used by a specific parser
+instance. They are divided into the following classes:
-B<NULLs>
+ * valid_commands
+ * valid_options
+ * valid_comparison_operators
+ * valid_data_types
+ * reserved_words
- * currently NULLs and empty strings are identical, but this will change
- * use {col IS NULL} to find NULLs, not {col=''} (though both currently work)
+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'".
-See below for further details.
+The feature() method allows you to enable, disable, or check the
+status of any feature.
-=head2 CREATE TABLE
+ $parser->feature( $class, $name, 1 ); # enable a feature
-Creates permanenet and in-memory tables.
+ $parser->feature( $class, $name, 0 ); # disable a feature
- CREATE [TEMP] TABLE <table_name> ( <column_definitions> )
- CREATE [TEMP] TABLE <table_name> AS <select statement>
- CREATE [TEMP] TABLE <table_name> AS IMPORT()
+ my $feature = $parser->feature( $class, $name ); # show status of a feature
-Column definitions are standard SQL column names, types, and constraints, see L<Column Definitions>.
+ For example:
- # create a permanent table
- #
- $dbh->do("CREATE TABLE qux (id INT PRIMARY KEY,word VARCHAR(30))");
+ $parser->feature('reserved_words','FOO',1); # make 'FOO' a reserved word
-The "AS SELECT" clause creates and populates the new table using the data and column structure specified in the select statement.
+ $parser->feature('valid_data_types','BLOB',0); # disallow 'BLOB' as a
+ # data type
- # 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");
+ # determine if the LIKE
+ # operator is supported
+ my $LIKE = $parser->feature('valid_operators','LIKE');
-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.
+See the section below on "Backwards Compatibility" for use of
+the feature() method with SQL::Statement 0.1x style parameters.
- # create a temporary table
- #
- $dbh->do("CREATE TEMP TABLE qux (id INT PRIMARY KEY,word VARCHAR(30))");
+=head1 Supported SQL syntax
-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:
+The SQL::Statement distribution can be used to either just parse SQL statements or to execute them against actual data. A broader set of syntax is supported in the parser than in the executor. For example the parser allows you to specify column constraints like PRIMARY KEY. Currently, these are ignored by the execution engine. Likewise syntax such as RESTRICT and CASCADE on DROP statements or LOCAL GLOBAL TEMPPORARY tables in CREATE are supported by the parser but ignored by the executor.
- $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");
+To see the list of Supported SQL syntax formerly kept in this pod, see L<SQL::Statement>.
-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.
+=head1 Subclassing SQL::Parser
- CREATE [ {LOCAL|GLOBAL} TEMPORARY ] TABLE $table
- (
- $col_1 $col_type1 $col_constraints1,
- ...,
- $col_N $col_typeN $col_constraintsN,
- )
- [ ON COMMIT {DELETE|PRESERVE} ROWS ]
+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:
- * col_type must be a valid data type as defined in the
- "valid_data_types" section of the dialect file for the
- current dialect
+=over
- * col_constriaints may be "PRIMARY KEY" or one or both of
- "UNIQUE" and/or "NOT NULL"
+=item C<$self->E<gt>C<get_btwn($string)>
- * 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
+Processes the BETWEEN...AND... predicates; default converts to
+2 range predicates.
- * 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
+=item C<$self->E<gt>C<get_in($string)>
-=head2 DROP TABLE
+Process the IN (...list...) predicates; default converts to
+a series of OR'd '=' predicate, or AND'd '<>' predicates for
+NOT IN.
- DROP TABLE $table [ RESTRICT | CASCADE ]
+=item C<$self->E<gt>C<transform_syntax($string)>
- * 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
+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.
-=head2 INSERT INTO
+=back
- INSERT INTO $table [ ( $col1, ..., $colN ) ] VALUES ( $val1, ... $valN )
+=head1 The parse structure
- * default values are not currently supported
- * inserting from a subquery is not currently supported
+This section outlines the B<now-deprecated> hash interface to the parsed
+structure. It is included B<for backwards compatability only>. You should
+use the SQL::Statement object interface to the structure instead. See L<SQL::Statement>.
-=head2 DELETE FROM
+B<Parse Structures>
- DELETE FROM $table [ WHERE search_condition ]
+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.
- * see "search_condition" below
+B<parse()>
-=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
@@ -3008,7 +2874,7 @@
foo (picture BLOB)' would be valid in the first two dialects but
would produce a syntax error in the 'ANSI' dialect.
-=head2 structure()
+B<structure()>
After a SQL::Parser object has been created and the parse()
method used to parse a SQL string, the structure() method
@@ -3037,95 +2903,7 @@
]
};
-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',
@@ -3169,77 +2947,6 @@
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.
Copied: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Embed.pod (from rev 956, packages/libsql-statement-perl/branches/upstream/current/lib/SQL/Statement/Embed.pod)
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Functions.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Statement/Functions.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Statement/Functions.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -314,9 +314,9 @@
sub SQL_FUNCTION_REGEX {
my($self,$sth,$rowhash, at params)=@_;
return 0 unless defined $params[0] and defined $params[1];
- my($pattern,$modifier) = $params[1] =~ m~^/(.+)/([a-z]+)$~;
- $pattern = "(?$modifier:$pattern)";
- return $params[0] =~ qr($pattern);
+ my($pattern,$modifier) = $params[1] =~ m~^/(.+)/([a-z]*)$~;
+ $pattern = "(?$modifier:$pattern)" if $modifier;
+ return ($params[0] =~ qr($pattern)) ? 1 : 0;
}
=pod
@@ -336,7 +336,7 @@
require Text::Soundex;
my $s1 = Text::Soundex::soundex($params[0]) or return 0;
my $s2 = Text::Soundex::soundex($params[1]) or return 0;
- return $s1 eq $s2;
+ return ($s1 eq $s2) ? 1 : 0;
}
=pod
@@ -478,6 +478,17 @@
sub SQL_FUNCTION_SUBSTITUTE { return SQL_FUNCTION_REPLACE(@_); }
+
+sub SQL_FUNCTION_SUBSTR {
+ my($self,$sth,$rowhash, at params)=@_;
+ my $string = $params[0] || '';
+ my $start = $params[1] || 0;
+ my $offset = $params[2] || length $string;
+ my $value = '';
+ $value = substr($string,$start-1,$offset)
+ if length $string >= $start-2+$offset;
+}
+
=pod
B<SUBSTRING>
@@ -541,8 +552,10 @@
return \@tbl;
}
my $tmp_sth = $params[0];
- my @cols = map{$_->name} $tmp_sth->{f_stmt}->columns if $tmp_sth->{f_stmt};
+# my @cols = map{$_->name} $tmp_sth->{f_stmt}->columns if $tmp_sth->{f_stmt};
+ my @cols;
@cols = @{ $tmp_sth->{NAME} } unless @cols;
+# push @{$sth->{org_names}},$_ for @cols;
my $tbl = [ \@cols ];
while (my @row=$tmp_sth->fetchrow_array) {
push @$tbl, \@row;
@@ -586,7 +599,7 @@
=head1 ACKNOWLEDGEMENTS
-Dean Arnold supplied
+Dean Arnold supplied DECODE, COALESCE, REPLACE, many thanks!
=head1 AUTHOR & COPYRIGHT
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Statement/RAM.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Statement/RAM.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Statement/RAM.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -56,7 +56,8 @@
sub push_names {
my($self, $data, $names) = @_;
$self->{col_names} = $names;
- $self->{parser}->{col_names} = $names;
+ push @{$self->{org_col_names}},$_ for @$names;
+ push @{$self->{parser}->{col_names}},$_ for @$names;
my($col_nums) = {};
for (my $i = 0; $i < @$names; $i++) {
$col_nums->{$names->[$i]} = $i;
Copied: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Structure.pod (from rev 956, packages/libsql-statement-perl/branches/upstream/current/lib/SQL/Statement/Structure.pod)
Copied: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Syntax.pod (from rev 956, packages/libsql-statement-perl/branches/upstream/current/lib/SQL/Statement/Syntax.pod)
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Statement/Util.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Statement/Util.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Statement/Util.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -4,33 +4,7 @@
return 'function' if $self->isa('SQL::Statement::Util::Function');
return 'column' if $self->isa('SQL::Statement::Util::Column');
}
-=pod
-=head1 NAME
-
-SQL::Statement::Util - Objects & Methods for accessing parsed SQL Statements
-
-=head1 SYNOPSIS
-
-=head2 Column Object
-
- Column->name() # column name in upper-case
- Column->display_name() # column alias or name in user-supplied case
- Column->table() # name of table column belongs to, if known
- Column->function() # a Function object, if it's a computed column
-
-=head3 Column->name()
-
-=head3 Column->display_name()
-
-=head3 Column->table()
-
-=head3 Column->function()
-
-=head2 Function Object
-
-=cut
-
package SQL::Statement::Util::Column;
use base 'SQL::Statement::Util';
sub new {
@@ -73,49 +47,10 @@
sub name { shift->{"name"} }
sub table { shift->{"table"} }
-package SQL::Statement::Util::ARRAY::Function; # Just a test, don't use yet
-use base 'SQL::Statement::Util';
-use constant NAME => 0;
-use constant PKG_NAME => 1;
-use constant SUB_NAME => 2;
-use constant ARGS => 3;
-sub new {
- my($class,$name,$sub_name,$args) = @_;
- my($pkg,$sub) = $sub_name =~ /^(.*::)([^:]+$)/;
- if (!$sub) { $pkg = 'main'; $sub = $sub_name }
- $pkg = 'main' if $pkg eq '::';
- $pkg =~ s/::$//;
- return bless [$name,$pkg,$sub,$args],$class;
-}
-sub name { shift->[NAME] }
-sub pkg_name { shift->[PKG_NAME] }
-sub sub_name { shift->[SUB_NAME] }
-sub args { shift->[ARGS] }
-sub validate {
- my($self) = @_;
- my $pkg = $self->pkg_name;
- my $sub = $self->sub_name;
- $pkg =~ s~::~/~g;
- eval { require "$pkg.pm" }
- unless $pkg eq 'SQL/Statement/Functions' or $pkg eq 'main';
- die $@ if $@;
- $pkg =~ s~/~::~g;
- die "Can't find subroutine $pkg"."::$sub\n" unless $pkg->can($sub);
- return 1;
-}
-sub run {
- my($self) = shift;
- my $sub = $self->sub_name;
- my $pkg = $self->pkg_name;
- return $pkg->$sub(@_);
-# return $self->pkg_name->$sub(@_);
-}
-
package SQL::Statement::Util::Function;
use base 'SQL::Statement::Util';
sub new {
my($class,$name,$sub_name,$args) = @_;
- use Data::Dumper;
my($pkg,$sub) = $sub_name =~ /^(.*::)([^:]+$)/;
if (!$sub) {
$pkg = 'main';
@@ -156,27 +91,4 @@
my $pkg = $self->pkg_name;
return $pkg->$sub(@_);
}
-=pod
-
-Value objects
- placeholders, columns, functions, etc.
-
-=head2 SQL::Statement::Func Objects
-
-A new S::S::Func object is created for each function once per prepare, after which, the following methods are available:
-
- name() # function's name, e.g. UPPER
- alias() # function's alias, e.g. c1
- args() # an arrayref of value objects
- class() # name of package holding func's subroutine, e.g. Bar::MyFuncs
- subname() # name of func's subroutine, e.g. SQL_FUNCTION_UPPER
-
-At this point, only the name of the class and sub are known, it isn't known whether there actually is a corresponding subroutine in the class. Value objects in the args arrayref may also be unknown at this point: placeholders and column names have not yet been replaced with values.
-
-Each Func object is validated once per execute, during open_tables(). Validation requires the function's package and checks for the existence of a routine named with the function's subname. An error will be generated if the subroutine can't be found.
-
- validate() # checks if the function corresponds to an available subroutine
-
-
-=cut
1;
Modified: packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm
===================================================================
--- packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/lib/SQL/Statement.pm 2005-04-23 00:56:07 UTC (rev 958)
@@ -11,7 +11,7 @@
use SQL::Parser;
use SQL::Eval;
use SQL::Statement::RAM;
-use vars qw($VERSION $numexp $s2pops $arg_num $dlm $warg_num $HAS_DBI $DEBUG);
+use vars qw($VERSION $new_execute $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(\@_) };
@@ -31,7 +31,7 @@
#use locale;
-$VERSION = '1.11';
+$VERSION = '1.13';
$dlm = '~';
$arg_num=0;
$warg_num=0;
@@ -56,11 +56,11 @@
my $class = shift;
my $sql = shift;
my $flags = shift;
- #
+
# IF USER DEFINED extend_csv IN SCRIPT
# USE THE ANYDATA DIALECT RATHER THAN THE CSV DIALECT
# WITH DBD::CSV
- #
+
if ($main::extend_csv or $main::extend_sql ) {
$flags = SQL::Parser->new('AnyData');
}
@@ -150,7 +150,8 @@
}
for (@$columns) {
my $newcol = $_;
- my $col_obj = delete $self->{col_obj}->{$newcol};
+ # my $col_obj = delete $self->{col_obj}->{$newcol};
+ my $col_obj = $self->{col_obj}->{$newcol};
if ($col_obj and ref($col_obj)=~/::Column$/ ) {
$self->{"computed_column"}->{$newcol} = $col_obj
if defined $col_obj->function;
@@ -184,6 +185,7 @@
sub execute {
my($self, $data, $params) = @_;
+ $new_execute=1;
($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};
@@ -193,15 +195,25 @@
return $self->do_err( 'No command found!') unless $command;
($self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'},
$self->{'data'}) = $self->$command($data, $params);
+
+ # MUNGE COLUMN NAME CASE
+
+ # $sth->{NAME} IS ALWAYS UPPER-CASED DURING PROCESSING
+ #
my $names = $self->{NAME};
+
+ # FOR ASTERISKED QUERIES - WE USE STORED CASE OF COLUMNS
+ #
@$names = map {
- my $org = $self->{ORG_NAME}->{$_}; # from the file header
+ my $org = $self->{ORG_NAME}->{$_};
$org =~ s/^"//;
$org =~ s/"$//;
$org =~ s/""/"/g;
$org;
} @$names if $self->{asterisked_columns};
- $names = $self->{org_col_names} unless $self->{asterisked_columns};
+
+ $names = $self->{org_col_names} unless $self->{asterisked_columns};
+
my $newnames;
#
# DAA
@@ -214,6 +226,7 @@
push @$newnames,$newname;
}
$self->{NAME} = $newnames;
+
my $tables;
@$tables = map {$_->{"name"}} @{ $self->{"tables"} };
delete $self->{'tables'}; # Force closing the tables
@@ -223,54 +236,9 @@
$self->{'NUM_OF_ROWS'} || '0E0';
}
-sub CONNECT ($$$) {
- my($self, $data, $params) = @_;
- if ($self->can('open_connection')) {
- my $dsn = $self->{connection}->{dsn};
- my $tbl = $self->{connection}->{tbl};
- return $self->open_connection($dsn,$tbl,$data,$params)
- }
- (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) = @_;
+ my $names;
# CREATE TABLE AS ...
if (my $subquery = $self->{subquery}) {
my $sth;
@@ -278,15 +246,22 @@
if ($subquery =~ /^IMPORT/i) {
$sth = $data->{Database}->prepare("SELECT * FROM $subquery");
$sth->execute(@$params);
+ $names = $sth->{NAME};
}
# AS SELECT
else {
$sth = $data->{Database}->prepare($subquery);
$sth->execute();
+ $names = $sth->{NAME};
}
+ $names = $sth->{NAME} unless defined $names;
my $tbl_data = $sth->{f_stmt}->{data};
my $tbl_name = $self->tables(0)->name;
- my @tbl_cols = map {$_->name} $sth->{f_stmt}->columns;
+ # my @tbl_cols = map {$_->name} $sth->{f_stmt}->columns;
+ #my @tbl_cols=map{$_->name} $sth->{f_stmt}->columns if $sth->{f_stmt};
+ my @tbl_cols;
+# @tbl_cols=@{ $sth->{NAME} } unless @tbl_cols;
+ @tbl_cols=@{ $names } unless @tbl_cols;
my $create_sql = "CREATE TABLE $tbl_name ";
$create_sql = "CREATE TEMP TABLE $tbl_name "
if $self->{"is_ram_table"};
@@ -344,7 +319,7 @@
my($eval,$all_cols) = $self->open_tables($data, 0, 1);
return undef unless $eval;
$eval->params($params);
- $self->verify_columns($eval, $all_cols) if scalar ($self->columns());
+ $self->verify_columns($data,$eval, $all_cols) if scalar ($self->columns());
my($table) = $eval->table($self->tables(0)->name());
$table->seek($data, 0, 2);
my($array) = [];
@@ -379,7 +354,7 @@
my($eval,$all_cols) = $self->open_tables($data, 0, 1);
return undef unless $eval;
$eval->params($params);
- $self->verify_columns($eval, $all_cols);
+ $self->verify_columns($data,$eval, $all_cols);
my($table) = $eval->table($self->tables(0)->name());
my($affected) = 0;
my(@rows, $array);
@@ -421,7 +396,7 @@
my($eval,$all_cols) = $self->open_tables($data, 0, 1);
return undef unless $eval;
$eval->params($params);
- $self->verify_columns($eval, $all_cols);
+ $self->verify_columns($data,$eval, $all_cols);
my($table) = $eval->table($self->tables(0)->name());
my $tname = $self->tables(0)->name();
my($affected) = 0;
@@ -564,7 +539,7 @@
my($eval,$all_cols) = $self->open_tables($data, 0, 0);
return undef unless $eval;
$eval->params($params);
- $self->verify_columns( $eval, $all_cols );
+ $self->verify_columns( $data,$eval, $all_cols );
if ($self->{"join"}->{"keycols"}
and $self->{"join"}->{"table_order"}
and scalar @{$self->{"join"}->{"table_order"}} == 0
@@ -796,7 +771,7 @@
($eval,$all_cols) = $self->open_tables($data, 0, 0);
return undef unless $eval;
$eval->params($params);
- $self->verify_columns( $eval, $all_cols );
+ $self->verify_columns( $data,$eval, $all_cols );
$tableName = $self->tables(0)->name();
$table = $eval->table($tableName);
}
@@ -933,9 +908,18 @@
if ($self->{"join"}) {
$e = $table;
}
+
+ # begin count for limiting if there's a limit clasue and no order clause
+ #
+ my $limit_count = 0 if $self->limit and !$self->order;
+ my $row_count = 0;
+ my $offset = $self->offset || 0;
while (my $array = $table->fetch_row($data)) {
- if ($self->eval_where($e,$tableName,$array,\%funcs)) {
+ if (eval_where($self,$e,$tableName,$array,\%funcs)) {
+ next if defined($limit_count) and $row_count++ < $offset;
+ $limit_count++ if defined $limit_count;
$array = $self->{fetched_value} if $self->{fetched_from_key};
+
# Note we also include the columns from @extraSortCols that
# have to be ripped off later!
@extraSortCols = () unless @extraSortCols;
@@ -944,8 +928,14 @@
: $self->{func_vals}->{$_} ;
} (@$cList, @extraSortCols);
push(@$rows, \@row);
- return (scalar(@$rows),scalar @{$self->{column_names}},$rows)
- if $self->{fetched_from_key};
+
+ # We quit here if its a primary key search
+ # or if there's a limit clause without order clause
+ # and the limit has been reached
+ #
+ return (scalar(@$rows),$numFields,$rows)
+ if $self->{fetched_from_key}
+ or (defined($limit_count) and $limit_count >= $self->limit);
}
}
if (@order_by) {
@@ -1066,11 +1056,12 @@
}
}
###################################################################
- if (defined $self->{"limit_clause"}) {
- my $offset = $self->{"limit_clause"}->offset || 0;
- my $limit = $self->{"limit_clause"}->limit || 0;
+ if ( defined $self->limit ) {
+ my $offset = $self->offset || 0;
+ my $limit = $self->limit || 0;
@$rows = splice @$rows, $offset, $limit;
}
+ return $self->group_by($rows) if $self->{group_by};
if ($self->{"set_function"}) {
my $numrows = scalar( @$rows );
my $numcols = scalar @{ $self->{"NAME"} };
@@ -1078,7 +1069,7 @@
my %colnum = map {$_=>$i++} @{ $self->{"NAME"} };
for my $i(0 .. scalar @{$self->{"set_function"}} -1 ) {
my $arg = $self->{"set_function"}->[$i]->{"arg"};
- $self->{"set_function"}->[$i]->{"sel_col_num"} = $colnum{$arg} if defined $colnum{$arg};
+ $self->{"set_function"}->[$i]->{"sel_col_num"} = $colnum{$arg} if defined $arg and defined $colnum{$arg};
}
my($name,$arg,$sel_col_num);
my @set;
@@ -1095,7 +1086,8 @@
$final_row[$sf_index]++;
}
else {
- my $v = $c->[$sf->{"sel_col_num"}];
+ my $cn = $sf->{"sel_col_num"};
+ my $v = $c->[$cn] if defined $cn;
my $name = $sf->{"name"};
next unless defined $v;
my $final = $final_row[$sf_index];
@@ -1140,7 +1132,66 @@
}
(scalar(@$rows), $numFields, $rows);
}
+sub group_by {
+ my($self,$rows)=@_;
+# my @columns_requested = map {$_->name} @{$self->{columns}};
+ my $columns_requested = $self->{columns};
+ my $numcols=scalar(@$columns_requested);
+# my $numcols=scalar(@{$self->{"set_function"}});
+ my $i=0;
+ my %colnum = map {$_=>$i++} @{ $self->{"NAME"} };
+# my %colnum = map {$_=>$i++} @columns_requested;
+ my $set_cols;
+ my @all_cols=();
+ my $set_columns = $self->{set_function};
+ for my $c1(@$columns_requested) {
+ for my $c2(@$set_columns) {
+# printf "%s %s\n",$c1->{name}, $c2->{arg};
+ next unless uc $c1->{name} eq uc $c2->{arg};
+ $c1->{arg}= $c2->{arg};
+ $c1->{name}= $c2->{name};
+ last;
+ }
+ push @all_cols,$c1;
+ }
+# $self->{set_function}=\@all_cols;
+
+ for (@{ $self->{"set_function"} }) {
+ push @$set_cols, $_->{name};
+ }
+ my($keycol,$keynum);
+ for my $i(0 .. $numcols-1 ) {
+ my $arg = $self->{"set_function"}->[$i]->{"arg"};
+# print $self->{NAME}->[$i],$arg,"\n";
+ if (!$arg ) {
+ $arg =$set_cols->[$i];
+# $arg =$columns_requested[$i];
+ $keycol = $self->{"set_function"}->[$i]->{"name"};
+ $keynum = $colnum{uc $arg};
+ }
+ $self->{"set_function"}->[$i]->{"sel_col_num"} = $colnum{uc $arg};
+ }
+
+ my $display_cols = $self->{"set_function"};
+ my $numFields = scalar(@$display_cols);
+# my $keyfield = $self->{group_by}->[0];
+# my $keynum=0;
+# for my$i(0..$#{$display_cols}) {
+# $keynum=$i if uc $display_cols->[$i]->{name} eq uc $keyfield;
+#printf "%s.%s,%s\n",$i,$display_cols->[$i]->{name},$keyfield;
+# }
+ my $g = SQL::Statement::Group->new($keynum,$display_cols,$rows);
+ $rows = $g->calc;
+ my $x = [ map {$_->{name}} @$display_cols ];
+ $self->{NAME} = [ map {$_->{name}} @$display_cols ];
+ %{$self->{ORG_NAME}} = map {
+ my $n = $_->{name};
+ $n .= "_" . $_->{arg} if $_->{arg};
+ $_->{name}=>$n;
+ } @$display_cols ;
+ return (scalar(@$rows), $numFields, $rows);
+}
sub anycmp($$) {
my ($a,$b) = @_;
$a = '' unless defined $a;
@@ -1178,9 +1229,18 @@
while ( ($f,$fval) = each %$funcs);
my @truths;
- $arg_num=0;
+ $arg_num=0; # set placeholder start
my $where = $self->{"where_clause"} || return 1;
- return $self->process_predicate ($where,$eval,$rowhash);
+ my $match = $self->process_predicate ($where,$eval,$rowhash);
+
+ # we set the $new_execute flag to 0 to allow reuse;
+ # it's set to 1 at the start of execute()
+ # we set it here because all predicates have been processed
+ # at this point
+ #
+ $new_execute=0; # we don't need to get the reuse values again;
+
+ return $match;
}
@@ -1202,10 +1262,10 @@
# 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);
+ my $match1 = process_predicate($self,$pred->{"arg1"},$eval,$rowhash);
return $pred->{'neg'} ? 0 : 1 if $match1;
- my $match2 = $self->process_predicate($pred->{"arg2"},$eval,$rowhash);
+ my $match2 = process_predicate($self,$pred->{"arg2"},$eval,$rowhash);
# Same logic applies for short-circuit on the second argument.
return $pred->{'neg'} ? 0 : 1 if $match2;
@@ -1214,14 +1274,14 @@
return $pred->{'neg'} ? 1 : 0;
}
elsif ($pred->{op} eq 'AND') {
- my $match1 = $self->process_predicate($pred->{"arg1"},$eval,$rowhash);
+ my $match1 = process_predicate($self,$pred->{"arg1"},$eval,$rowhash);
if ($pred->{"neg"}) {
return 1 unless $match1;
}
else {
return 0 unless $match1;
}
- my $match2 = $self->process_predicate($pred->{"arg2"},$eval,$rowhash);
+ my $match2 = process_predicate($self,$pred->{"arg2"},$eval,$rowhash);
if ($pred->{"neg"}) {
return $match2 ? 0 : 1;
}
@@ -1230,38 +1290,64 @@
}
}
else {
- my $val1 = $self->get_row_value( $pred->{"arg1"}, $eval, $rowhash );
- my $val2 = $self->get_row_value( $pred->{"arg2"}, $eval, $rowhash );
- my $op = $pred->{op};
+
+ # The old way, now replaced, called get_row_value everytime
#
+ # my $val1 = $self->get_row_value( $pred->{"arg1"}, $eval, $rowhash );
+ # my $val2 = $self->get_row_value( $pred->{"arg2"}, $eval, $rowhash );
+
+ # define types that we only need to call get_row_value on once
+ # per execute
+ #
+ my %is_value = map {$_=>1} qw(placeholder string number null);
+
+ # use a reuse value if defined, get_row_value() otherwise
+ #
+ # except we ignore the reuse value if this is the first pass
+ # on an execute() since placeholders need to be reset on the
+ # first pass
+ #
+ # $new_execute is set to 1 at the start of execute()
+ # and set to 0 at the end of eval_where()
+ #
+ my $val1 = (!$new_execute and defined $pred->{arg1}->{reuse})
+ ? $pred->{arg1}->{reuse}
+ : $self->get_row_value( $pred->{"arg1"}, $eval, $rowhash );
+ my $val2 = (!$new_execute and defined $pred->{arg2}->{reuse})
+ ? $pred->{arg2}->{reuse}
+ : $self->get_row_value( $pred->{"arg2"}, $eval, $rowhash );
+
+ # the first time we call get_row_value, we set the reuse value
+ # for the argument object with its scalar value
+ #
+ my $type1 = $pred->{arg1}->{type} if ref($pred->{arg1}) eq 'HASH';
+ my $type2 = $pred->{arg2}->{type} if ref($pred->{arg2}) eq 'HASH';
+ $pred->{arg1}->{reuse} = $val1
+ if $type1 and $is_value{$type1} and $new_execute;
+ $pred->{arg2}->{reuse} = $val2
+ if $type2 and $is_value{$type2} and $new_execute;
+
+ my $op = $pred->{op};
+ my $opfunc = $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 ''
- )) {
- $op = $s2pops->{"$op"}->{'s'};
- }
- 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 = ( is_number($val1) and is_number($val2) )
- ? $s2pops->{"$op"}->{'n'}
- : $s2pops->{"$op"}->{'s'};
- }
- }
+ if ( $op !~ /^IS/i and (
+ !defined $val1 or $val1 eq '' or
+ !defined $val2 or $val2 eq ''
+ )) {
+ $op = $s2pops->{"$op"}->{'s'};
+ }
+ elsif (defined $val1 and defined $val2 and $op !~ /^IS/i ) {
+ $op = ( is_number($val1) and is_number($val2) )
+ ? $s2pops->{"$op"}->{'n'}
+ : $s2pops->{"$op"}->{'s'};
+ }
my $neg = $pred->{"neg"};
- if (ref $eval !~ /TempTable/) {
+ my $table_type = ref($eval);
+ if ($table_type !~ /TempTable/) {
+# if (ref $eval !~ /TempTable/) {
my($table) = $eval->table($self->tables(0)->name());
if ($pred->{op} eq '=' and !$neg and $table->can('fetch_one_row')){
my $key_col = $table->fetch_one_row(1,1);
@@ -1272,7 +1358,20 @@
}
}
}
- my $match = $self->is_matched($val1,$op,$val2) || 0;
+# my $match = $self->is_matched($val1,$op,$val2) || 0;
+ my $match;
+ if ($op) {
+ $match = $self->is_matched($val1,$op,$val2) || 0;
+ }
+ else {
+ my $sub = $self->{opts}->{function_defs}->{uc $opfunc}->{sub}->{value};
+ my $func = $self->{loaded_function}->{uc $opfunc}
+ ||= SQL::Statement::Util::Function->new(
+ uc $opfunc, $sub, [$val1,$val2]
+ );
+ $func->{args}=[$val1,$val2];
+ $match = $self->get_row_value( $func, $eval, $rowhash );
+ }
if ($pred->{"neg"}) {
$match = $match ? 0 : 1;
}
@@ -1314,49 +1413,12 @@
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 '');
- return 0;
- }
- $val1 = '' unless defined $val1;
- $val2 = '' unless defined $val2;
- if ($op eq 'IS') {
- return defined $val1 ? 0 : 1;
- }
- return undef if !defined $val1 or !defined $val2;
- if ($op =~ /LIKE|CLIKE/i) {
- $val2 = quotemeta($val2);
- $val2 =~ s/\\%/.*/g;
- $val2 =~ s/_/./g;
- }
- if ( !$self->{"alpha_compare"} && $op =~ /lt|gt|le|ge/ ) {
- return 0;
- }
- if ($op eq 'LIKE' ) { return $val1 =~ /^$val2$/s; }
- if ($op eq 'CLIKE' ) { return $val1 =~ /^$val2$/si; }
- if ($op eq 'RLIKE' ) { return $val1 =~ /$val2/is; }
- if ($op eq '<' ) { return $val1 < $val2; }
- if ($op eq '>' ) { return $val1 > $val2; }
- if ($op eq '==') { return $val1 == $val2; }
- if ($op eq '!=') { return $val1 != $val2; }
- if ($op eq '<=') { return $val1 <= $val2; }
- if ($op eq '>=') { return $val1 >= $val2; }
- if ($op eq 'lt') { return $val1 lt $val2; }
- if ($op eq 'gt') { return $val1 gt $val2; }
- if ($op eq 'eq') { return $val1 eq $val2; }
- if ($op eq 'ne') { return $val1 ne $val2; }
- if ($op eq 'le') { return $val1 le $val2; }
- if ($op eq 'ge') { return $val1 ge $val2; }
-}
-
-sub data {
+sub fetch {
my($self) = @_;
$self->{data} ||= [];
- return $self->{data};
+ my $row = shift @{ $self->{data} };
+ return undef unless $row and scalar @$row;
+ return $row;
}
sub open_tables {
my($self, $data, $createMode, $lockMode) = @_;
@@ -1383,6 +1445,8 @@
elsif ($data->{Database}->{sql_ram_tables}->{uc $name}) {
$t->{"$name"} = $data->{Database}->{sql_ram_tables}->{uc $name};
$t->{"$name"}->{index}=0;
+ $t->{$name}->init_table($data,$name,$createMode,$lockMode)
+ if $t->{$name}->can('init_table');
}
elsif ( $self->{"is_ram_table"} or !($self->can('open_table'))) {
$t->{"$name"} = $data->{Database}->{sql_ram_tables}->{uc $name}
@@ -1409,7 +1473,10 @@
}
my @cnames;
#$DEBUG=1;
-for my $c(@{$t->{"$name"}->{"col_names"}}) {
+#for my $c(@{$t->{"$name"}->{"col_names"}}) {
+my $table_cols= $t->{"$name"}->{"org_col_names"};
+ $table_cols= $t->{"$name"}->{"col_names"} unless $table_cols;
+for my $c(@$table_cols) {
my $newc;
if ($c =~ /^"/) {
# $c =~ s/^"(.+)"$/$1/;
@@ -1443,16 +1510,30 @@
}
@c = ( @c, @newcols );
}
- my $all_cols = $self->{all_cols}
- || [ map {$_->{name} }@{$self->{columns}} ]
- || [];
- @$all_cols = (@$all_cols, at c);
- $self->{all_cols} = $all_cols;
+ ##################################################
+ # Patch from Cosimo Streppone <cosimoATcpan.org>
+
+ # my $all_cols = $self->{all_cols}
+ # || [ map {$_->{name} }@{$self->{columns}} ]
+ # || [];
+ # @$all_cols = (@$all_cols, at c);
+ # $self->{all_cols} = $all_cols;
+ my $all_cols = [];
+ if(!$self->{all_cols}) {
+ $all_cols = [ map {$_->{name}} @{$self->{columns}} ];
+ $all_cols ||= []; # ?
+ @$all_cols = (@$all_cols, @c);
+ $self->{all_cols} = $all_cols;
+ }
+ ##################################################
return SQL::Eval->new({'tables' => $t}), \@c;
}
-
sub verify_columns {
- my( $self, $eval, $all_cols ) = @_;
+ my( $self, $data,$eval, $all_cols ) = @_;
+ #
+ # NOTE FOR LATER:
+ # perhaps cache column names and skip this after first table open
+ #
$all_cols ||= [];
my @tmp_cols = @$all_cols;
my $usr_cols;
@@ -1606,28 +1687,11 @@
$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
+ # CLEAN parser's {strcut} - no, maybe needed by second execute?
#
- delete $self->{opts};
- delete $self->{select_procedure};
+ # delete $self->{opts}; # need $opts->{function_defs}
+ # delete $self->{select_procedure};
return $fully_qualified_cols;
}
@@ -1676,16 +1740,9 @@
}
-=pod
-
- if (ref $structure eq ) {
- }
-
-=cut
-
sub get_row_value {
my($self,$structure,$eval,$rowhash) = @_;
-# bug($self) unless defined $structure;
+# bug($structure);
$structure = '' unless defined $structure;
return $rowhash->{$structure} unless ref $structure;
my $type = $structure->{"type"} if ref $structure eq 'HASH';
@@ -1713,7 +1770,10 @@
if ( ref($structure) =~ /::Function/ ) {
my @argslist=();
for my $arg(@{$structure->args}) {
- push @argslist, $self->get_row_value($arg,$eval,$rowhash);
+# my $val = $arg unless ref $arg;
+# $val = $self->get_row_value($arg,$eval,$rowhash) unless defined $val;
+ my $val = $self->get_row_value($arg,$eval,$rowhash);
+ push @argslist, $val;
}
return $structure->run(
$self->{procedure}->{data},
@@ -1796,7 +1856,6 @@
if $vtype eq 'function';
/TRIM/ &&do {
-
my $trim_char = $structure->{"trim_char"} || ' ';
my $trim_spec = $structure->{"trim_spec"} || 'BOTH';
$trim_char = quotemeta($trim_char);
@@ -1815,33 +1874,6 @@
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
}
}
@@ -1919,6 +1951,8 @@
#use mylibs; zwarn $self->{"sort_spec_list"}; exit;
}
+sub limit ($) { shift->{limit_clause}->{limit}; }
+sub offset ($) { shift->{limit_clause}->{'offset'}; }
sub order {
my $self = shift;
my $o_num = shift;
@@ -2039,15 +2073,100 @@
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
+ # my $tempTable = SQL::Statement::TempTable->new(
+ # $name, $col_names, $col_names, $data_aryref
+ # );
+ my $tempTable = SQL::Statement::RAM->new(
+ $name, $col_names, $data_aryref
);
$tempTable->{all_cols} ||= $col_names;
return $tempTable;
}
-#use SQL::Statement::Func;
+package SQL::Statement::Group;
+
+sub new {
+ my $class = shift;
+ my ($keycol,$display_cols,$ary)=@_;
+ my $self = {
+ keycol => $keycol,
+ display_cols => $display_cols,
+ records => $ary,
+ };
+ return bless $self, $class;
+}
+sub calc {
+ my $self=shift;
+ $self->ary2hash( $self->{records} );
+ my @cols = @{ $self->{display_cols} };
+ for my $key(@{$self->{keys}}) {
+ my $newrow;
+ my $colnum=0;
+ my %done;
+ my @func;
+ for my $col(@cols) {
+ if ($col->{arg}) {
+ my $selkey = $col->{sel_col_num};
+$selkey ||= 0;
+ if (!defined $selkey) {
+#use mylibs; zwarn $col;
+#exit;
+ }
+ $func[$selkey] = $self->calc_cols($key,$selkey)
+ unless defined $func[$selkey];
+ push @$newrow, $func[$selkey]->{$col->{name}};
+ }
+ else {
+ push @$newrow, $self->{records}->{$key}->[-1]->[$col->{sel_col_num}];
+#use mylibs; zwarn $newrow;
+#exit;
+ }
+ $colnum++;
+ }
+ push @{$self->{final}}, $newrow;
+ }
+ return $self->{final};
+}
+sub calc_cols {
+ my($self,$key,$selcolnum)=@_;
+ # $self->{counter}++;
+ my( $sum,$count,$min,$max,$avg );
+ my $ary = $self->{records}->{$key};
+ for my $row(@$ary) {
+ my $val = $row->[$selcolnum];
+ $max = $val if !(defined $max) or SQL::Statement::anycmp($val,$max) > 0;
+ $min = $val if !(defined $min) or SQL::Statement::anycmp($val,$min) < 0;
+ $count++;
+ $sum += $val if $val =~ $SQL::Statement::numexp;
+ }
+ $avg = $sum/$count if $count and $sum;
+ return {
+ AVG => $avg,
+ MIN => $min,
+ MAX => $max,
+ SUM => $sum,
+ COUNT => $count,
+ };
+}
+
+sub ary2hash {
+ my $self = shift;
+ my $ary = shift;
+ my $keycolnum = $self->{keycol} || 0;
+ my $hash;
+ my @keys;
+ my %is_key;
+ for my $row(@$ary) {
+ my $key = $row->[$keycolnum];
+#die "@$row" unless defined $key;
+ push @{$hash->{$key}}, $row;
+ push @keys, $key unless $is_key{$key}++;
+ }
+ $self->{records}=$hash;
+ $self->{keys} =\@keys;
+}
+
package SQL::Statement::Op;
sub new {
@@ -2156,8 +2275,8 @@
my $self = shift;
bless($self, (ref($proto) || $proto));
}
-sub limit ($) { shift->{'limit'}; }
-sub offset ($) { shift->{'offset'}; }
+#sub limit ($) { shift->{'limit'}; }
+#sub offset ($) { shift->{'offset'}; }
package SQL::Statement::Param;
@@ -2205,8 +2324,8 @@
return bless $self, $class;
}
-sub value { shift->{"value"} }
-sub type { shift->{"type"} }
+#sub value { shift->{"value"} }
+#sub type { shift->{"type"} }
sub name { shift->{"name"} }
sub table { shift->{"table"} }
@@ -2225,771 +2344,85 @@
1;
__END__
+=pod
+
=head1 NAME
SQL::Statement - SQL parsing and processing engine
=head1 SYNOPSIS
- require SQL::Statement;
+ # ... depends on what you want to do, see below
- # Create a parser
- my($parser) = SQL::Parser->new('Ansi');
-
- # Parse an SQL statement
- $@ = '';
- my ($stmt) = eval {
- SQL::Statement->new("SELECT id, name FROM foo WHERE id > 1",
- $parser);
- };
- if ($@) {
- die "Cannot parse statement: $@";
- }
-
- # Query the list of result columns;
- my $numColums = $stmt->columns(); # Scalar context
- my @columns = $stmt->columns(); # Array context
- # @columns now contains SQL::Statement::Column instances
-
- # Likewise, query the tables being used in the statement:
- my $numTables = $stmt->tables(); # Scalar context
- my @tables = $stmt->tables(); # Array context
- # @tables now contains SQL::Statement::Table instances
-
- # Query the WHERE clause; this will retrieve an
- # SQL::Statement::Op instance
- my $where = $stmt->where();
-
- # Evaluate the WHERE clause with concrete data, represented
- # by an SQL::Eval object
- my $result = $stmt->eval_where($eval);
-
- # Execute a statement:
- $stmt->execute($data, $params);
-
-
=head1 DESCRIPTION
-For installing the module, see L<"INSTALLATION"> below.
+The SQL::Statement module implements a pure Perl SQL parsing and execution engine. While it by no means implements full ANSI standard, it does support many features including column and table aliases, built-in and user-defined functions, implicit and explicit joins, complexly nested search conditions, and other features.
-At the moment this POD is lifted straight from Jochen
-Wiedmann's SQL::Statement with the exception of the
-section labeled L<"PURE PERL VERSION"> below which is
-a must read.
+SQL::Statement is a small embeddable Database Management System (DBMS), This means that it provides all of the services of a simple DBMS except that instead of a persistant storage mechanism, it has two things: 1) an in-memory storage mechanism that allows you to prepare, execute, and fetch from SQL statements using temporary tables and 2) a set of software sockets where any author can plug in any storage mechanism.
-The SQL::Statement module implements a small, abstract SQL engine. This
-module is not usefull itself, but as a base class for deriving concrete
-SQL engines. The implementation is designed to work fine with the
-DBI driver DBD::CSV, thus probably not so well suited for a larger
-environment, but I'd hope it is extendable without too much problems.
+There are three main uses for SQL::Statement. One or another (hopefully not all) may be irrelevant for your needs: 1) to access and manipulate data in CSV, XML, and other formats 2) to build your own DBD for a new data source 3) to parse and examine the structure of SQL statements.
-By parsing an SQL query you create an SQL::Statement instance. This
-instance offers methods for retrieving syntax, for WHERE clause and
-statement evaluation.
-
-=head1 PURE PERL VERSION
-
-This version is a pure perl version of Jochen's original SQL::Statement. Eventually I will re-write the POD but for now I will document in this section the ways it differs from Jochen's version only and you can assume that things not mentioned in this section remain as described in the rest of this POD.
-
-=head2 Dialect Files
-
-In the ...SQL/Dialect directory are files that define the valid types, reserved words, and other features of the dialects. Currently the ANSI dialect is available only for prepare() not execute() while the CSV and AnyData dialect support both prepare() and execute().
-
-=head2 New flags
-
-In addition to the dialect files, features of SQL::Statement can be defined by flags sent by subclasses in the call to new, for example:
-
- my $stmt = SQL::Statement->new($sql_str,$flags);
-
- my $stmt = SQL::Statement->new($sql_str, {text_numbers=>1});
-
-=over
-
-=item dialect
-
- Dialect is one of 'ANSI', 'CSV', or 'AnyData'; the default is CSV,
- i.e. the behaviour of the original XS SQL::Statement.
-
-=item text_numbers
-
- If true, this allows texts that look like numbers (e.g. 2001-01-09
- or 15.3.2) to be sorted as text. In the original version these
- were treated as numbers and threw warnings as well as failed to sort
- as text. The default is false, i.e. the original behaviour. The
- AnyData dialect sets this to true by default, i.e. it allows sorting
- of these kinds of columns.
-
-=item alpha_compare
-
- If true this allows alphabetic comparison. The original version would
- ignore SELECT statements with clauses like "WHERE col3 < 'c'". The
- default is false, i.e. the original style. The AnyData dialect sets
- this to true by default, i.e. it allows such comparisons.
-
-=item LIMIT
-
- The LIMIT clause as described by Jochen below never actually made it
- into the execute() portion of his SQL::Statement, it is now supported.
-
-=item RLIKE
-
- There is an experimental RLIKE operator similar to LIKE but takes a
- perl regular expression, e.g.
-
- SELECT * FROM foo WHERE bar RLIKE '^\s*Baz[^:]*:$'
-
- Currently this is only available in the AnyData dialect.
-
-=back
-
-=head2 It's Pure Perl
-
-All items in the pod referring to yacc, C, bison, etc. are now only historical since this version has ported all of those portions into perl.
-
-=head2 Creating a parser object
-
-What's accepted as valid SQL, depends on the parser object. There is
-a set of so-called features that the parsers may have or not. Usually
-you start with a builtin parser:
-
- my $parser = SQL::Parser->new($name, [ \%attr ]);
-
-Currently two parsers are builtin: The I<Ansi> parser implements a proper
-subset of ANSI SQL. (At least I hope so. :-) The I<SQL::Statement> parser
-is used by the DBD:CSV driver.
-
-You can query or set individual features. Currently available are:
-
-=over 8
-
-=item create.type_blob
-
-=item create.type_real
-
-=item create.type_text
-
-These enable the respective column types in a I<CREATE TABLE> clause.
-They are all disabled in the I<Ansi> parser, but enabled in the
-I<SQL::Statement> parser. Example:
-
-=item select.join
-
-This enables the use of multiple tables in a SELECT statement, for
-example
-
- SELECT a.id, b.name FROM a, b WHERE a.id = b.id AND a.id = 2
-
-=back
-
-To enable or disable a feature, for example I<select.join>, use the
-following:
-
- # Enable feature
- $parser->feature("select", "join", 1);
- # Disable feature
- $parser->feature("select", "join", 0);
-
-Of course you can query features:
-
- # Query feature
- my $haveSelectJoin = $parser->feature("select", "join");
-
-The C<new> method allows a shorthand for setting features. For example,
-the following is equivalent to the I<SQL::Statement> parser:
-
- $parser = SQL::Statement->new('Ansi',
- { 'create' => { 'type_text' => 1,
- 'type_real' => 1,
- 'type_blob' => 1 },
- 'select' => { 'join' => 0 }});
-
-
-=head2 Parsing a query
-
-A statement can be parsed with
-
- my $stmt = SQL::Statement->new($query, $parser);
-
-In case of syntax errors or other problems, the method throws a Perl
-exception. Thus, if you want to catch exceptions, the above becomes
-
- $@ = '';
- my $stmt = eval { SQL::Statement->new($query, $parser) };
- if ($@) { print "An error occurred: $@"; }
-
-The accepted SQL syntax is restricted, though easily extendable. See
-L<SQL syntax> below. See L<Creating a parser object> above.
-
-
-=head2 Retrieving query information
-
-The following methods can be used to obtain information about a
-query:
-
-=over 8
-
-=item command
-
-Returns the SQL command, currently one of I<SELECT>, I<INSERT>, I<UPDATE>,
-I<DELETE>, I<CREATE> or I<DROP>, the last two referring to
-I<CREATE TABLE> and I<DROP TABLE>. See L<SQL syntax> below. Example:
-
- my $command = $stmt->command();
-
-=item columns
-
- my $numColumns = $stmt->columns(); # Scalar context
- my @columnList = $stmt->columns(); # Array context
- my($col1, $col2) = ($stmt->columns(0), $stmt->columns(1));
-
-This method is used to retrieve column lists. The meaning depends on
-the query command:
-
- SELECT $col1, $col2, ... $colN FROM $table WHERE ...
- UPDATE $table SET $col1 = $val1, $col2 = $val2, ...
- $colN = $valN WHERE ...
- INSERT INTO $table ($col1, $col2, ..., $colN) VALUES (...)
-
-When used without arguments, the method returns a list of the
-columns $col1, $col2, ..., $colN, you may alternatively use a
-column number as argument. Note that the column list may be
-empty, like in
-
- INSERT INTO $table VALUES (...)
-
-and in I<CREATE> or I<DROP> statements.
-
-But what does "returning a column" mean? It is returning an
-SQL::Statement::Column instance, a class that implements the
-methods C<table> and C<name>, both returning the respective
-scalar. For example, consider the following statements:
-
- INSERT INTO foo (bar) VALUES (1)
- SELECT bar FROM foo WHERE ...
- SELECT foo.bar FROM foo WHERE ...
-
-In all these cases exactly one column instance would be returned
-with
-
- $col->name() eq 'bar'
- $col->table() eq 'foo'
-
-=item tables
-
- my $tableNum = $stmt->tables(); # Scalar context
- my @tables = $stmt->tables(); # Array context
- my($table1, $table2) = ($stmt->tables(0), $stmt->tables(1));
-
-Similar to C<columns>, this method returns instances of
-C<SQL::Statement::Table>. For I<UPDATE>, I<DELETE>, I<INSERT>,
-I<CREATE> and I<DROP>, a single table will always be returned.
-I<SELECT> statements can return more than one table, in case
-of joins. Table objects offer a single method, C<name> which
-
-returns the table name.
-
-=item params
-
- my $paramNum = $stmt->params(); # Scalar context
- my @params = $stmt->params(); # Array context
- my($p1, $p2) = ($stmt->params(0), $stmt->params(1));
-
-The C<params> method returns information about the input parameters
-used in a statement. For example, consider the following:
-
- INSERT INTO foo VALUES (?, ?)
-
-This would return two instances of SQL::Statement::Param. Param objects
-implement a single method, C<$param->num()>, which retrieves the
-parameter number. (0 and 1, in the above example). As of now, not very
-usefull ... :-)
-
-=item row_values
-
- my $rowValueNum = $stmt->row_values(); # Scalar context
- my @rowValues = $stmt->row_values(); # Array context
- my($rval1, $rval2) = ($stmt->row_values(0),
- $stmt->row_values(1));
-
-This method is used for statements like
-
- UPDATE $table SET $col1 = $val1, $col2 = $val2, ...
- $colN = $valN WHERE ...
- INSERT INTO $table (...) VALUES ($val1, $val2, ..., $valN)
-
-to read the values $val1, $val2, ... $valN. It returns scalar values
-or SQL::Statement::Param instances.
-
-=item order
-
- my $orderNum = $stmt->order(); # Scalar context
- my @order = $stmt->order(); # Array context
- my($o1, $o2) = ($stmt->order(0), $stmt->order(1));
-
-In I<SELECT> statements you can use this for looking at the ORDER
-clause. Example:
-
- SELECT * FROM FOO ORDER BY id DESC, name
-
-In this case, C<order> could return 2 instances of SQL::Statement::Order.
-You can use the methods C<$o-E<gt>table()>, C<$o-E<gt>column()> and
-C<$o-E<gt>desc()> to examine the order object.
-
-=item limit
-
- my $l = $stmt->limit();
- if ($l) {
- my $offset = $l->offset();
- my $limit = $l->limit();
- }
-
-In a SELECT statement you can use a C<LIMIT> clause to implement
-cursoring:
-
- SELECT * FROM FOO LIMIT 5
- SELECT * FROM FOO LIMIT 5, 5
- SELECT * FROM FOO LIMIT 10, 5
-
-These three statements would retrieve the rows 0..4, 5..9, 10..14
-of the table FOO, respectively. If no C<LIMIT> clause is used, then
-the method C<$stmt-E<gt>limit> returns undef. Otherwise it returns
-an instance of SQL::Statement::Limit. This object has the methods
-C<offset> and C<limit> to retrieve the index of the first row and
-the maximum number of rows, respectively.
-
-=item where
-
- my $where = $stmt->where();
-
-This method is used to examine the syntax tree of the C<WHERE> clause.
-It returns undef (if no WHERE clause was used) or an instance of
-SQL::Statement::Op. The Op instance offers 4 methods:
-
-=over 12
-
-=item op
-
-returns the operator, one of C<AND>, C<OR>, C<=>, C<E<lt>E<gt>>, C<E<gt>=>,
-C<E<gt>>, C<E<lt>=>, C<E<lt>>, C<LIKE>, C<CLIKE> or C<IS>.
-
-=item arg1
-
-=item arg2
-
-returns the left-hand and right-hand sides of the operator. This can be a
-scalar value, an SQL::Statement::Param object or yet another
-SQL::Statement::Op instance.
-
-=item neg
-
-returns a TRUE value, if the operation result must be negated after
-evalution.
-
-=back
-
-To evaluate the I<WHERE> clause, fetch the topmost Op instance with
-the C<where> method. Then evaluate the left-hand and right-hand side
-of the operation, perhaps recursively. Once that is done, apply the
-operator and finally negate the result, if required.
-
-=back
-
-To illustrate the above, consider the following WHERE clause:
-
- WHERE NOT (id > 2 AND name = 'joe') OR name IS NULL
-
-We can represent this clause by the following tree:
-
- (id > 2) (name = 'joe')
- \ /
- NOT AND
- \ (name IS NULL)
- \ /
- OR
-
-Thus the WHERE clause would return an SQL::Statement::Op instance with
-the op() field set to 'OR'. The arg2() field would return another
-SQL::Statement::Op instance with arg1() being the SQL::Statement::Column
-instance representing id, the arg2() field containing the value undef
-(NULL) and the op() field being 'IS'.
-
-The arg1() field of the topmost Op instance would return an Op instance
-with op() eq 'AND' and neg() returning TRUE. The arg1() and arg2()
-fields would be Op's representing "id > 2" and "name = 'joe'".
-
-Of course there's a ready-for-use method for WHERE clause evaluation:
-
-
-=head2 Evaluating a WHERE clause
-
-The WHERE clause evaluation depends on an object being used for
-fetching parameter and column values. Usually this can be an
-SQL::Eval object, but in fact it can be any object that supplies
-the methods
-
- $val = $eval->param($paramNum);
- $val = $eval->column($table, $column);
-
-See L<SQL::Eval> for a detailed description of these methods.
-Once you have such an object, you can call a
-
- $match = $stmt->eval_where($eval);
-
-
-=head2 Evaluating queries
-
-So far all methods have been concrete. However, the interface for
-executing and evaluating queries is abstract. That means, for using
-them you have to derive a subclass from SQL::Statement that implements
-at least certain missing methods and/or overwrites others. See the
-C<test.pl> script for an example subclass.
-
-Something that all methods have in common is that they simply throw
-a Perl exception in case of errors.
-
-
-=over 8
-
-=item execute
-
-After creating a statement, you must execute it by calling the C<execute>
-method. Usually you put an eval statement around this call:
-
- $@ = '';
- my $rows = eval { $self->execute($data); };
- if ($@) { die "An error occurred!"; }
-
-In case of success the method returns the number of affected rows or -1,
-if unknown. Additionally it sets the attributes
-
- $self->{'NUM_OF_FIELDS'}
- $self->{'NUM_OF_ROWS'}
- $self->{'data'}
-
-the latter being an array ref of result rows. The argument $data is for
-private use by concrete subclasses and will be passed through to all
-methods. (It is intentionally not implemented as attribute: Otherwise
-we might well become self referencing data structures which could
-prevent garbage collection.)
-
-
-=item CREATE
-
-=item DROP
-
-=item INSERT
-
-=item UPDATE
-
-=item DELETE
-
-=item SELECT
-
-Called by C<execute> for doing the real work. Usually they create an
-SQL::Eval object by calling C<$self-E<gt>open_tables()>, call
-C<$self-E<gt>verify_columns()> and then do their job. Finally they return
-the triple
-
- ($self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'},
- $self->{'data'})
-
-so that execute can setup these attributes. Example:
-
- ($self->{'NUM_OF_ROWS'}, $self->{'NUM_OF_FIELDS'},
- $self->{'data'}) = $self->SELECT($data);
-
-
-=item verify_columns
-
-Called for verifying the row names that are used in the statement.
-Example:
-
- $self->verify_columns($eval, $data);
-
-
-=item open_tables
-
-Called for creating an SQL::Eval object. In fact what it returns
-doesn't need to be derived from SQL::Eval, it's completely sufficient
-to implement the same interface of methods. See L<SQL::Eval> for
-details. The arguments C<$data>, C<$createMode> and C<$lockMode>
-are corresponding to those of SQL::Eval::Table::open_table and
-usually passed through. Example:
-
- my $eval = $self->open_tables($data, $createMode, $lockMode);
-
-The eval object can be used for calling C<$self->verify_columns> or
-C<$self->eval_where>.
-
-=item open_table
-
-This method is completely abstract and *must* be implemented by subclasses.
-The default implementation of C<$self->open_tables> calls this method for
-any table used by the statement. See the C<test.pl> script for an example
-of imlplementing a subclass.
-
-=back
-
-
-=head1 SQL syntax
-
-The SQL::Statement module is far away from ANSI SQL or something similar,
-it is designed for implementing the DBD::CSV module. See L<DBD::CSV(3)>.
-
-I do not want to give a formal grammar here, more an informal
-description: Read the statement definition in sql_yacc.y, if you need
-something precise.
-
-The main lexical elements of the grammar are:
-
-=over 8
-
-=item Integers
-
-=item Reals
-
-Syntax obvious
-
-=item Strings
-
-Surrounded by either single or double quotes; some characters need to
-be escaped with a backslash, in particular the backslash itself (\\),
-the NUL byte (\0), Line feeds (\n), Carriage return (\r), and the
-quotes (\' or \").
-
-=item Parameters
-
-Parameters represent scalar values, like Integers, Reals and Strings
-do. However, their values are read inside Execute() and not inside
-Prepare(). Parameters are represented by question marks (?).
-
-=item Identifiers
-
-Identifiers are table or column names. Syntactically they consist of
-alphabetic characters, followed by an arbitrary number of alphanumeric
-characters. Identifiers like SELECT, INSERT, INTO, ORDER, BY, WHERE,
-... are forbidden and reserved for other tokens.
-
-=back
-
-What it offers is the following:
-
-=head2 CREATE
-
-This is the CREATE TABLE command:
-
- CREATE TABLE $table ( $col1 $type1, ..., $colN $typeN,
- [ PRIMARY KEY ($col1, ... $colM) ] )
-
-The column names are $col1, ... $colN. The column types can be
-C<INTEGER>, C<CHAR(n)>, C<VARCHAR(n)>, C<REAL> or C<BLOB>. These
-types are currently completely ignored. So is the (optional)
-C<PRIMARY KEY> clause.
-
-=head2 DROP
-
-Very simple:
-
- DROP TABLE $table
-
-=head2 INSERT
-
-This can be
-
- INSERT INTO $table [ ( $col1, ..., $colN ) ]
- VALUES ( $val1, ... $valN )
-
-=head2 DELETE
-
- DELETE FROM $table [ WHERE $where_clause ]
-
-See L<SELECT> below for a decsription of $where_clause
-
-=head2 UPDATE
-
- UPDATE $table SET $col1 = $val1, ... $colN = $valN
- [ WHERE $where_clause ]
-
-See L<SELECT> below for a decsription of $where_clause
-
-=head2 SELECT
-
- SELECT [DISTINCT] $col1, ... $colN FROM $table
- [ WHERE $where_clause ] [ ORDER BY $ocol1, ... $ocolM ]
-
-The $where_clause is based on boolean expressions of the form
-$val1 $op $val2, with $op being one of '=', '<>', '>', '<', '>=',
-'<=', 'LIKE', 'CLIKE' or IS. You may use OR, AND and brackets to combine
-such boolean expressions or NOT to negate them.
-
-
=head1 INSTALLATION
-For the moment, just unpack the tarball in a private directory. For the moment, I suggest this be somewhere other than where you store your current SQL::Statement and you use this version by a "use lib" referencing the private directory where you unpack it.
+There are no prerequisites for using this as a standalone parser. If you want to access persistant stored data, you either need to write a subclass or use one of the DBI DBD drivers. You can install this module using CPAN.pm, CPANPLUS.pm, PPM, apt-get, or other packaging tools. Or you can download the tar.gz file form CPAN and use the standard perl mantra
-There's no Makefile at this time.
+ perl Makefile.PL
+ make
+ make test
+ make install
+It works fine on all platforms it's been tested on. On Windows, you can use ppm or with the mantra use nmake, dmake, or make depending on which is available.
-=head1 INTERNALS
+=head1 USAGE
-Internally the module is splitted into three parts:
+=head2 How can I use SQL::Statement to access and modify data?
+SQL::Statement provides the SQL engine for a number of existing DBI drivers including L<DBD::CSV>, L<DBD::DBM>, L<DBD::AnyData>, L<DBD::Excel>, L<DBD::Amazon>, and others.
-=head2 Perl-independent C part
+These modules provide access to Comma Separated Values, Fixed Length, XML, HTML and many other kinds of text files, to Excel Spreadsheets, to BerkeleyDB and other DBM formats, and to non-traditional data sources like on-the-fly Amazon searches.
-This part, contained in the files C<sql_yacc.y>, C<sql_data.h>,
-C<sql_data.c> and C<sql_op.c>, is completely independent from Perl.
-It might well be used from within another script language, Tcl say,
-or from a true C application.
+If your interest is in actually accessing and manipulating persistent data, you don't really want to use SQL::Statement directly. Instead, use L<DBI> along with one of the DBDs mentioned above. You'll be using SQL::Statement, but under the hood of the DBD. See L<http://dbi.perl.org> for help with DBI and see L<SQL::Statement::Syntax> for a description of the SQL syntax that SQL::Statement provides for these modules and see the documentation for whichever DBD you are using for additional details.
-You probably ask, why Perl independence? Well, first of all, I
-think this is a valuable target in itself. But the main reason was
-the impossibility to use the Perl headers inside bison generated
-code. The Perl headers export almost the complete Yacc interface
-to XS, for whatever reason, thus redefining constants and structures
-created by your own bison code. :-(
+=head2 How can I use it to parse and examine the structure of SQL statements?
+SQL::Statement can be used stand-alone (without a subclass, without DBI) to parse and examine the structure of SQL statements. See L<SQL::Statement::Structure> for details.
-=head2 Perl-dependent C part
+=head2 How can I use it to embed a SQL engine in a DBD or other module?
-This is contained in C<Statement.xs>. The both C parts communicate via
-a C structure sql_stmt_t. In fact, an SQL::Statement object is nothing
-else than a pointer to such a structure. The XS calls columns(), Table(),
-where(), ... do nothing more than fetching data from this structure
-and converting it to Perl objects. See L<The sql_stmt_t structure>
-below for details on the structure.
+SQL::Statement is designed to be easily embedded in other modules and is especially suited for developing new DBI drivers (DBDs). See L<SQL::Statement::Embed>.
+=head2 What SQL Syntax is supported?
-=head2 Perl part
+SQL::Statement supports a small but powerful subset of SQL commands. See L<SQL::Statement::Syntax>.
-Besides some stub functions for retrieving statement data, this is
-mainly the query processing with the exception of WHERE clause
-evaluation.
+=head2 How can I extend the supported SQL syntax?
+You can modify and extend the SQL syntax either by issuing SQL commands or by subclassing SQL::Statement. See L<SQL::Statement::Syntax>.
-=head2 The sql_stmt_t structure
+=head1 How can I participate in ongoing development?
-This structure is designed for optimal performance. A typical query
-will be parsed with only 4 or 5 malloc() calls; in particular no
-memory will be aquired for storing strings; only pointers into the
-query string are used.
+SQL::Statement is a large module with many potential future directions. You are invited to help plan, code, test, document, or kibbitz about these directions. A sourceforge site will be available soon. If you want to join the development team, or just hear more about the development, write Jeff a note (<jzuckerATcpan.org>.
-The statement stores its tokens in the values array. The array elements
-are of type sql_val_t, a union, that can represent the most interesting
-tokens; for example integers and reals are stored in the data.i and
-data.d parts of the union, strings are stored in the data.str part,
-columns in the data.col part and so on. Arrays are allocated in chunks
-of 64 elements, thus a single malloc() will be usually sufficient for
-allocating the complete array. Some types use pointers into the values
-array: For example, operations are stored in an sql_op_t structure that
-containes elements arg1 and arg2 which are pointers into the value
-table, pointing to other operations or scalars. These pointers are
-stored as indices, so that the array can be extended using realloc().
+=head1 Where can I go for more help?
-The sql_stmt_t structure contains other arrays: columns, tables,
-rowvals, order, ... representing the data returned by the columns(),
-tables(), row_values() and order() methods. All of these contain
-pointers into the values array, again stored as integers.
+For questions about installation or usage, please ask on the dbi-users at perl.org mailing list or post a question on PerlMonks (L<http://www.perlmonks.org/>, where Jeff is known as jZed). If you have a bug report, a patch, a suggestion, write Jeff at the email shown below.
-Arrays are initialized with the _InitArray call in SQL_Statement_Prepare
-and deallocated with _DestroyArray in SQL_Statement_Destroy. Array
-elements are obtained by calling _AllocData, which returns an index.
-The number -1 is used for errors or as a NULL value.
+=head1 ACKNOWLEDGEMENTS
+Jochen Wiedmann created the original module as an XS (C) extension in 1998. Jeff Zucker took over the maintenance in 2001 and rewrote all of the C portions in perl and began extending the SQL support. More recently Ilya Sterin provided help with SQL::Parser, Tim Bunce provided both general and specific support, Dan Wright and Dean Arnold have contributed extensively to the code, and dozens of people from around the world have submitted patches, bug reports, and suggestions. Thanks to all!
-=head2 The WHERE clause evaluation
+If you're interested in helping develop SQL::Statement or want to use it with your own modules, feel free to contact Jeff.
-A WHERE clause is evaluated by calling SQL_Statement_EvalWhere(). This
-function is in the Perl independent part, but it needs the possibility
-to retrieve data from the Perl part, for example column or parameter
-values. These values are retrieved via callbacks, stored in the
-sql_eval_t structure. The field stmt->evalData points to such a
-structure. Of course the calling method can extend the sql_eval_t
-structure (like eval_where in Statement.xs does) to include private data
-not used by SQL_Statement_EvalWhere.
-
-
-=head2 Features
-
-Different parsers are implemented via the sql_parser_t structure. This
-is mainly a set of yes/no flags. If you'd like to add features, do
-the following:
-
-First of all, extend the sql_parser_t structure. If your feature is
-part of a certain statement, place it into the statements section,
-for example "select.join". Otherwise choose a section like "misc"
-or "general". (There's no particular for the section design, but
-structure never hurts.)
-
-Second, add your feature to sql_yacc.y. If your feature needs to
-extend the lexer, do it like this:
-
- if (FEATURE(misc, myfeature) {
- /* Scan your new symbols */
- ...
- }
-
-See the I<BOOL> symbol as an example.
-
-If you need to extend the parser, do it like this:
-
- my_new_rule:
- /* NULL, old behaviour, doesn't use my feature */
- | my_feature
- { YFEATURE(misc, myfeature); }
- ;
-
-Thus all parsers not having FEATURE(misc, myfeature) set will produce
-a parse error here. Again, see the BOOL symbol for an example.
-
-Third thing is to extend the builtin parsers. If they support your
-feature, add a 1, otherwise a 0. Currently there are two builtin
-parsers: The I<ansiParser> in sql_yacc.y and the sqlEvalParser in
-Statement.xs.
-
-Finally add support for your feature to the C<feature> method in
-Statement.xs. That's it!
-
-
-=head1 MULTITHREADING
-
-The complete module code is reentrant. In particular the parser is
-created with C<%pure_parser>. See L<bison(1)> for details on
-reentrant parsers. That means, the module is ready for multithreading,
-as long as you don't share handles between threads. Read-only handles,
-for example parsers, can even be shared.
-
-Statement handles cannot be shared among threads, at least not, if
-you don't grant serialized access. Per-thread handles are always safe.
-
-
=head1 AUTHOR AND COPYRIGHT
-The original version of this module is Copyright (C) 1998 by
+Copyright (c) 2001,2005 by Jeff Zucker: jzuckerATcpan.org
- Jochen Wiedmann
- Am Eisteich 9
- 72555 Metzingen
- Germany
+Portions Copyright (C) 1998 by Jochen Wiedmann: jwiedATcpan.org
- Email: joe at ispsoft.de
- Phone: +49 7123 14887
-
-The current version is Copyright (c) 2001,2005 by
-
- Jeff Zucker
-
- Email: jzuckerATcpan.org
-
All rights reserved.
You may distribute this module under the terms of either the GNU
General Public License or the Artistic License, as specified in
the Perl README file.
-
-=head1 SEE ALSO
-
-L<DBI(3)>, L<DBD::CSV(3)>, L<DBD::AnyData>
-
=cut
Copied: packages/libsql-statement-perl/trunk/t/00error.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/00error.t)
Modified: packages/libsql-statement-perl/trunk/t/01prepare.t
===================================================================
--- packages/libsql-statement-perl/trunk/t/01prepare.t 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/t/01prepare.t 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,11 +1,13 @@
#!perl -w
use strict;
$|=1;
-use lib '../lib';
-use SQL::Statement;
+use lib qw' ./ ./t ';
+use SQLtest;
use Test::More tests => 100;
-print "[SQL::Statement $SQL::Statement::VERSION]\n";
-my $parser = SQL::Parser->new('ANSI',{RaiseError=>1});
+
+$parser = new_parser();
+$parser->{PrintError}=0;
+$parser->{RaiseError}=1;
my $count;
my @data;
for (<DATA>) {
@@ -16,11 +18,7 @@
push @data,$_;
}
for my $sql(@data) {
- ok( my $stmt = SQL::Statement->new($sql,$parser) );
- #
- # NOTE: RaiseError is on so the program will die here
- # if the SQL can't be parsed
- #
+ ok( parse($sql) );
}
__DATA__
/* DROP TABLE */
Deleted: packages/libsql-statement-perl/trunk/t/02execute.t
===================================================================
--- packages/libsql-statement-perl/trunk/t/02execute.t 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/t/02execute.t 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,128 +0,0 @@
-#!/usr/bin/perl -w
-$|=1;
-use strict;
-use lib qw( ../lib );
-use Test::More;
-eval { require DBD::File; };
-if ($@) {
- plan skip_all => "No DBD::File available";
-}
-else {
- plan tests => 16;
-}
-use SQL::Statement; printf "SQL::Statement v.%s\n", $SQL::Statement::VERSION;
-use DBI;
-my $sth;
-my $dbh = DBI->connect('dbi:File(RaiseError=1):');
-
-########################################
-# CREATE, INSERT, UPDATE, DELETE, SELECT
-########################################
-for (split /\n/,
- q{ CREATE TEMP TABLE phrase (id INT,phrase VARCHAR(30))
- INSERT INTO phrase VALUES(1,UPPER(TRIM(' foo ')))
- INSERT INTO phrase VALUES(2,'baz')
- INSERT INTO phrase VALUES(3,'qux')
- UPDATE phrase SET phrase=UPPER(TRIM(LEADING 'z' FROM 'zbar')) WHERE id=3
- DELETE FROM phrase WHERE id = 2 }
-){
- $sth = $dbh->prepare($_);
- ok($sth->execute($_),$sth->{f_stmt}->command);
-}
-$sth = $dbh->prepare("SELECT UPPER('a') AS A,phrase FROM phrase");
-$sth->execute;
-my $str = '';
-while (my $r=$sth->fetch) { $str.="@$r^"; }
-ok($str eq 'A FOO^A BAR^','SELECT');
-ok(2==$dbh->selectrow_array("SELECT COUNT(*) FROM phrase"),'COUNT *');
-
-#################################
-# COMPUTED COLUMNS IN SELECT LIST
-#################################
-ok('B' eq $dbh->selectrow_array("SELECT UPPER('b')"),'COMPUTED COLUMNS IN SELECT LIST');
-
-###########################
-# CREATE function in script
-###########################
-$dbh->do("CREATE FUNCTION froog");
-sub froog { 99 }
-ok('99'eq $dbh->selectrow_array("SELECT froog"),'CREATE FUNCTION from script');
-
-
-###########################
-# CREATE function in module
-###########################
-BEGIN {
- eval "package Foo; sub foo { 88 } 1;"
-}
-$dbh->do(q{CREATE FUNCTION foo NAME "Foo::foo"});
-ok(88 == $dbh->selectrow_array("SELECT foo"), 'CREATE FUNCTION from module');
-
-################
-# LOAD functions
-################
-unlink 'Bar.pm' if -e 'Bar.pm';
-open(O,'>Bar.pm') or die $!;
-print O "package Bar; sub SQL_FUNCTION_BAR{77};1;";
-close O;
-$dbh->do("LOAD Bar");
-ok(77 == $dbh->selectrow_array("SELECT bar"), 'LOAD FUNCTIONS');
-unlink 'Bar.pm' if -e 'Bar.pm';
-
-####################
-# IMPORT($AoA)
-####################
-$sth = $dbh->prepare("SELECT word FROM IMPORT(?) ORDER BY id DESC");
-my $AoA= [ [qw( id word )],
- [qw( 1 Hacker )],
- [qw( 2 Perl )],
- [qw( 3 Another )],
- [qw( 4 Just )] ];
-
-$sth->execute($AoA);
-$str = '';
-while (my $r=$sth->fetch) { $str.="@$r^"; }
-ok($str eq 'Just^Another^Perl^Hacker^','IMPORT($AoA)');
-
-#######################
-# IMPORT($internal_sth)
-#######################
-$dbh->do($_) for split /\n/,<<"";
- CREATE TEMP TABLE tmp (id INTEGER, xphrase VARCHAR(30))
- INSERT INTO tmp VALUES(1,'foo')
-
-my $internal_sth = $dbh->prepare('SELECT * FROM tmp');
-$internal_sth->execute;
-$sth=$dbh->prepare('SELECT * FROM IMPORT(?)');
-$sth->execute($internal_sth);
-$str = '';
-while (my $r=$sth->fetch) { $str.="@$r^"; }
-ok($str eq '1 foo^','IMPORT($internal_sth)');
-
-#######################
-# IMPORT($external_sth)
-#######################
-eval { require DBD::XBase };
-SKIP: {
- skip('No XBase installed',1) if $@;
- ok(external_sth(),'IMPORT($external_sth)');
-};
-
-sub external_sth {
- my $xb_dbh = DBI->connect('dbi:XBase:./');
- unlink 'xb' if -e 'xb';
- $xb_dbh->do($_) for split /\n/,<<"";
- CREATE TABLE xb (id INTEGER, xphrase VARCHAR(30))
- INSERT INTO xb VALUES(1,'foo')
-
- my $xb_sth = $xb_dbh->prepare('SELECT * FROM xb');
- $xb_sth->execute;
- $sth=$dbh->prepare('SELECT * FROM IMPORT(?)');
- $sth->execute($xb_sth);
- $str = '';
- while (my $r=$sth->fetch) { $str.="@$r^"; }
- $xb_dbh->do("DROP TABLE xb");
- return ($str eq '1 foo^');
-}
-ok( $dbh->do("DROP TABLE phrase"), 'DROP TEMP TABLE');
-__END__
Copied: packages/libsql-statement-perl/trunk/t/02executeDirect.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/02executeDirect.t)
Property changes on: packages/libsql-statement-perl/trunk/t/02executeDirect.t
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t/03executeDBD.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/03executeDBD.t)
Property changes on: packages/libsql-statement-perl/trunk/t/03executeDBD.t
___________________________________________________________________
Name: svn:executable
+ *
Deleted: packages/libsql-statement-perl/trunk/t/03join.t
===================================================================
--- packages/libsql-statement-perl/trunk/t/03join.t 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/t/03join.t 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,85 +0,0 @@
-#!/usr/bin/perl -w
-$|=1;
-use strict;
-use Test::More;
-use lib qw( ../lib );
-if ($@) {
- plan skip_all => "No DBD::File available";
-}
-else {
- plan tests => 8;
-}
-use SQL::Statement; printf "SQL::Statement v.%s\n", $SQL::Statement::VERSION;
-use DBI;
-use vars qw($dbh $sth $DEBUG);
-$DEBUG = 0;
-$dbh = DBI->connect('dbi:File(RaiseError=1):');
-$dbh->do($_) for <DATA>;
-
-$sth = $dbh->prepare("SELECT pname,sname FROM Prof NATURAL JOIN Subject");
-ok( 'Sue~Chem^Bob~Bio^Bob~Math^'
- eq query2str($sth),'NATURAL JOIN - with named columns in select list');
-
-
-$sth = $dbh->prepare("SELECT * FROM Prof NATURAL JOIN Subject");
-ok( '1~Sue~Chem^2~Bob~Bio^2~Bob~Math^'
- eq query2str($sth),'NATURAL JOIN - with select list = *');
-
-$sth = $dbh->prepare("
- SELECT UPPER(pname)AS P,Prof.pid,pname,sname FROM Prof NATURAL JOIN Subject
-");
-ok( 'SUE~1~Sue~Chem^BOB~2~Bob~Bio^BOB~2~Bob~Math^'
- eq query2str($sth),'NATURAL JOIN - with computed columns');
-
-$sth = $dbh->prepare("SELECT * FROM Prof LEFT JOIN Subject USING(pid)");
-ok( '1~Sue~Chem^2~Bob~Bio^2~Bob~Math^3~Tom~undef^'
- eq query2str($sth),'LEFT JOIN');
-
-$sth = $dbh->prepare("SELECT * FROM Prof RIGHT JOIN Subject USING(pid)");
-ok( '1~Chem~Sue^2~Bio~Bob^2~Math~Bob^4~English~undef^'
- eq query2str($sth),'RIGHT JOIN');
-
-$sth = $dbh->prepare("SELECT * FROM Prof FULL JOIN Subject USING(pid)");
-ok( '1~Sue~Chem^2~Bob~Bio^2~Bob~Math^3~Tom~undef^4~undef~English^'
- eq query2str($sth),'FULL JOIN');
-
-$sth = $dbh->prepare("
- SELECT * FROM Prof AS P,Subject AS S WHERE P.pid=S.pid
-");
-ok( '1~Sue~1~Chem^2~Bob~2~Bio^2~Bob~2~Math^'
- eq query2str($sth),'IMPLICIT JOIN - two tables');
-
-$sth = $dbh->prepare("
- SELECT *
- FROM Prof AS P,Subject AS S,Room AS R
- WHERE P.pid=S.pid
- AND P.pid=R.pid
-");
-ok( '1~Sue~1~Chem~1~1C^2~Bob~2~Bio~2~2B^2~Bob~2~Math~2~2B^'
- eq query2str($sth),'IMPLICIT JOIN - three tables');
-
-sub query2str {
- my($sth)=@_;
- $sth->execute;
- my $str='';
- while (my $r=$sth->fetch) {
- $str .= sprintf "%s^",join('~',map { defined $_ ? $_ : 'undef' } @$r);
- }
- return $str unless $DEBUG;
- printf "%s\n",join',',@{$sth->{NAME}};
- print "<$str>\n";
- return $str;
-}
-__END__
-CREATE TEMP TABLE Prof (pid INT, pname VARCHAR(30))
-INSERT INTO Prof VALUES (1,'Sue')
-INSERT INTO Prof VALUES (2,'Bob')
-INSERT INTO Prof VALUES (3,'Tom')
-CREATE TEMP TABLE Subject (pid INT, sname VARCHAR(30))
-INSERT INTO Subject VALUES (1,'Chem')
-INSERT INTO Subject VALUES (2,'Bio')
-INSERT INTO Subject VALUES (2,'Math')
-INSERT INTO Subject VALUES (4,'English')
-CREATE TEMP TABLE Room (pid INT, rname VARCHAR(30))
-INSERT INTO Room VALUES (1,'1C')
-INSERT INTO Room VALUES (2,'2B')
Modified: packages/libsql-statement-perl/trunk/t/04names.t
===================================================================
--- packages/libsql-statement-perl/trunk/t/04names.t 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/t/04names.t 2005-04-23 00:56:07 UTC (rev 958)
@@ -3,9 +3,13 @@
use strict;
use Test::More;
use lib qw( ../lib );
+{require DBD::File;}
if ($@) {
- plan skip_all => "No DBD::File available";
+ plan skip_all => "No DBD::File available";
}
+elsif ($DBD::File::VERSION < '0.033' ) {
+ plan skip_all => "Tests require DBD::File => 0.33";
+}
else {
plan tests => 2;
}
@@ -17,7 +21,7 @@
$dbh->do($_) for <DATA>;
$sth = $dbh->prepare("SELECT * FROM Prof");
-ok( 'PID PNAME' eq (join' ',cols($sth)),'Column Names: select list = *');
+ok( 'pid pname' eq (join' ',cols($sth)),'Column Names: select list = *');
$sth = $dbh->prepare("SELECT pname,pID FROM Prof");
ok( 'pname pID' eq (join' ',cols($sth)),'Column Names: select list = named');
Deleted: packages/libsql-statement-perl/trunk/t/05create.pl
===================================================================
--- packages/libsql-statement-perl/trunk/t/05create.pl 2005-04-23 00:55:40 UTC (rev 957)
+++ packages/libsql-statement-perl/trunk/t/05create.pl 2005-04-23 00:56:07 UTC (rev 958)
@@ -1,97 +0,0 @@
-#!/usr/bin/perl -w
-$|=1;
-use strict;
-use Test::More;
-eval { require DBD::File; };
-if ($@) {
- plan skip_all => "No DBD::File available";
-}
-else {
- plan tests => 5;
-}
-use lib qw( ../lib );
-use SQL::Statement; printf "SQL::Statement v.%s\n", $SQL::Statement::VERSION;
-use DBI;
-use vars qw($dbh $sth $DEBUG);
-$dbh = DBI->connect('dbi:File(RaiseError=1):');
-
-########################################
-# CREATE TABLE AS IMPORT($AoA);
-########################################
-my $aoa = [['c1','c2'],[1,9],[2,8] ];
-$dbh->do("CREATE TEMP TABLE aoa AS IMPORT(?)",{},$aoa);
-$sth = $dbh->prepare("SELECT * FROM aoa");
-ok( '1~9^2~8^' eq query2str($sth),'CREATE TABLE AS IMPORT($AoA)' );
-
-########################################
-# CREATE TABLE AS IMPORT($AoH);
-########################################
-my $aoh = [{c1=>1,c2=>9},{c1=>2,c2=>8}];
-$dbh->do("CREATE TEMP TABLE aoh AS IMPORT(?)",{},$aoh);
-$sth = $dbh->prepare("SELECT * FROM aoh");
-ok( '1~9^2~8^' eq query2str($sth),'CREATE TABLE AS IMPORT($AoH)' );
-
-########################################
-# CREATE TABLE AS IMPORT($internal_sth);
-########################################
-$sth = $dbh->prepare("SELECT * FROM aoh");
-$sth->execute;
-$dbh->do("CREATE TEMP TABLE aoi AS IMPORT(?)",{},$sth);
-$sth = $dbh->prepare("SELECT * FROM aoi");
-$sth->execute;
-ok( '1~9^2~8^' eq query2str($sth),'CREATE TABLE AS IMPORT($internal_sth)' );
-
-########################################
-# CREATE TABLE AS IMPORT($external_sth);
-########################################
-eval { require DBD::XBase };
-SKIP: {
- skip('No XBase installed',1) if $@;
- ok(external_sth(),'CREATE TABLE AS IMPORT($external_sth)');
-};
-
-sub external_sth {
- my $xb_dbh = DBI->connect('dbi:XBase:./');
- unlink 'xb' if -e 'xb';
- $xb_dbh->do($_) for split /\n/,<<"";
- CREATE TABLE xb (id INTEGER, xphrase VARCHAR(30))
- INSERT INTO xb VALUES(1,'foo')
-
- my $xb_sth = $xb_dbh->prepare('SELECT * FROM xb');
- $xb_sth->execute;
- $dbh->do("CREATE TEMP TABLE tmpxb AS IMPORT(?)",{},$xb_sth);
- $sth=$dbh->prepare('SELECT * FROM tmpxb');
- $sth->execute;
- my $str='';
- while (my $r=$sth->fetch) { $str.="@$r^"; }
- $xb_dbh->do("DROP TABLE xb");
- return ($str eq '1 foo^');
-}
-
-
-########################
-# CREATE TABLE AS SELECT
-########################
-$dbh->do("CREATE TEMP TABLE tbl_copy AS SELECT * FROM aoa");
-$sth = $dbh->prepare("SELECT * FROM tbl_copy");
-$sth->execute;
-ok( '1~9^2~8^' eq query2str($sth),'CREATE TABLE AS SELECT' );
-
-sub query2str {
- my($sth)=@_;
- $sth->execute;
- my $str='';
- while (my $r=$sth->fetch) {
- $str .= sprintf "%s^",join('~',map { defined $_ ? $_ : 'undef' } @$r);
- }
- return $str unless $DEBUG;
- printf "%s\n",join',',@{$sth->{NAME}};
- print "<$str>\n";
- return $str;
-}
-
-__END__
-#######################
-# IMPORT($external_sth)
-#######################
-__END__
Copied: packages/libsql-statement-perl/trunk/t/05create.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/05create.t)
Property changes on: packages/libsql-statement-perl/trunk/t/05create.t
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t/06group.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/06group.t)
Property changes on: packages/libsql-statement-perl/trunk/t/06group.t
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t/07case.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/07case.t)
Property changes on: packages/libsql-statement-perl/trunk/t/07case.t
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t/08join.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/08join.t)
Property changes on: packages/libsql-statement-perl/trunk/t/08join.t
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t/09ops.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/09ops.t)
Property changes on: packages/libsql-statement-perl/trunk/t/09ops.t
___________________________________________________________________
Name: svn:executable
+ *
Copied: packages/libsql-statement-perl/trunk/t/10limit.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/10limit.t)
Copied: packages/libsql-statement-perl/trunk/t/11functions.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/11functions.t)
Copied: packages/libsql-statement-perl/trunk/t/12eval.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/12eval.t)
Copied: packages/libsql-statement-perl/trunk/t/13call.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/13call.t)
Copied: packages/libsql-statement-perl/trunk/t/14allcols.t (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/14allcols.t)
Copied: packages/libsql-statement-perl/trunk/t/SQLtest.pm (from rev 956, packages/libsql-statement-perl/branches/upstream/current/t/SQLtest.pm)
More information about the Pkg-perl-cvs-commits
mailing list