SQL-Statement-1.407/000755 000765 000024 00000000000 12531016333 014065 5ustar00snostaff000000 000000 SQL-Statement-1.407/Changes000755 000765 000024 00000053014 12531016220 015361 0ustar00snostaff000000 000000 Changes log for Perl extension SQL::Statement 1.407 2015-05-26 * Release 1.406_002 without further changes as 1.407 1.406_002 2015-05-22 [Bug fixes] * Fix RT#104579: Redundant argument in sprintf submitted by Slaven Rezić * Fix RT#104589: t/14parse.t fails if Test::Deep is not installed submitted by Slaven Rezić 1.406_001 2015-05-20 [Misc] * clean up Makefile.PL, meta-data and requirements [Bug fixes] * Fix SQL function CONV to use limited number of sane character sets for conversion and rely on Math::Base::Convert instead of own code (suggested by Tom Wyant in RT#100551, thanks Tom) * fix handling of literal identifiers and for every IMPORT rely on literal identifiers to avoid parser errors for column names starting with numbers or similar * fix capability cache: "$class->can(...)" might return undef and therefore inexistent capabilities are queried to often * Fix COUNT(DISTINCT col) without GROUP BY clause (patch submitted by Grant Mathews, thanks Grant) * Fix "parse insert with functions" submitted via GitHub PR#6 by fecundf and RT#96628 * Fix RT#93320: SQL-style comment can not begin inside quotes by Tom Wyant - thanks Tom [Improvements] * reduce blocks and rewrite some inner statements to increase speed of sql command processing 1.405 2013-06-17 [Bug fixes] * INSERT now expands incomplete rows (Thanks to H.Merijn Brand) 1.404 2013-05-23 [Bug fixes] * re-enable cleanup test_output* after test done * recommend Text::Soundex and do soundex-test only when have it, because it's going to be removed from core for Perl 5.19 (thank Merijn) 1.403 2013-05-22 [Bug fixes] * fix documentation (rt#84889 - thanks Xavier Guimard and Florian, rt#85257 - thanks Andreas Koenig) 1.402 2012-12-19 [Misc] * add Math::Complex 1.56 as recommendation (RT#81926, Sam Ferencik) * add Math::BigInt 1.88 as recommendation (RT#81927, Sam Ferencik) * clarify Test::Simple 1.90 is required for building (RT#81925, Sam Ferencik) [Bug fixes] * fix leaking reference to open tables outside SQL::Statement::execute (fixes RT#81523) * looks_like_number identifies 'nan' as number sometimes (add regex to t/06virtual.t) 1.401 2012-10-29 [Misc] * Switch to 3-digited minor version [Bug fixes] * undo literal replaces in subqueries before passing them to the child parser * Fix doc typo RT#76764 (STEFFENW) - thanks Steffen * Fix typo documented in RT#71914 (reported by Ze'ev Atlas, fixed by H.Merijn Brand) - thanks Ze'ev and Merijn * Fix DROP TABLE behaviour and error detection [Improvements] * Improve documentation/tests for multiple JOIN's from RT#69573 (from BBYRD) with modifications * Filling in the SQL92 gaps for functions (BBYRD) from RT#72638 with minor modifications - thanks Brendan 1.33 2011-02-05 [Bug fixes] * Move test dependencies to (unreleased) Bundle::Test::SQL::Statement to avoid circular dependencies 1.32 2011-01-19 [Bug fixes] * Fixed invalid check for escaped single quotes * Fixed unpermitted modification of array source for table creation (CREATE TABLE AS IMPORT(?),[[..],[..]]) * Fixing alias used in ORDER BY (RT#61384, thanks jvm) * Fixing ORDER BY behavior for multiple sort columns (slower, but guaranteed correct) [Improvements] * renamed fetch-method into fetch_row (keep fetch() as alias) and add a fetch_rows() to fetch all rows at once * Different accessors for direction of ORDER BY clause query part and it's boolean equivalent "desc" (0 or 1, respectively) * Add a lot of Pure-Perl DBD's as build dependency for testing (skip DBD::AnyData for now, because it seems to be broken - check for next release) [Misc] * Bump requirement of DBI to 1.616 * switch for fully external DBD tests from DBD::XBase to DBD::SQLite * Document another limitation (lacking implicit creating temp table during processing a query using the same table with different aliases twice) 1.31 2010-08-16 [Bug fixes] * Fix misbehaviour of DELETE/UPDATE for tables with only basic capabilities and no matching where clause (reported by H.Merijn Brand and Drew ...) * Fix some column identifier splits to respect quoted tables [Improvements] * Optimized some core routines between 25% and 50%. 1.30 2010-08-01 [Bug fixes] * remove blib directory from distfile 1.29 2010-08-01 released August 1st, 2010 [Bug fixes] * add some getters as documented in SQL::Statement::Structure (fixes RT#59834, thanks John Wiersba) * add missing import of function croak to SQL::Statement::Term::ColumnValue * fix assignment of parser result (doesn't run with perl-5.13.3) 1.28 2010-07-15 [Improvements] * Introduce new "capability" method for SQL::Statement and SQL::Eval::Table + Add capability for "insert_new_row" to allow DBD::DBM to fix PK constrain on INSERT statements. * Performance of IMPORT feature improved (thanks to Sven Probst, RT#57322) [Bug fixes] * expect every table object being derived from SQL::Eval::Table * rewrite DELETE and UPDATE command based on table capabilities * add abstract methods for all methods derived classes must override (this means, open_table for SQL::Statement deriveds must be overridden and all data access methods of tables - see SQL::Eval::Table for details) * Tests are fixed to use TEMP TABLES explicitely when required * check for invalid column names fixed * Don't let depreciated parser structures stay alive in SQL::Statement when reusing the Parser [Documentation] * Method documentation of SQL::Statement and SQL::Eval::Table are improved * Add a Roadmap describing future plans for SQL::Statement (in addition to DBD::File::Roadmap). * POD spelling fixes provided by H.Merijn Brand and Pod::Spell::CommonMistakes (thanks Tux) * POD grammar fixes and reasonable sentences created by Martin Evans [Things that may break your code] * SQL::Statement 1.28 is expected not to work proper in combination with DBI 1.611 and below * SQL::Statement::ColumnValue expects now every table being derived from SQL::Eval::Table 1.27 2010-05-06 [Bug fixes] * use originally given table name for open_table() on SELECT, too (all other command still use the originally given name) * warn/die -> carp/croak * fix delete_one_row & update_one_row ability using [Documentation] * Apply spelling fix patch from Ansgar Burchardt (RT#56475) 1.26 2010-04-09 [Bug fixes] * Handle NULL columns in concatenation as empty strings [Improvements] * Change regex's in parser to use \p{Word} instead of \w to allow unicode support [Documentation] * Make clear, that identifiers are handled case insensetive and there is a real good solution provided by DBI which allows to live great with that behaviour. 1.25 2010-03-15 [Bug fixes] * Keep org_table_names with schema information to allow derived table classes to handle as it seems reasonable there * Separate columns with "\0" in multi-column aggregation to be able to difference between ('1','1foo') and ('11','foo') [Misc] * More resources added to META.yml 1.24 2010-03-15 [Misc] * Ignore *.rej in MANIFEST.SKIP (fixes RT #52081 reported by Lars Thegler) [Bug fixes] * Add missing import of _INSTANCE in SQL::Statement::Function::NumericEval fixes RT #52356 - reported by Detlef Pilzecker) * Fix wrongly discarded DISTINCT clause (RT#53186) [Improvements] * Fix parsing errors of plain numbers (RT#16931) * Fix parsing errors of nested calculation / functions (RT#16931, RT#52356) * Rewrite result calculation of aggregation functions (simplify code, speed up) * Upgrade Makefile.PL (patch from Alexandr Ciornii) to handle different EU::MM versions and abilities properly * Update documentation to show how 'column_defs' and SQL::Statement::Term instances shall be used * Introduce SQL::Dialect::Role providing ini-style data access to SQL::Dialects (patch from Michael Schwern) [Things that may break your code] * SQL::Parser now didn't deliver a struct containing 'column_names', 'computed_columns' and 'set_functions' - it's combined into one member 'column_defs'. * Minimum required perl version is now 5.8 - upcoming next version of DBI requires perl 5.8, too - and I could simplify some code that's why 1.23 2009-11-20 [Misc] * Applied patch from Marc Espie which fixes several orthographic errors in SQL::Statement::Syntax documentation. * Added a fixed version of test reported via RT #34121 [Bug fixes] * Fix an issue in UPDATE command which 'shift's the values from the list of parameters which causes there're no more parameters left after first row get's updated (Fixes RT #50788) * Fix aggregate function handling of new code since 1.21_01 * Correct handling of DISTINCT in aggregate functions [Improvements] * Add support for tables/columns starting with '_' for CSV and AnyData, which is usually forbidden by ANSI SQL * Add support for inserting multiple lines with one statement (fixes RT #31730) * Handle ANSI 'IS NULL' and CVS/AnyData 'IS NULL' different [Things that may break your code] * row_value now expects up to two arguments 1.22 2009-10-10 [Misc] * Add missing changelog - no code changes 1.21 2009-10-10 [Misc] * remove version dependency to check previously installed version * add DBD::File as "Test" requirement 1.21_8 2009-10-05 [Bug fixes] * Add additional test for bug-fix in 1.21_7 to t/18bigjoin.t [Misc] * Correct some typo's in POD 1.21_7 2009-09-31 [Bug fixes] * Don't fail for non-existent columns introduced by functions in joins 1.21_6 2009-09-24 [Bug fixes] * Don't abort Makefile.PL when in automated smoke tests 1.21_5 2009-09-23 [Bug fixes] * table order isn't wrongly used in order of appearance when SQL::Parser couldn't determine an order * Some internal fixes [Misc] * Updated dependency to Params::Util to non-leaking 1.00 * Note dependency to Carp and Data::Dumper * rely on version to compare versions * Update POD for terms * Update 1.21_4 2009-09-21 [Bug fixes] * modify regex to match types to fix problems with Perl 5.6.2 * add DESTROY methods to ensure clean up * fix lower casing internal table names when joining tables * replace parameter shifting by assigning @_ to the list of parameters 1.21_3 2009-09-17 [Things that may break your code] * When someone accesses the where_clause attribute of the SQL::Statement instance - be aware that now IN and BETWEEN can be native entries [Bug fixes] * convert operation to upper case when surely initialized [Improvements] * IN and BETWEEN are now native operations - they are not expanded to OR'ed equalize operations anymore 1.21_2 2009-09-15 [Things that may break your code] * modify behavior for unquoted identifiers - they're converted and returned lower cased now (instead upper cased as in 1.21_1) Fixes bug RT #48502 1.21_1 2009-07-30 [Things that may break your code] * removed SQL::Statement::Column * don't instantiate SQL::Statement::Functions objects * Reworked internal column and function handling to reduce code complexity * rows and columns aren't setable from outside a table or eval object anymore [Bug fixes and other changes] * Fixed bugs: + RT #47292: Test failures with recent DBI + RT #44512: Patch for CREATE TABLE parsing + RT #42676: tests 16 failed 1.20 2009-03-05 * Fixed Makefile in MANIFEST (reported by Havard Eidnes in RT #43586) * Fixed invalid label FETCHROW used (reported by Michael in RT #42982) * separated update_one_row and update_specific_row method names for tables to avoid confusion 1.19 2009-02-06 * Fixed OUTER JOIN behavior * Added version info to all *.pm files to allow CPAN::Reporter find updates * Correct META-Files * Fixed reported bugs: 1.18_02 2009-01-20 * Additional (profiled) optimizations for complicated where clauses 1.18_01 2009-01-12 * No code changes within SQL::Statement - but deliver and execute additional tests. 1.17 2009-01-12 * Fixed bug: RT#42263: GROUP BY doesn't group on multiple columns 1.16_04 2009-01-04 * added tests to prove valid quoting (most of them fail) * Reformat the source * add some (profiled) tweaks as removing useless regex to speed up SELECT [Bug fixes] * 14217 Does not correctly handle SQL statements with comments * 15686 Join syntax is case-sensitive, and common columns in natural joins are "ambiguous" [patch] * 13080 Cannot update a field based on its previous value * 26058 functions on computed columns aliased to the underlying column name are not called 1.16_03 2009-01-01 * removed *.orig and *.rej relics 1.16_02 2009-01-01 * Changing join_2_tables to reduce memory usage when joining a lot of tables [Bug fixes] * 15688 Columns aliased with double quotes are a fatal error * 16579 Speed optimizations * 30590 Bug in SQL::Statement::is_number() * 41875 Bug in synopsis example 1.16_01 2009-01-01 * With this release, I'd like to welcome Jens Rehsack as co-maintainer of the SQL::Statement and SQL::Parser modules. Jens has added in some great improvements. Thanks Jens! -- Jeff * Adding a lot of join tests (once from Jeff, 48 from PostgreSQL official handbook) - no error of them will be corrected in the first run Thanks to Alexander Breibach -- Jens 1.15 2006-02-02 * fixed placeholder bug in SQL::Statement::UPDATE thanks for bug report Tanktalus 1.14 2005-04-21 * fixed circular dependency in tests (one mistakenly required AnyData) 1.13 2005-04-18 * pod fixes 1.12 2005-04-18 * 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, * fixed problem with all_cols slowing inserts thanks for patch and test Cosimo Streppone * cleaned up case of temp table column names thanks for bug report: Dan Wright * added a META.YML and extra tests 1.11 2005-03-28 * fixed bug in "CREATE TABLE AS ..." 1.10 2005-03-27 * added support for CREATE TABLE AS SELECT ... and CREATE TABLE AS IMPORT() * added support for in-memory tables and heterogeneous operations, see the SQL::Parser docs * added many new built-in functions see SQL::Statement::Functions.pm * added support for user-defined functions, see SQL::Statement::Functions.pm * added support for column name aliases thanks for patch, Robert Rothenberg * added support for comparison to empty string (e.g. WHERE col1='') currently returns the same as WHERE col1 IS NULL thanks for patch, cpanATgoess.org * fixed bug in S::P::clean_sql() newline-handling, thanks for patch Steffen G., steffenATkonzeptloses.de * fixed bug in SQL::Parser::feature() thanks for patch, chromatic * the word "INTO" is now optional in "INSERT INTO tblname ..." * the word "FROM" is now optional in "DELETE FROM tblname ..." thanks for suggestion, gipeol@sci.kun.nl * optimized portions of eval_where, process_predicate, and is_matched HUGE thanks Dan Wright and Dean Arnold for patches * HUGE thanks to Dean Arnold for all the following which should clean up a number of bugs in parentheses parsing and in the predicates IN and BETWEEN as well as speed things up considerably [SQL::Parser changes] * removed recursion from get_in(), get_btwn() * fixed paren scan and argument separator scan in get_in() * optimized get_in/get_btwn code * made get_in/get_btwn OO methods to support being overridden by subclasses * added transform_syntax() abstract method to permit subclasses to add their own syntax extensions * rewrite of parens_search() to fixed predicate paren processing, remove recursion, and optimize code * rewrite of non_parens_search() to fixed predicate paren processing and optimize code * rewrite of PREDICATE to optimize code; moved operator regex construction to dialect initialization * change undo_string_funcs(), undo_math_funcs(), nongroup_numeric(), nongroup_string() to remove scoped recursion * fixed nongroup_numeric() for case insensitive operator match * fixed nongroup_string, undo_string_funcs() to include user defined funcs * fixed ROW_VALUE's scan for user defined function argument separator scan * fixed function detection regex in SQL::Parser::ROW_VALUE to accomodate arbitrary spacing * fixed SQL::Parser::SELECT_LIST()/extract_column_list() to support concat operator '||' expressions * added following functions to SQL::Statement::Functions: COALESCE; NVL (same as COALESCE); DECODE (same as Oracle DECODE); CONCAT; REPLACE/SUBSTITUTE * fixed/adapted SQL::Statement::get_row_value(), SQL::Statement::SELECT(), for join'ed resultsets 1.09 2004-04-22 * fixed parens parsing bug reported by Dan Wright, thanks! 1.08 2004-04-20 * fixed bug in JOIN handling introduced in 1.06 1.07 2004-04-20 * fixed infinite recursion bug with empty IN() predicate thanks chromatic, for the patch * fixed case issues with table aliases in joins thanks chromatic, for bug report 1.06 2004-04-18 * column and table name hashes now default to case sensitive * where() method now supported as per the docs 1.005 2002-10-26 * added support for MySQL-like "DROP TABLE IF EXISTS" * fixed bug in dotted column names e.g. tableA.colB * fixed bug in MAX and MIN (thanks Michael Kovacs, mkovacs@turing.une.edu.au) * fixed bug in ORDER BY (when col names not in SELECT list) Thanks Janet Goldstein 1.004 2002-03-13 * added support for delimited identifiers (inside double quotes); these are case sensitive and can contain spaces and other special chars * added support for two forms of escaping single quotes inside quoted values: 'O\'Brien' or 'O''Brien' * added support for both C-Style and SQL-Style double-hypen comments, e.g. /* comment */ or -- comment * added GetInfo.pm for use with $dbh->get_info() * updated the readme file * fixed bug in update that refers to its own columns (e.g. SET num = num + 2) * fixed bug in MIN and MAX when used with strings Thanks Dean Kopesky 1.003 2002-03-01 * identifiers (names of columns, tables, and table name aliases) are now all case insensitive as required by the SQL standard. all older versions including the XS versions used case sensitive column names * added numerous examples to test.pl * improved and/or fixed bugs in: * placeholder support Thanks Achim Grolms * ORDER BY clause Thanks Jan Stocker * LIKE/CLIKE/RLIKE/IN predicates Thanks Udo Beckmann * table name aliases in explicit joins 1.002 2002-02-05 * added backwards compatiblity: both SQL::Statement and SQL::Parser now work in perl version 5.004 and above. * changed defaults for DBD::CSV so it now accepts new SQL without adding extra flags to scripts * added support for SQL comments * added support for temporary tables and on commit clauses in CREATE statements and drop behaviour flags in DROP statements (SQL::Parser only, not supported by SQL::Statement) * fixed bugs in qualified column names (e.g. tableA.*), and in joins using ON or WHERE 1.001 2002-01-17 * Fixed bug in UPDATE that caused the new value to be a hash rather than a scalar. 1.0 2002-01-15 This is the first CPAN release of the pure perl version of the module. It was previously released in an XS version by Jochen Wiedman who has turned over maintenance of it to me. The new Pure Perl version of SQL::Statement supports everything supported by the XS version and, additionally, at least partial support for the following features that are not supported at all by the XS version: * Explicit and implicit joins * Table name aliases * Set functions * String functions * String concatenation * Numeric expressions * IN predicate * BETWEEN predicate * Alphabetic comparison in WHERE clauses * Ordering of text that looks like a number * Verbose error messages for both Parsing and Execution errors SQL-Statement-1.407/lib/000755 000765 000024 00000000000 12531016333 014633 5ustar00snostaff000000 000000 SQL-Statement-1.407/Makefile.PL000755 000765 000024 00000015021 12527533364 016056 0ustar00snostaff000000 000000 # -*- perl -*- use 5.008; use strict; use warnings; use ExtUtils::MakeMaker; my $conflictMsg = < 0, 'Clone' => '0.30', 'Data::Dumper' => 0, 'Module::Runtime' => 0, 'Params::Util' => '1.00', 'Scalar::Util' => '1.0', 'Text::Balanced' => 0, ); my %CONFIGURE_DEPS = ( 'ExtUtils::MakeMaker' => 0, ); my %BUILD_DEPS = (); my %TEST_DEPS = ( 'Math::Complex' => '1.56', 'Math::Base::Convert' => 0, 'Test::Deep' => 0, 'Test::More' => '0.90', 'Text::Soundex' => '3.04', ); my %CONFLICTS = ( 'SQL::Statement' => '1.20', 'DBI' => '1.611', 'DBD::AnyData' => '0.09', 'DBD::CSV' => '0.29', ); WriteMakefile1( MIN_PERL_VERSION => '5.008', META_MERGE => { 'meta-spec' => { version => 2 }, resources => { homepage => 'https://metacpan.org/release/SQL-Statement', x_IRC => "irc://irc.perl.org/#dbi", x_MailingList => "mailto:dbi-dev\@perl.org'", repository => { url => 'https://github.com:perl5-utils/SQL-Statement.git', web => 'https://github.com/perl5-utils/SQL-Statement', type => 'git', }, bugtracker => { web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=SQL-Statement', mailto => 'sql-statement@rt.cpan.org', }, license => 'http://dev.perl.org/licenses/', }, prereqs => { develop => { requires => { 'Test::CPAN::Changes' => 0, 'Test::CheckManifest' => 0, 'Module::CPANTS::Analyse' => '0.96', 'Test::Kwalitee' => 0, 'Test::Pod' => 0, 'Test::Pod::Coverage' => 0, 'Test::Pod::Spelling::CommonMistakes' => 0, 'Test::Spelling' => 0, }, }, configure => { requires => {%CONFIGURE_DEPS}, }, build => { requires => {%BUILD_DEPS}, }, test => { requires => {%TEST_DEPS}, conflicts => {%CONFLICTS}, }, runtime => { recommends => { 'Math::Complex' => '1.56', 'Text::Soundex' => '3.04', 'Math::Base::Convert' => 0, }, requires => {%RUN_DEPS}, conflicts => {%CONFLICTS}, }, }, }, NAME => 'SQL::Statement', VERSION_FROM => 'lib/SQL/Statement.pm', ABSTRACT_FROM => 'lib/SQL/Statement.pm', dist => { 'SUFFIX' => ".gz", 'DIST_DEFAULT' => 'manifest tardist', 'COMPRESS' => "gzip -9vf" }, CONFLICTS => \%CONFLICTS, PREREQ_PM => \%RUN_DEPS, BUILD_REQUIRES => \%BUILD_DEPS, TEST_REQUIRES => \%TEST_DEPS, LICENSE => 'perl', AUTHOR => 'Jeff Zucker , Jens Rehsack ', test => { TESTS => 't/*.t xt/*.t' }, ); sub CheckConflicts { my %params = @_; my %conflicts = %{ $params{CONFLICTS} }; my $found = 0; while ( my ( $module, $version ) = each(%conflicts) ) { undef $@; eval "require $module"; next if $@; my $installed = eval "\$" . $module . "::VERSION"; if ( $installed le $version ) { ++$found; my $msg = $module eq $params{NAME} ? $selfConflictMsg : $conflictMsg; my $warning = sprintf( $msg, $module, $installed ); warn $warning; } } return !$found; } sub WriteMakefile1 { #Written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. my %params = @_; my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version = eval $eumm_version; die "EXTRA_META is deprecated" if ( exists( $params{EXTRA_META} ) ); die "License not specified" if ( !exists( $params{LICENSE} ) ); $params{TEST_REQUIRES} and $eumm_version < 6.6303 and $params{BUILD_REQUIRES} = { %{ $params{BUILD_REQUIRES} || {} }, %{ delete $params{TEST_REQUIRES} } }; #EUMM 6.5502 has problems with BUILD_REQUIRES $params{BUILD_REQUIRES} and $eumm_version < 6.5503 and $params{PREREQ_PM} = { %{ $params{PREREQ_PM} || {} }, %{ delete $params{BUILD_REQUIRES} } }; ref $params{AUTHOR} and "ARRAY" eq ref $params{AUTHOR} and $eumm_version < 6.5702 and $params{AUTHOR} = join( ", ", @{ $params{AUTHOR} } ); delete $params{CONFIGURE_REQUIRES} if ( $eumm_version < 6.52 ); delete $params{MIN_PERL_VERSION} if ( $eumm_version < 6.48 ); delete $params{META_MERGE} if ( $eumm_version < 6.46 ); delete $params{META_ADD}{prereqs} if ( $eumm_version < 6.58 ); delete $params{META_ADD}{'meta-spec'} if ( $eumm_version < 6.58 ); delete $params{META_ADD} if ( $eumm_version < 6.46 ); delete $params{LICENSE} if ( $eumm_version < 6.31 ); delete $params{AUTHOR} if ( $] < 5.005 ); delete $params{ABSTRACT_FROM} if ( $] < 5.005 ); delete $params{BINARY_LOCATION} if ( $] < 5.005 ); # more or less taken from Moose' Makefile.PL if ( $params{CONFLICTS} ) { my $ok = CheckConflicts(%params); exit(0) if ( $params{PREREQ_FATAL} and not $ok ); my $cpan_smoker = grep { $_ =~ m/(?:CR_SMOKER|CPAN_REPORTER|AUTOMATED_TESTING)/ } keys %ENV; unless ( $cpan_smoker || $ENV{PERL_MM_USE_DEFAULT} || $ENV{SQL_STATEMENT_WARN_UPDATE} ) { sleep 4 unless ($ok); } delete $params{CONFLICTS}; } WriteMakefile(%params); } SQL-Statement-1.407/MANIFEST000644 000765 000024 00000001741 12531016333 015221 0ustar00snostaff000000 000000 Changes lib/SQL/Dialects/ANSI.pm lib/SQL/Dialects/AnyData.pm lib/SQL/Dialects/CSV.pm lib/SQL/Dialects/Role.pm lib/SQL/Eval.pm lib/SQL/Parser.pm lib/SQL/Statement.pm lib/SQL/Statement/Embed.pod lib/SQL/Statement/Function.pm lib/SQL/Statement/Functions.pm lib/SQL/Statement/GetInfo.pm lib/SQL/Statement/Operation.pm lib/SQL/Statement/Placeholder.pm lib/SQL/Statement/RAM.pm lib/SQL/Statement/Roadmap.pod lib/SQL/Statement/Structure.pod lib/SQL/Statement/Syntax.pod lib/SQL/Statement/Term.pm lib/SQL/Statement/TermFactory.pm lib/SQL/Statement/Util.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP README README.md t/00error.t t/01prepare.t t/02execute.t t/03import.t t/04idents.t t/05simple.t t/06virtual.t t/08join.t t/09ops.t t/10limit.t t/12eval.t t/14parse.t t/17quoting.t t/23dialects.t t/SQLtest.pm t/TestLib.pm META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) SQL-Statement-1.407/MANIFEST.SKIP000644 000765 000024 00000000515 12527152473 015777 0ustar00snostaff000000 000000 \B\.svn\b \B\.git\b \.gitignore$ \.[Bb][Aa][Kk]$ \.orig$ \.old$ \.tdy$ \.tmp$ \..*swp ^Makefile$ ^Build$ ^Build\.bat$ \.Inline/.* _Inline/.* \.bak$ \.tar$ \.tgz$ \.tar\.gz$ ^mess/ ^tmp/ ^testdata/ ^blib/ ^sandbox/ ^pm_to_blib$ ^_build/.* ~$ .*\.planner \bxt ^MYMETA\.json$ ^MYMETA\..*$ bugsql nytprof* .*\.csv ^\..* SQL-Statement-.* SQL-Statement-1.407/META.json000644 000765 000024 00000005440 12531016333 015511 0ustar00snostaff000000 000000 { "abstract" : "SQL parsing and processing engine", "author" : [ "Jeff Zucker , Jens Rehsack " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "SQL-Statement", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Module::CPANTS::Analyse" : "0.96", "Test::CPAN::Changes" : "0", "Test::CheckManifest" : "0", "Test::Kwalitee" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0" } }, "runtime" : { "conflicts" : { "DBD::AnyData" : "0.09", "DBD::CSV" : "0.29", "DBI" : "1.611", "SQL::Statement" : "1.20" }, "recommends" : { "Math::Base::Convert" : "0", "Math::Complex" : "1.56", "Text::Soundex" : "3.04" }, "requires" : { "Carp" : "0", "Clone" : "0.30", "Data::Dumper" : "0", "Module::Runtime" : "0", "Params::Util" : "1.00", "Scalar::Util" : "1.0", "Text::Balanced" : "0", "perl" : "5.008" } }, "test" : { "conflicts" : { "DBD::AnyData" : "0.09", "DBD::CSV" : "0.29", "DBI" : "1.611", "SQL::Statement" : "1.20" }, "requires" : { "Math::Base::Convert" : "0", "Math::Complex" : "1.56", "Test::Deep" : "0", "Test::More" : "0.90", "Text::Soundex" : "3.04" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "sql-statement@rt.cpan.org", "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=SQL-Statement" }, "homepage" : "https://metacpan.org/release/SQL-Statement", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com:perl5-utils/SQL-Statement.git", "web" : "https://github.com/perl5-utils/SQL-Statement" }, "x_IRC" : "irc://irc.perl.org/#dbi", "x_MailingList" : "mailto:dbi-dev@perl.org'" }, "version" : "1.407" } SQL-Statement-1.407/META.yml000644 000765 000024 00000002356 12531016333 015344 0ustar00snostaff000000 000000 --- abstract: 'SQL parsing and processing engine' author: - 'Jeff Zucker , Jens Rehsack ' build_requires: Math::Base::Convert: '0' Math::Complex: '1.56' Test::Deep: '0' Test::More: '0.90' Text::Soundex: '3.04' configure_requires: ExtUtils::MakeMaker: '0' conflicts: DBD::AnyData: '0.09' DBD::CSV: '0.29' DBI: '1.611' SQL::Statement: '1.20' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: SQL-Statement no_index: directory: - t - inc recommends: Math::Base::Convert: '0' Math::Complex: '1.56' Text::Soundex: '3.04' requires: Carp: '0' Clone: '0.30' Data::Dumper: '0' Module::Runtime: '0' Params::Util: '1.00' Scalar::Util: '1.0' Text::Balanced: '0' perl: '5.008' resources: IRC: irc://irc.perl.org/#dbi MailingList: "mailto:dbi-dev@perl.org'" bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=SQL-Statement homepage: https://metacpan.org/release/SQL-Statement license: http://dev.perl.org/licenses/ repository: https://github.com:perl5-utils/SQL-Statement.git version: '1.407' SQL-Statement-1.407/README000755 000765 000024 00000004102 12160006754 014751 0ustar00snostaff000000 000000 README FILE FOR MODULES SQL::Statement and SQL::Parser These modules can be used stand-alone to parse SQL statements or used with DBI and DBD::CSV, DBD::AnyData or other drivers to create, modify, and query data in many kinds of formats including XML, CSV, Fixed Length, Excel Spreadsheets and many others. WHO NEEDS IT? If you use the DBI drivers for flatfiles, Excel spreadsheets, or formats such as XML via the CSV, AnyData, or Excel DBDs, this distribution will greatly expand the range of supported SQL, as well as provide support for text-like numbers and alphabetic comparisons previously missing in those drivers. Some of the features included in this release are partial support for multi-table joins, for set and string functions, for numeric expressions, for the IN and BETWEEN predicates and much more. HOW DO I INSTALL IT? If you are familiar with the standard make/nmake procedures, simply do as always: perl Makefile.PL make make test make install You may also use nmake or dmake on windows. Since the modules are pure perl, you may also simply copy the enclosed SQL directory into your lib directory (either your main site/lib or a private area). WHAT ELSE DO I NEED? to parse SQL statements: perl to create, query, & modify databases perl DBI DBD::CSV or DBD::AnyData or other DBDs that subclass SQL::Statement WHERE DO I FIND OUT MORE? If you are using it via one of the DBD drivers, see the help documentation for that driver. If you are subclassing the moduels, there are extensive help documents included with the modules. Use perldoc or pod2html or simply read the POD section of the .pm files. For further questions, write to the the dbi-users@perl.org listserv or try www.perlmonks.org. WHO DUNNIT? The original XS versions of the modules were written by Jochen Wiedmann. The current, pure perl versions were rewritten (mostly from the ground up) by Jeff Zucker . Both versions are currently maintained by Jens Rehsack . SQL-Statement-1.407/README.md000644 000765 000024 00000000076 12134453375 015361 0ustar00snostaff000000 000000 SQL-Statement ============= SQL parsing and processing engineSQL-Statement-1.407/t/000755 000765 000024 00000000000 12531016333 014330 5ustar00snostaff000000 000000 SQL-Statement-1.407/t/00error.t000644 000765 000024 00000002712 12160006754 016014 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs); my ( $required, $recommended ) = prove_reqs(); show_reqs( $required, $recommended ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); foreach my $test_dbd (@test_dbds) { my $dbh; note("Running tests for $test_dbd"); # Test RaiseError for prepare errors # $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, } ); eval { $dbh->prepare("Junk"); }; ok( !$@, 'Parse "Junk" RaiseError=0 (default)' ) or diag($@); eval { $dbh->do("SELECT UPPER('a')"); }; ok( !$@, 'Execute function succeeded' ) or diag($@); ok( !$dbh->errstr(), 'Execute function no errstr' ) or diag($dbh->errstr()); eval { $dbh->do( "SELECT * FROM nonexistant" ); }; ok( !$@, 'Execute RaiseError=0' ) or diag($@); $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 1, } ); eval { $dbh->prepare("Junk"); }; ok( $@, 'Parse "Junk" RaiseError=1' ); { eval { $dbh->do( "SELECT * FROM nonexistant" ); }; ok( $@, 'Execute RaiseError=1' ); ok( $dbh->errstr(), 'Execute "SELECT * FROM nonexistant" has errstr' ); } } done_testing(); SQL-Statement-1.407/t/01prepare.t000644 000765 000024 00000035034 12527131546 016332 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; no warnings 'uninitialized'; use lib qw(t); use Test::More; use Params::Util qw(_INSTANCE); use TestLib qw(connect prove_reqs show_reqs); my ( $required, $recommended ) = prove_reqs(); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); foreach my $test_dbd (@test_dbds) { my $dbh; # Test RaiseError for prepare errors # my %extra_args; if ( $test_dbd =~ m/^DBD::/i ) { $extra_args{sql_dialect} = "ANSI"; } $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, %extra_args, } ); for my $sql( split /\n/, <<"" /* DROP TABLE */ DROP TABLE foo DROP TABLE foo CASCADE DROP TABLE foo RESTRICT /* DELETE */ DELETE FROM foo DELETE FROM foo WHERE id < 7 /* UPDATE */ UPDATE foo SET bar = 7 UPDATE foo SET bar = 7 WHERE id > 7 /* INSERT */ INSERT INTO foo VALUES ( 'baz', 7, NULL ) INSERT INTO foo (col1,col2,col7) VALUES ( 'baz', 7, NULL ) INSERT INTO foo VALUES ( now(), trim(lower(user)), curdate-1 ) INSERT INTO foo VALUES ( 'smile :-),(-: twice)', ' \\' ) ' ) INSERT INTO foo VALUES (1,'row'),(2,'rows') /* CREATE TABLE */ CREATE TABLE foo ( id INT ) CREATE LOCAL TEMPORARY TABLE foo (id INT) CREATE LOCAL TEMPORARY TABLE foo (id INT) ON COMMIT DELETE ROWS CREATE LOCAL TEMPORARY TABLE foo (id INT) ON COMMIT PRESERVE ROWS CREATE GLOBAL TEMPORARY TABLE foo (id INT) CREATE GLOBAL TEMPORARY TABLE foo (id INT) ON COMMIT DELETE ROWS CREATE GLOBAL TEMPORARY TABLE foo (id INT) ON COMMIT PRESERVE ROWS CREATE TABLE foo ( id INTEGER, phrase VARCHAR(40) ) CREATE TABLE foo ( id INTEGER UNIQUE, phrase VARCHAR(40) UNIQUE ) CREATE TABLE foo ( id INTEGER PRIMARY KEY, phrase VARCHAR(40) UNIQUE ) CREATE TABLE foo ( id INTEGER PRIMARY KEY, phrase VARCHAR(40) NOT NULL ) CREATE TABLE foo ( id INTEGER NOT NULL, phrase VARCHAR(40) NOT NULL ) CREATE TABLE foo ( id INTEGER UNIQUE NOT NULL, phrase VARCHAR(40) ) CREATE TABLE foo ( phrase CHARACTER VARYING(255) ) CREATE TABLE foo ( phrase NUMERIC(4,6) ) CREATE TABLE foo ( id INTEGER, phrase VARCHAR(40), CONSTRAINT "foo_pkey" PRIMARY KEY ( "id", "phrase" ), CONSTRAINT "foo_fkey" FOREIGN KEY ( "id" ) REFERENCES "bar" ( "bar_id" )) CREATE TABLE foo ( id INTEGER, phrase VARCHAR(40), PRIMARY KEY ( "id" ), FOREIGN KEY ("id", "phrase") REFERENCES "bar" ("id2", "phrase2")) CREATE TABLE foo ( id INTEGER, phrase CHAR(255), phrase2 VARCHAR(40), CONSTRAINT "foo_pkey" PRIMARY KEY ( "id", phrase, "phrase2" ), CONSTRAINT "foo_fkey" FOREIGN KEY ("id", "phrase", "phrase2") REFERENCES "bar" ("id2", "phrase2", "phase10")) /* JOINS */ SELECT Lnum,Llet,Ulet FROM zLower NATURAL INNER JOIN zUpper SELECT Lnum,Llet,Ulet FROM zLower NATURAL LEFT JOIN zUpper SELECT Lnum,Llet,Ulet FROM zLower NATURAL RIGHT JOIN zUpper SELECT Lnum,Llet,Ulet FROM zLower NATURAL FULL JOIN zUpper SELECT Lnum,Llet,Ulet FROM zLower INNER JOIN zUpper ON Lnum = Unum SELECT Lnum,Llet,Ulet FROM zLower LEFT JOIN zUpper ON Lnum = Unum SELECT Lnum,Llet,Ulet FROM zLower RIGHT JOIN zUpper ON Lnum = Unum SELECT Lnum,Llet,Ulet FROM zLower FULL JOIN zUpper ON Lnum = Unum SELECT Lnum,Llet,Ulet FROM zLower INNER JOIN zUpper USING(num) SELECT Lnum,Llet,Ulet FROM zLower LEFT JOIN zUpper USING(num) SELECT Lnum,Llet,Ulet FROM zLower RIGHT JOIN zUpper USING(num) SELECT Lnum,Llet,Ulet FROM zLower FULL JOIN zUpper USING(num) SELECT Lnum,Llet,Ulet FROM zLower,zUpper WHERE Lnum = Unum SELECT * FROM zLower NATURAL INNER JOIN zUpper SELECT * FROM zLower NATURAL LEFT JOIN zUpper SELECT * FROM zLower NATURAL RIGHT JOIN zUpper SELECT * FROM zLower NATURAL FULL JOIN zUpper SELECT * FROM zLower INNER JOIN zUpper ON Lnum = Unum SELECT * FROM zLower LEFT JOIN zUpper ON Lnum = Unum SELECT * FROM zLower RIGHT JOIN zUpper ON Lnum = Unum SELECT * FROM zLower FULL JOIN zUpper ON Lnum = Unum SELECT * FROM zLower INNER JOIN zUpper USING(num) SELECT * FROM zLower LEFT JOIN zUpper USING(num) SELECT * FROM zLower RIGHT JOIN zUpper USING(num) SELECT * FROM zLower FULL JOIN zUpper USING(num) SELECT * FROM zLower,zUpper WHERE Lnum = Unum /* SELECT COLUMNS */ SELECT id, phrase FROM foo SELECT * FROM foo SELECT DISTINCT * FROM foo SELECT ALL * FROM foo SELECT A.*,B.* FROM A,B WHERE A.id=B.id /* SET FUNCTIONS */ SELECT MAX(foo) FROM bar SELECT MIN(foo) FROM bar SELECT AVG(foo) FROM bar SELECT SUM(foo) FROM bar SELECT COUNT(foo) FROM foo SELECT COUNT(*) FROM foo SELECT SUM(DISTINCT foo) FROM bar SELECT SUM(ALL foo) FROM bar /* ORDER BY */ SELECT * FROM foo ORDER BY bar SELECT * FROM foo ORDER BY bar, baz SELECT * FROM foo ORDER BY bar DESC SELECT * FROM foo ORDER BY bar ASC /* LIMIT */ SELECT * FROM foo LIMIT 5 SELECT * FROM foo LIMIT 0, 5 SELECT * FROM foo LIMIT 5, 10 /* DATE/TIME FUNCTIONS */ SELECT CURRENT_DATE() SELECT CURRENT_TIME() SELECT CURRENT_TIMESTAMP() SELECT CURDATE() SELECT CURTIME() SELECT NOW() SELECT UNIX_TIMESTAMP() SELECT CURRENT_TIME(2) SELECT CURRENT_TIMESTAMP(2) SELECT CURTIME(2) SELECT NOW(2) SELECT UNIX_TIMESTAMP(2) /* STRING FUNCTIONS */ SELECT * FROM foo WHERE ASCII(status) = 65 SELECT * FROM foo WHERE CHAR(code) = 'A' SELECT * FROM foo WHERE CHAR(chr1,chr2,chr3) = 'ABC' SELECT * FROM foo WHERE BIT_LENGTH(str) = 27 SELECT * FROM foo WHERE CHARACTER_LENGTH(str) = 6 SELECT * FROM foo WHERE CHAR_LENGTH(str) = 6 SELECT * FROM foo WHERE COALESCE(NULL, status) = 'bar' SELECT * FROM foo WHERE NVL(NULL, status) = 'bar' SELECT * FROM foo WHERE IFNULL(NULL, status) = 'bar' SELECT * FROM foo WHERE CONCAT(str1, str2) = 'bar' SELECT * FROM foo WHERE DECODE(color,'White','W','Red','R','B') = 'W' SELECT * FROM foo WHERE INSERT(str1, 4, 5, str2) = 'foobarland' SELECT * FROM foo WHERE LEFT(phrase) = 'bar' SELECT * FROM foo WHERE RIGHT(phrase) = 'bar' SELECT * FROM foo WHERE LOCATE(str1, str2) = 2 SELECT * FROM foo WHERE LOCATE(str1, str2, 3) = 5 SELECT * FROM foo WHERE POSITION(str1, str2) = 2 SELECT * FROM foo WHERE POSITION(str1, str2, 3) = 5 SELECT * FROM foo WHERE LOWER(phrase) = 'bar' SELECT * FROM foo WHERE UPPER(phrase) = 'BAR' SELECT * FROM foo WHERE LCASE(phrase) = 'BAR' SELECT * FROM foo WHERE UCASE(phrase) = 'bar' SELECT * FROM foo WHERE LTRIM(str) = 'bar' SELECT * FROM foo WHERE RTRIM(str) = 'bar' SELECT * FROM foo WHERE OCTET_LENGTH(str) = 12 SELECT * FROM foo WHERE REGEX(phrase, '/EF/i') = TRUE SELECT * FROM foo WHERE REPEAT(status, 3) = 'AAA' SELECT * FROM foo WHERE REPLACE(phrase, 's/z(.+)ky/$1/i') = 'bar' SELECT * FROM foo WHERE SUBSTITUTE(phrase, 's/z(.+)ky/$1/i') = 'bar' SELECT * FROM foo WHERE SOUNDEX(name1, name2) = TRUE SELECT * FROM foo WHERE SPACE(num) = ' ' SELECT * FROM foo WHERE blat = SUBSTRING(bar FROM 3 FOR 6) SELECT * FROM foo WHERE blat = SUBSTRING(bar FROM 3) SELECT * FROM foo WHERE blat = SUBSTR(bar, 3, 6) SELECT * FROM foo WHERE blat = SUBSTR(bar, 3) SELECT * FROM foo WHERE blat = TRANSLATE(bar, set1, set2) SELECT * FROM foo WHERE TRIM( str ) = 'bar' SELECT * FROM foo WHERE TRIM( LEADING FROM str ) = 'bar' SELECT * FROM foo WHERE TRIM( TRAILING FROM str ) = 'bar' SELECT * FROM foo WHERE TRIM( BOTH FROM str ) = 'bar' SELECT * FROM foo WHERE TRIM( LEADING ';' FROM str ) = 'bar' SELECT * FROM foo WHERE TRIM( UPPER(phrase) ) = 'bar' SELECT * FROM foo WHERE TRIM( LOWER(phrase) ) = 'bar' UPDATE foo SET bar='baz', bop=7, bump=bar+8, blat=SUBSTRING(bar FROM 3 FOR 6) /* NUMERIC FUNCTIONS */ SELECT * FROM bar WHERE ABS(-4) = 4 SELECT * FROM bar WHERE CEILING(-4.5) = -4 SELECT * FROM bar WHERE CEIL(-4.9) = -4 SELECT * FROM bar WHERE FLOOR(4.999999999999) = 4 SELECT * FROM bar WHERE LOG(6) = LOG10(6) SELECT * FROM bar WHERE LN(1) = EXP(1) SELECT * FROM bar WHERE MOD(8, 5) = 3 SELECT * FROM bar WHERE POWER(2, 4) = 16 SELECT * FROM bar WHERE POW(2, 4) = 16 SELECT * FROM bar WHERE RAND(2) = 0 SELECT * FROM bar WHERE RAND(2, UNIX_TIMESTAMP()) = 0 SELECT * FROM bar WHERE ROUND(4.999999999999) = 5 SELECT * FROM bar WHERE ROUND(4.542222222222, 1) = 4.5 SELECT * FROM bar WHERE SIGN(-25.5) = -1 SELECT * FROM bar WHERE SIGN(53645) = 1 SELECT * FROM bar WHERE SIGN(0) = 0 SELECT * FROM bar WHERE SIGN(NULL) = NULL SELECT * FROM bar WHERE SQRT(64) = 8 SELECT * FROM bar WHERE TRUNCATE(4.999999999999) = 4 SELECT * FROM bar WHERE TRUNC(-4.9) = -4 SELECT * FROM bar WHERE TRUNCATE(4.934, 1) = 4.9 SELECT * FROM bar WHERE TRUNC(-4.99999, 1) = -4.9 /* TRIGONOMETRIC FUNCTIONS */ SELECT * FROM test WHERE ACOS(x) SELECT * FROM test WHERE ACOSEC(x) SELECT * FROM test WHERE ACOSECH(x) SELECT * FROM test WHERE ACOSH(x) SELECT * FROM test WHERE ACOT(x) SELECT * FROM test WHERE ACOTAN(x) SELECT * FROM test WHERE ACOTANH(x) SELECT * FROM test WHERE ACOTH(x) SELECT * FROM test WHERE ACSC(x) SELECT * FROM test WHERE ACSCH(x) SELECT * FROM test WHERE ASEC(x) SELECT * FROM test WHERE ASECH(x) SELECT * FROM test WHERE ASIN(x) SELECT * FROM test WHERE ASINH(x) SELECT * FROM test WHERE ATAN(x) SELECT * FROM test WHERE ATAN2(y, x) SELECT * FROM test WHERE ATANH(x) SELECT * FROM test WHERE COS(x) SELECT * FROM test WHERE COSEC(x) SELECT * FROM test WHERE COSECH(x) SELECT * FROM test WHERE COSH(x) SELECT * FROM test WHERE COT(x) SELECT * FROM test WHERE COTAN(x) SELECT * FROM test WHERE COTANH(x) SELECT * FROM test WHERE COTH(x) SELECT * FROM test WHERE CSC(x) SELECT * FROM test WHERE CSCH(x) SELECT * FROM test WHERE DEG2DEG(deg) SELECT * FROM test WHERE RAD2RAD(rad) SELECT * FROM test WHERE GRAD2GRAD(grad) SELECT * FROM test WHERE DEG2GRAD(deg) SELECT * FROM test WHERE DEG2RAD(deg) SELECT * FROM test WHERE GRAD2DEG(grad) SELECT * FROM test WHERE GRAD2RAD(grad) SELECT * FROM test WHERE RAD2DEG(rad) SELECT * FROM test WHERE RAD2GRAD(rad) SELECT * FROM test WHERE DEGREES(rad) SELECT * FROM test WHERE RADIANS(deg) SELECT * FROM test WHERE DEG2DEG(deg, TRUE) SELECT * FROM test WHERE RAD2RAD(rad, TRUE) SELECT * FROM test WHERE GRAD2GRAD(grad, TRUE) SELECT * FROM test WHERE DEG2GRAD(deg, TRUE) SELECT * FROM test WHERE DEG2RAD(deg, TRUE) SELECT * FROM test WHERE GRAD2DEG(grad, TRUE) SELECT * FROM test WHERE GRAD2RAD(grad, TRUE) SELECT * FROM test WHERE RAD2DEG(rad, TRUE) SELECT * FROM test WHERE RAD2GRAD(rad, TRUE) SELECT * FROM test WHERE DEGREES(rad, TRUE) SELECT * FROM test WHERE RADIANS(deg, TRUE) SELECT * FROM test WHERE PI() SELECT * FROM test WHERE SEC(x) SELECT * FROM test WHERE SECH(x) SELECT * FROM test WHERE SIN(x) SELECT * FROM test WHERE SINH(x) SELECT * FROM test WHERE TAN(x) SELECT * FROM test WHERE TANH(x) /* SYSTEM FUNCTIONS */ SELECT * FROM ztable WHERE DBNAME() = foobar SELECT * FROM ztable WHERE USERNAME() = foobar SELECT * FROM ztable WHERE USER() = foobar /* TABLE NAME ALIASES */ SELECT * FROM test as T1 SELECT * FROM test T1 SELECT T1.id, T2.num FROM test as T1 JOIN test2 as T2 USING(id) SELECT id FROM test as T1 WHERE T1.num < 7 SELECT id FROM test as T1 ORDER BY T1.num SELECT a.x,b.y FROM foo AS a, bar b WHERE a.baz = b.bop ORDER BY a.blat /* NUMERIC EXPRESSIONS */ SELECT * FROM foo WHERE 1 = 0 AND baz < (6*foo+11-r) /* CASE OF IDENTIFIERS */ SELECT ID, phRase FROM tEst AS tE WHERE te.id < 3 ORDER BY TE.phrasE /* PARENS */ SELECT * FROM ztable WHERE NOT data IN ('one','two') SELECT * from ztable WHERE (aaa > 'AAA') SELECT * from ztable WHERE sev = 50 OR sev = 60 SELECT * from ztable WHERE (sev = 50 OR sev = 60) SELECT * from ztable WHERE sev IN (50,60) SELECT * from ztable WHERE rc > 200 AND ( sev IN(50,60) ) SELECT * FROM ztable WHERE data NOT IN ('one','two') SELECT * from ztable WHERE (aaa > 'AAA') AND (zzz < 'ZZZ') SELECT * from ztable WHERE (sev IN(50,60)) /* NOT */ SELECT * FROM foo WHERE NOT bar = 'baz' AND bop = 7 OR NOT blat = bar SELECT * FROM foo WHERE NOT bar = 'baz' AND NOT bop = 7 OR NOT blat = bar SELECT * FROM foo WHERE NOT bar = 'baz' AND NOT bop = 7 OR blat IS NOT NULL /* IN */ SELECT * FROM bar WHERE foo IN ('aa','ab','ba','bb') SELECT * FROM bar WHERE foo IN (3.14,2.72,1.41,9.81) SELECT * FROM bar WHERE foo NOT IN ('aa','ab','ba','bb') SELECT * FROM bar WHERE foo NOT IN (3.14,2.72,1.41,9.81) /* BETWEEN */ SELECT * FROM bar WHERE foo BETWEEN ('aa','bb') SELECT * FROM bar WHERE foo BETWEEN (1.41,9.81) SELECT * FROM bar WHERE foo NOT BETWEEN ('aa','bb') SELECT * FROM bar WHERE foo NOT BETWEEN (1.41,9.81) ) { ok( eval { $dbh->prepare($sql); }, "parse '$sql' using $test_dbd" ) or diag( $dbh->errstr() ); } for my $sql( split /\n/, <<"" UPDATE foo SET bar=REPEAT(status, BIT_LENGTH(str)), bop=7, bump=bar+POSITION(str1, str2), blat=SUBSTRING(bar FROM ASCII(status) FOR CHAR_LENGTH(str)) SELECT * FROM bar WHERE EXP(1) = SINH(1)+COSH(1) SELECT * FROM bar WHERE LOG(8, 2) = LOG10(8) / LOG10(2) ) { local $TODO = "Analyze failures"; ok( eval { $dbh->prepare($sql); }, "parse '$sql' using $test_dbd" ) or diag( $dbh->errstr() ); } SKIP: { my $sql = "SELECT a FROM b JOIN c WHERE c=? AND e=7 ORDER BY f ASC, g DESC LIMIT 5,2"; my $sth; eval { $sth = $dbh->prepare( $sql ) }; ok( !$@, '$sth->new' ) or skip("Can't instantiate SQL::Statement: $@"); cmp_ok( $sth->command, 'eq', 'SELECT', '$sth->command' ); cmp_ok( scalar( $sth->params ), '==', 1, '$sth->params' ); cmp_ok( $sth->tables(1)->name(), 'eq', 'c', '$sth->tables' ); ok( defined( _INSTANCE( $sth->where(), 'SQL::Statement::Operation::And' ) ), '$sth->where()->op' ); ok( defined( _INSTANCE( $sth->where()->{LEFT}, 'SQL::Statement::Operation::Equal' ) ), '$sth->where()->left' ); ok( defined( _INSTANCE( $sth->where()->{LEFT}->{LEFT}, 'SQL::Statement::ColumnValue' ) ), '$sth->where()->left->left' ); ok( defined( _INSTANCE( $sth->where()->{LEFT}->{RIGHT}, 'SQL::Statement::Placeholder' ) ), '$sth->where()->left->right' ); cmp_ok( $sth->limit(), '==', 2, '$sth->limit' ); cmp_ok( $sth->offset(), '==', 5, '$sth->offset' ); note( "Command " . $sth->command() ); note( "Num Pholders " . scalar $sth->params() ); note( "Columns " . join ',', map { $_->name } $sth->columns() ); note( "Tables " . join ',', $sth->tables() ); note( "Where op " . join ',', $sth->where->op() ); note( "Limit " . $sth->limit() ); note( "Offset " . $sth->offset ); my @order_cols = $sth->order(); note( "Order Cols " . join( ',', map { keys %$_ } @order_cols ) ); } my $sth = $dbh->prepare( "INSERT a VALUES(3,7)" ); cmp_ok( scalar( $sth->row_values() ), '==', 1, '$stmt->row_values()' ); cmp_ok( scalar( $sth->row_values(0) ), '==', 2, '$stmt->row_values(0)' ); cmp_ok( scalar( $sth->row_values( 0, 1 ) )->{value}, '==', 7, '$stmt->row_values(0,1)' ); cmp_ok( ref( $sth->parser()->structure ), 'eq', 'HASH', 'structure' ); cmp_ok( $sth->parser()->command(), 'eq', 'INSERT', 'command' ); ok( $dbh->prepare( "SELECT DISTINCT c1 FROM tbl" ), 'distinct' ); } done_testing(); SQL-Statement-1.407/t/02execute.t000644 000765 000024 00000021457 12160006754 016336 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs test_dir default_recommended); my ( $required, $recommended ) = prove_reqs( { default_recommended(), ( MLDBM => 0 ) } ); show_reqs( $required, $recommended ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); my $testdir = test_dir(); foreach my $test_dbd (@test_dbds) { my $dbh; note("Running tests for $test_dbd"); my $temp = ""; # XXX # my $test_dbd_tbl = "${test_dbd}::Table"; # $test_dbd_tbl->can("fetch") or $temp = "$temp"; $test_dbd eq "DBD::File" and $temp = "TEMP"; $test_dbd eq "SQL::Statement" and $temp = "TEMP"; my %extra_args; if ( $test_dbd eq "DBD::DBM" and $recommended->{MLDBM} ) { $extra_args{dbm_mldbm} = "Storable"; } $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, f_dir => $testdir, %extra_args, } ); my ( $sth, $str ); ok( $dbh->do(qq{ CREATE $temp TABLE Tmp (id INT,phrase VARCHAR(30)) }), 'CREATE Tmp' ) or diag( $dbh->errstr() ); ok( $dbh->do( qq{ INSERT INTO Tmp (id,phrase) VALUES (?,?) }, {}, 9, 'yyy' ), 'placeholder insert with named cols' ) or diag( $dbh->errstr() ); ok( $dbh->do( qq{ INSERT INTO Tmp VALUES(?,?) }, {}, 2, 'zzz' ), 'placeholder insert without named cols' ) or diag( $dbh->errstr() ); $dbh->do( qq{ INSERT INTO Tmp (id,phrase) VALUES (?,?) }, {}, 3, 'baz' ) or diag( $dbh->errstr() ); ok( $dbh->do( qq{ DELETE FROM Tmp WHERE id=? or phrase=? }, {}, 3, 'baz' ), 'placeholder delete' ); ok( $dbh->do( qq{ UPDATE Tmp SET phrase=? WHERE id=?}, {}, 'bar', 2 ), 'placeholder update' ) or diag( $dbh->errstr() ); ok( $dbh->do( qq{ UPDATE Tmp SET phrase=?,id=? WHERE id=? and phrase=?}, {}, 'foo', 1, 9, 'yyy' ), 'placeholder update' ) or diag( $dbh->errstr() ); ok( $dbh->do( qq{INSERT INTO Tmp VALUES (3, 'baz'), (4, 'fob'), (5, 'zab')} ), 'multiline insert' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare('SELECT id,phrase FROM Tmp ORDER BY id'); ok($sth, "prepare 'SELECT id,phrase FROM Tmp ORDER BY id'") or diag( $dbh->errstr() ); $sth->execute() or diag( $dbh->errstr() ); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 foo^2 bar^3 baz^4 fob^5 zab^', 'verify table contents' ); ok( $dbh->do(qq{ DROP TABLE IF EXISTS Tmp }), 'DROP TABLE' ) or diag( $dbh->errstr() ); ######################################## # CREATE, INSERT, UPDATE, DELETE, SELECT ######################################## ok( $dbh->do($_), $dbh->command() ) for split /\n/, <<""; 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("SELECT UPPER('a') AS A,phrase FROM phrase"); ok($sth, "prepare 'SELECT UPPER('a') AS A,phrase FROM phrase'") or diag( $dbh->errstr() ); $sth->execute or diag( $dbh->errstr() ); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } ok( $str eq 'A FOO^A BAR^', 'SELECT' ); cmp_ok( scalar $dbh->selectrow_array("SELECT COUNT(*) FROM phrase"), '==', 2, 'COUNT *' ); ok( $dbh->do("DROP TABLE phrase"), "DROP $temp TABLE" ); ################################# # COMPUTED COLUMNS IN SELECT LIST ################################# cmp_ok( $dbh->selectrow_array("SELECT UPPER('b')"), 'eq', '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' ); for my $sql ( split /\n/, <<"" CREATE $temp TABLE a (b INT, c CHAR) INSERT INTO a VALUES(1,'abc') INSERT INTO a VALUES(2,'efg') INSERT INTO a VALUES(3,'hij') INSERT INTO a VALUES(4,'klm') INSERT INTO a VALUES(5,'nmo') INSERT INTO a VALUES(6,'pqr') INSERT INTO a VALUES(7,'stu') INSERT INTO a VALUES(8,'vwx') INSERT INTO a VALUES(9,'yz') SELECT b,c FROM a WHERE c LIKE '%b%' ORDER BY c DESC" ) { note("<$sql>"); $sth = $dbh->prepare( $sql ); ok( $sth->execute(), '$stmt->execute "' . $sql . '" (' . $sth->command() . ')' ); next unless ( $sth->command() eq 'SELECT' ); cmp_ok( ref( $sth->where_hash ), 'eq', 'HASH', '$stmt->where_hash' ); cmp_ok( $sth->columns(0)->name(), 'eq', 'b', '$stmt->columns' ); cmp_ok( join( '', @{$sth->col_names()} ), 'eq', 'bc', '$stmt->column_names' ); cmp_ok( $sth->order(0)->{direction}, 'eq', 'DESC', '$stmt->order' ); while ( my $row = $sth->fetch_row() ) { cmp_ok( $row->[0], '==', 1, '$stmt->fetch' ); } } my %gen_inbtw = ( q{SELECT b,c FROM a WHERE b IN (2,3,5,7)} => '2^efg^3^hij^5^nmo^7^stu', q{SELECT b,c FROM a WHERE b NOT IN (2,3,5,7)} => '1^abc^4^klm^6^pqr^8^vwx^9^yz', q{SELECT b,c FROM a WHERE NOT b IN (2,3,5,7)} => '1^abc^4^klm^6^pqr^8^vwx^9^yz', q{SELECT b,c FROM a WHERE b BETWEEN (5,7)} => '5^nmo^6^pqr^7^stu', q{SELECT b,c FROM a WHERE b NOT BETWEEN (5,7)} => '1^abc^2^efg^3^hij^4^klm^8^vwx^9^yz', q{SELECT b,c FROM a WHERE NOT b BETWEEN (5,7)} => '1^abc^2^efg^3^hij^4^klm^8^vwx^9^yz', q{SELECT b,c FROM a WHERE c IN ('abc','klm','pqr','vwx','yz')} => '1^abc^4^klm^6^pqr^8^vwx^9^yz', q{SELECT b,c FROM a WHERE c NOT IN ('abc','klm','pqr','vwx','yz')} => '2^efg^3^hij^5^nmo^7^stu', q{SELECT b,c FROM a WHERE NOT c IN ('abc','klm','pqr','vwx','yz')} => '2^efg^3^hij^5^nmo^7^stu', q{SELECT b,c FROM a WHERE c BETWEEN ('abc','nmo')} => '1^abc^2^efg^3^hij^4^klm^5^nmo', q{SELECT b,c FROM a WHERE c NOT BETWEEN ('abc','nmo')} => '6^pqr^7^stu^8^vwx^9^yz', q{SELECT b,c FROM a WHERE NOT c BETWEEN ('abc','nmo')} => '6^pqr^7^stu^8^vwx^9^yz', ); while ( my ( $sql, $result ) = each(%gen_inbtw) ) { my $sth = $dbh->prepare($sql); ok( $sth->execute(), '$stmt->execute "' . $sql . '" (' . $sth->command . ')' ); my @res; while ( my $row = $sth->fetch_row() ) { push( @res, @{$row} ); } is( $result, join( '^', @res ), $sql ); } ########################### # CREATE function in module ########################### BEGIN { eval 'package Foo; sub foo { 88 } sub bar { return $_[2] * 2; } 1;'; } $dbh->do(qq{CREATE FUNCTION foofoo NAME "Foo::foo"}); $dbh->do(qq{CREATE FUNCTION foobar NAME "Foo::bar"}); ok( 88 == $dbh->selectrow_array("SELECT foofoo()"), 'CREATE FUNCTION from module' ); ok( 42 == $dbh->selectrow_array("SELECT foobar(21)"), 'CREATE FUNCTION from module with argument' ); ################ # LOAD functions ################ SKIP: { -e 'Bar.pm' and unlink 'Bar.pm'; my $fh; open( $fh, '>Bar.pm' ) or skip(1, $!); print $fh "package Bar; sub SQL_FUNCTION_BAR{77};1;"; close $fh; $dbh->do("LOAD Bar"); ok( 77 == $dbh->selectrow_array("SELECT bar()"), 'LOAD FUNCTIONS' ); } -e 'Bar.pm' and unlink 'Bar.pm'; #my $foo=0; #sub test2 {$foo = 6;} #open(O,'>','tmpss.sql') or die $!; #print O "SELECT test2"; #close O; #$dbh->do("CREATE FUNCTION test2"); #ok($dbh->do(qq{CALL RUN('tmpss.sql')}),'run'); #ok(6==$foo,'call run'); #unlink 'tmpss.sql' if -e 'tmpss.sql'; SKIP: { if ( $test_dbd eq "DBD::DBM" and !$recommended->{MLDBM} ) { skip( "DBD::DBM Update test won't run without MLDBM", 3 ); } my $pauli = [ [ 1, 'H', 19 ], [ 2, 'H', 21 ], [ 3, 'KK', 1 ], [ 4, 'KK', 2 ], [ 5, 'KK', 13 ], [ 6, 'MMM', 25 ], ]; ok( $dbh->do(qq{CREATE $temp TABLE pauli (id INT, column1 VARCHAR, column2 INTEGER)}), 'CREATE pauli test table' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare("INSERT INTO pauli VALUES (?, ?, ?)"); foreach my $line ( @{$pauli} ) { $sth->execute( @{$line} ); } $sth = $dbh->prepare("UPDATE pauli SET column1 = ? WHERE column1 = ?"); my $cnt = $sth->execute( "XXXX", "KK" ); cmp_ok( $cnt, '==', 3, 'UPDATE with placeholders' ); $sth->finish(); $sth = $dbh->prepare("SELECT column1, COUNT(column1) FROM pauli GROUP BY column1"); $sth->execute(); my $hres = $sth->fetchall_hashref('column1'); cmp_ok( $hres->{XXXX}->{'COUNT'}, '==', 3, 'UPDATE with placeholder updates correct' ); } } done_testing(); SQL-Statement-1.407/t/03import.t000644 000765 000024 00000015321 12160006754 016200 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs test_dir default_recommended); my ( $required, $recommended ) = prove_reqs( { default_recommended(), ( MLDBM => 0 ) } ); my ( undef, $extra_recommended ) = prove_reqs( { 'DBD::SQLite' => 0, } ); show_reqs( $required, { %$recommended, %$extra_recommended } ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); my $testdir = test_dir(); my @external_dbds = ( keys %$extra_recommended, grep { /^dbd::(?:dbm|csv)/i } keys %{$recommended} ); foreach my $test_dbd (@test_dbds) { my $dbh; note("Running tests for $test_dbd"); my $temp = ""; # XXX # my $test_dbd_tbl = "${test_dbd}::Table"; # $test_dbd_tbl->can("fetch") or $temp = "$temp"; $test_dbd eq "DBD::File" and $temp = "TEMP"; $test_dbd eq "SQL::Statement" and $temp = "TEMP"; my %extra_args; if ( $test_dbd eq "DBD::DBM" and $recommended->{MLDBM} ) { $extra_args{dbm_mldbm} = "Storable"; } $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, f_dir => $testdir, %extra_args, } ); my $external_dsn; if (%$extra_recommended) { if ( $extra_recommended->{'DBD::SQLite'} ) { $external_dsn = "DBI:SQLite:dbname=" . File::Spec->catfile( $testdir, 'sqlite.db' ); } } elsif (@external_dbds) { if ( $test_dbd eq $external_dbds[0] and @external_dbds > 1 ) { $external_dsn = $external_dbds[1]; } else { $external_dsn = $external_dbds[0]; } $external_dsn =~ s/^dbd::(\w+)$/dbi:$1:/i; my @valid_dsns = DBI->data_sources( $external_dsn, { f_dir => $testdir } ); $external_dsn = $valid_dsns[0]; } my ( $sth, $str ); #################### # IMPORT($AoA) #################### $sth = $dbh->prepare("SELECT word FROM IMPORT(?) ORDER BY id DESC"); my $AoA = [ [qw( id word )], [qw( 4 Just )], [qw( 3 Another )], [qw( 2 Perl )], [qw( 1 Hacker )], ]; $sth->execute($AoA); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', 'Just^Another^Perl^Hacker^', 'IMPORT($AoA)' ); ####################### # IMPORT($AoH) ####################### my $aoh = [ { c1 => 1, c2 => 9 }, { c1 => 2, c2 => 8 } ]; $sth = $dbh->prepare("SELECT C1,c2 FROM IMPORT(?)"); $sth->execute($aoh); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 9^2 8^', 'IMPORT($AoH)' ); ####################### # IMPORT($internal_sth) ####################### SKIP: { skip( "Need DBI statement handle - can't use when executing direct", 7 ) if ( $dbh->isa('TestLib::Direct') ); ok( $dbh->do( "CREATE $temp TABLE aoh AS IMPORT(?)", {}, $aoh ), 'CREATE AS IMPORT($aoh)' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare("SELECT C1,c2 FROM aoh"); $sth->execute(); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 9^2 8^', 'SELECT FROM IMPORTED($AoH)' ); ok( $dbh->do( "CREATE $temp TABLE aoa AS IMPORT(?)", {}, $AoA ), 'CREATE AS IMPORT($aoa)' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare("SELECT word FROM aoa ORDER BY id DESC"); $sth->execute(); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', 'Just^Another^Perl^Hacker^', 'SELECT FROM IMPORTED($AoA)' ); ok( $dbh->do("CREATE $temp TABLE tbl_copy AS SELECT * FROM aoa"), 'CREATE AS SELECT *' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare("SELECT * FROM tbl_copy ORDER BY id ASC"); $sth->execute(); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 Hacker^2 Perl^3 Another^4 Just^', 'SELECT FROM "SELECTED(*)" tbl_copy' ); ok( $dbh->do("CREATE $temp TABLE tbl_extract AS SELECT * FROM aoa WHERE word LIKE 'H%'"), 'CREATE AS SELECT * with quoted restriction' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare("SELECT * FROM tbl_extract ORDER BY id ASC"); $sth->execute(); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 Hacker^', 'SELECT FROM "SELECTED(*)" tbl_extract' ); $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')->{sth}; # XXX breaks abstraction $internal_sth->execute(); $sth = $dbh->prepare('SELECT * FROM IMPORT(?)'); $sth->execute($internal_sth); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 foo^', 'IMPORT($internal_sth)' ); } ####################### # IMPORT($external_sth) ####################### SKIP: { skip( 'No external usable data source installed', 2 ) unless ($external_dsn); my $xb_dbh = DBI->connect($external_dsn); $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_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 foo^', 'SELECT IMPORT($external_sth)' ); SKIP: { skip( "Need DBI statement handle - can't use when executing direct", 2 ) if ( $dbh->isa('TestLib::Direct') ); $xb_sth = $xb_dbh->prepare('SELECT * FROM xb'); $xb_sth->execute(); ok( $dbh->do( "CREATE $temp TABLE xbi AS IMPORT(?)", {}, $xb_sth ), 'CREATE AS IMPORT($sth)' ) or diag( $dbh->errstr() ); $sth = $dbh->prepare('SELECT * FROM xbi'); $sth->execute(); $str = ''; while ( my $r = $sth->fetch_row() ) { $str .= "@$r^"; } cmp_ok( $str, 'eq', '1 foo^', 'SELECT FROM IMPORTED ($external_sth)' ); } $xb_dbh->do("DROP TABLE xb"); } } done_testing(); SQL-Statement-1.407/t/04idents.t000644 000765 000024 00000021402 12160006754 016152 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs test_dir); my ( $required, $recommended ) = prove_reqs(); my ( undef, $extra_recommended ) = prove_reqs( { 'DBD::SQLite' => 0, } ); show_reqs( $required, { %$recommended, %$extra_recommended } ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); my $testdir = test_dir(); my @external_dbds = ( keys %$extra_recommended, grep { /^dbd::(?:dbm|csv)/i } keys %{$recommended} ); foreach my $test_dbd (@test_dbds) { my ( $dbh, $sth ); note("Running tests for $test_dbd"); my $temp = ""; # XXX # my $test_dbd_tbl = "${test_dbd}::Table"; # $test_dbd_tbl->can("fetch") or $temp = "$temp"; $test_dbd eq "DBD::File" and $temp = "TEMP"; $test_dbd eq "SQL::Statement" and $temp = "TEMP"; $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, f_dir => $testdir, } ); my $external_dsn; if (%$extra_recommended) { if ( $extra_recommended->{'DBD::SQLite'} ) { $external_dsn = "DBI:SQLite:dbname=" . File::Spec->catfile( $testdir, 'sqlite.db' ); } } elsif (@external_dbds) { if ( $test_dbd eq $external_dbds[0] and @external_dbds > 1 ) { $external_dsn = $external_dbds[1]; } else { $external_dsn = $external_dbds[0]; } $external_dsn =~ s/^dbd::(\w+)$/dbi:$1:/i; my @valid_dsns = DBI->data_sources( $external_dsn, { f_dir => $testdir } ); $external_dsn = $valid_dsns[0]; } ####################### # identifier names ####################### $dbh->do($_) for split /\n/, <<""; 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') $sth = $dbh->prepare("SELECT * FROM Prof"); $sth->execute(); is_deeply( $sth->col_names(), [qw(pid pname)], "Column Names: select list = *" ); $sth = $dbh->prepare("SELECT pname,pID FROM Prof"); $sth->execute(); is_deeply( $sth->col_names(), [qw(pname pID)], 'Column Names: select list = named' ); $sth = $dbh->prepare('SELECT pname AS "ProfName", pId AS "Magic#" from prof'); $sth->execute(); no warnings; is_deeply( $sth->col_names(), [qw("ProfName" "Magic#")], "Column Names: select list = aliased" ); use warnings; $sth = $dbh->prepare(q{SELECT pid, concat(pname, ' is #', pId ) from prof}); $sth->execute(); is_deeply( $sth->col_names(), [qw(pid concat)], "Column Names: select list with function" ); $sth = $dbh->prepare( q{SELECT pid AS "ID", concat(pname, ' is #', pId ) AS "explanation" from prof}); $sth->execute(); is_deeply( $sth->col_names(), [qw("ID" "explanation")], "Column Names: select list with function = aliased" ); my @rt34121_checks = ( { descr => 'camelcased', cols => [qw("fOo")], tbls => [qw("SomeTable")] }, { descr => 'reserved names', cols => [qw("text")], tbls => [qw("Table")] }, ## ## According to jZed, ## ## Verbatim from Martin Gruber and Joe Celko (who is on the standards committee ## and whom I have talked to in person about this), _SQL Instant Reference_, Sybex ## ## "A regular and a delimited identifier are equal if they contain the same ## characters, taking case into account, but first converting the regular ## (but not the delimited) identifier to all uppercase letters. In effect ## a delimited identifier that contains lowercase letters can never equal a ## regular identifier although it may equal another delimited one." ## { descr => 'not quoted', cols => [qw(Foo)], tbls => [qw(SomeTable)], icols => [qw(foo)], itbls => [qw(sometable)], # none quoted identifiers are lowercased internally }, ); for my $check (@rt34121_checks) { $sth = $dbh->prepare( sprintf( q{SELECT %s FROM %s}, join( ", ", @{ $check->{cols} } ), join( ", ", @{ $check->{tbls} } ) ) ); is_deeply( $sth->col_names(), $check->{icols} || $check->{cols}, "Raw SQL hidden absent from column name [rt.cpan.org #34121] ($check->{descr})" ); is_deeply( $sth->tbl_names(), $check->{itbls} || $check->{tbls}, "Raw SQL hidden absent from table name [rt.cpan.org #34121] ($check->{descr})" ); } $dbh->do("CREATE $temp TABLE allcols ( f1 char(10), f2 char(10) )"); $sth = $dbh->prepare("INSERT INTO allcols (f1,f2) VALUES (?,?)") or diag( "Can't prepare insert sth: " . $dbh->errstr() ); $sth->execute( 'abc', 'def' ); my $allcols_before = $sth->all_cols(); $sth->execute( 'abc', 'def' ) for 1 .. 100; my $allcols_after = $sth->all_cols(); is_deeply( $allcols_before, $allcols_after, '->{all_cols} structure does not grow beyond control' ); ######################### # migration of t/07case.t ######################### # NOTE: DBD::DBM requires at least 2 columns my %create = ( lower => "CREATE $temp TABLE tbl (id INT, col INT)", upper => "CREATE $temp TABLE tbl (ID INT, COL INT)", mixed => "CREATE $temp TABLE tbl (iD INT, cOl INT)", ); my %query = ( lower => "SELECT id,col FROM tbl WHERE 1=0", upper => "SELECT ID,COL FROM tbl WHERE 1=0", mixed => "SELECT Id,cOl FROM tbl WHERE 1=0", asterisked => "SELECT * FROM tbl WHERE 1=0", ); for my $create_case (qw(lower upper mixed)) { $dbh->do("DROP TABLE IF EXISTS tbl"); $dbh->do( $create{$create_case} ); for my $query_case (qw(lower upper mixed asterisked)) { my $sth = $dbh->prepare( $query{$query_case} ); my $msg = sprintf( "%s/%s", $create_case, $query_case ); ok( $sth->execute(), "execute for '$msg'" ) or diag( $dbh->errstr() ); my $col = $sth->col_names()->[1]; is( $col, 'col', $msg ) if ( $query_case eq 'lower' ); is( $col, 'COL', $msg ) if ( $query_case eq 'upper' ); is( $col, 'cOl', $msg ) if ( $query_case eq 'mixed' ); is( $col, 'col', $msg ) if ( $query_case eq 'asterisked' ); } $dbh->do("DROP TABLE IF EXISTS tbl"); } SKIP: { skip( 'No external usable data source installed', 1 ) unless ($external_dsn); skip( "Need DBI statement handle - can't use when executing direct", 1 ) if ( $dbh->isa('TestLib::Direct') ); my $xb_dbh = DBI->connect($external_dsn); $xb_dbh->do($_) for split /\n/, <<""; CREATE TABLE pg (id INT, col INT) INSERT INTO pg VALUES (3,7) my $xb_sth = $xb_dbh->prepare("SELECT * FROM pg WHERE 1=0"); $xb_sth->execute(); my $nameOfCol = $xb_sth->{NAME}->[1]; $dbh->do("CREATE $temp TABLE tbl AS IMPORT(?)",{},$xb_sth); for my $query_case(qw(lower upper mixed asterisked)) { my $sth = $dbh->prepare( $query{$query_case} ); $sth->execute(); my $msg = sprintf( "imported table : %s", $query_case ); my $col = $sth->col_names()->[1]; is($col, 'col',$msg) if $query_case eq 'lower'; is($col, 'COL',$msg) if $query_case eq 'upper'; is($col, 'cOl',$msg) if $query_case eq 'mixed'; is($col, $nameOfCol,$msg) if $query_case eq 'asterisked'; } $xb_dbh->do("DROP TABLE pg"); $dbh->do("DROP TABLE IF EXISTS tbl"); $xb_dbh->disconnect; } } done_testing(); __END__ PostgreSQL Case insensitive comparisons Always stores in lower case Always returns lower case S::S 0.x Case *sensitive* comparisons (if you created with "MYCOL" you can not query with "mycol" or "MyCol") Stores in mixed case Always returns stored case SQLite and S::S 1.x Case insensitive comparisons Stores in mixed case Returns stored case for *, query case otherwise Returns stored case for asterisked queries * except in 1.12 with TEMP files, upper-cases columns Returns query case if columns are specified in query S::S 1.12 file-based table : same as 1.x TEMP table : same, except upper cases on asterisked queries imported table : same, except upper cases on asterisked queries SQL-Statement-1.407/t/05simple.t000644 000765 000024 00000021131 12160006754 016155 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs test_dir default_recommended); use Clone qw(clone); use Params::Util qw(_CODE _ARRAY); my ( $required, $recommended ) = prove_reqs( { default_recommended(), ( MLDBM => 0 ) } ); show_reqs( $required, $recommended ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); my $testdir = test_dir(); my @massValues = map { [ $_, ( "a" .. "f" )[ int rand 6 ], int rand 10 ] } ( 1 .. 3999 ); SKIP: foreach my $test_dbd (@test_dbds) { my $dbh; note("Running tests for $test_dbd"); my $temp = ""; # XXX # my $test_dbd_tbl = "${test_dbd}::Table"; # $test_dbd_tbl->can("fetch") or $temp = "$temp"; $test_dbd eq "DBD::File" and $temp = "TEMP"; $test_dbd eq "SQL::Statement" and $temp = "TEMP"; my %extra_args; if ( $test_dbd eq "DBD::DBM" ) { if ( $recommended->{MLDBM} ) { $extra_args{dbm_mldbm} = "Storable"; } else { skip( 'DBD::DBM test runs without MLDBM', 1 ); } } elsif( $test_dbd eq "DBD::CSV" ) { $extra_args{csv_null} = 1; } $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, f_dir => $testdir, %extra_args, } ); my $vsql = "SELECT * FROM multi_fruit ORDER BY dKey DESC"; my $vsth = $dbh->prepare($vsql); ok($vsth, "prepare <$vsql> using '$test_dbd'") or diag($dbh->errstr || 'unknown error'); # evil hack to avoid full dbi emulating in TestLib my %store; defined $dbh->{stmt} and $store{stmt} = $dbh->{stmt}; defined $dbh->{sth} and $store{sth} = $dbh->{sth}; # basic tests taken from DBD::DBM simple tests - should work overall my @tests = ( "DROP TABLE IF EXISTS multi_fruit", -1, "CREATE $temp TABLE multi_fruit (dKey INT, dVal VARCHAR(10), qux INT)", '0E0', "INSERT INTO multi_fruit VALUES (1,'oranges' , 11 )", 1, "INSERT INTO multi_fruit VALUES (2,'to_change', 0 )", 1, "INSERT INTO multi_fruit VALUES (3, NULL , 13 )", 1, "INSERT INTO multi_fruit VALUES (4,'to_delete', 14 )", 1, undef, [ [ 4, 'to_delete', 14 ], [ 3, undef, 13 ], [ 2, 'to_change', 0 ], [ 1, 'oranges', 11 ], ], "INSERT INTO multi_fruit VALUES (?,?,?); #5,via placeholders,15", 1, undef, [ [ 5, 'via placeholders', 15 ], [ 4, 'to_delete', 14 ], [ 3, undef, 13 ], [ 2, 'to_change', 0 ], [ 1, 'oranges', 11 ], ], "INSERT INTO multi_fruit VALUES (6,'to_delete', 16 )", 1, "INSERT INTO multi_fruit VALUES (7,'to delete', 17 )", 1, "INSERT INTO multi_fruit VALUES (8,'to remove', 18 )", 1, "UPDATE multi_fruit SET dVal='apples', qux='12' WHERE dKey=2", 1, undef, [ [ 8, 'to remove', 18 ], [ 7, 'to delete', 17 ], [ 6, 'to_delete', 16 ], [ 5, 'via placeholders', 15 ], [ 4, 'to_delete', 14 ], [ 3, undef, 13 ], [ 2, 'apples', 12 ], [ 1, 'oranges', 11 ], ], "DELETE FROM multi_fruit WHERE dVal='to_delete'", 2, "DELETE FROM multi_fruit WHERE qux=17", 1, "DELETE FROM multi_fruit WHERE dKey=8", 1, undef, [ [ 5, 'via placeholders', 15 ], [ 3, undef, 13 ], [ 2, 'apples', 12 ], [ 1, 'oranges', 11 ], ], "DELETE FROM multi_fruit", 4, "SELECT COUNT(*) FROM multi_fruit", [ [ 0 ] ], "DROP TABLE multi_fruit", -1, ); SKIP: for my $idx ( 0 .. $#tests ) { $idx % 2 and next; my $sql = $tests[$idx]; my $result = $tests[$idx+1]; my ($comment, $sth, @bind); if( defined $sql ) { $sql =~ s/;$//; $sql =~ s/\s*;\s*(?:#(.*))//; $comment = $1; $comment and @bind = split /,/, $comment; $sth = $dbh->prepare($sql); ok($sth, "prepare <$sql> using '$test_dbd'") or diag($dbh->errstr || 'unknown error'); } else { $sql = $vsql; $sth = $vsth; $comment = undef; # evil hack to avoid full dbi emulating in TestLib defined $store{stmt} and $dbh->{stmt} = $store{stmt}; defined $store{sth} and $dbh->{sth} = $store{sth}; } # if execute errors we will handle it, not PrintError: my $n = $sth->execute(@bind); ok($n, "execute <$sql> using '$test_dbd'") or diag($sth->errstr || 'unknown error'); next if (!defined($n)); is( $n, $result, "execute($sql) == $result using '$test_dbd'") unless( 'ARRAY' eq ref $result ); TODO: { local $TODO = "AUTOPROXY drivers might throw away sth->rows()" if($ENV{DBI_AUTOPROXY}); is( $n, $sth->rows(), "\$sth->execute($sql) == \$sth->rows using $test_dbd") if( $sql =~ m/^(?:UPDATE|DELETE)/ ); } next unless $sql =~ /SELECT/; my $allrows = $sth->fetch_rows(); my $expected_rows = $result; is( $sth->rows, scalar( @{$expected_rows} ), "execute <$sql> == " . scalar( @{$expected_rows} ) . " using '$test_dbd'" ); is_deeply( $allrows, $expected_rows, "SELECT results for $sql using $test_dbd" ); # run SELECT 2nd time to test bug from RT#81523 $sth->finish(); $n = $sth->execute(@bind); ok($n, "execute <$sql> using '$test_dbd' 2nd time") or diag($sth->errstr || 'unknown error'); is( $n, $result, "execute($sql) == $result using '$test_dbd'") unless( 'ARRAY' eq ref $result ); $allrows = $sth->fetch_rows(); $expected_rows = $result; is( $sth->rows, scalar( @{$expected_rows} ), "execute <$sql> == " . scalar( @{$expected_rows} ) . " using '$test_dbd'" ); is_deeply( $allrows, $expected_rows, "SELECT results for $sql using '$test_dbd' 2nd time" ); } my $i_sql = "INSERT INTO test_tbl VALUES (?,?)"; my $s_sql = "SELECT dKey, dVal FROM test_tbl WHERE dKey=?"; my @rows = ( [ 1, "Perl" ], [ 2, "DBI" ], [ 3, "SQL::Statement" ], [ 4, "DBD::File" ], [ 5, "DBD::CSV" ], [ 6, "DBD::DBM" ], [ 7, "DBD::ODBC" ], [ 8, "DBD::SQLite" ], ); my @sqls = ( "DROP TABLE IF EXISTS test_tbl", -1, "CREATE $temp TABLE test_tbl (dKey INT, dVal VARCHAR(23))", '0E0', ( $i_sql, 1, $s_sql, 1, ) x scalar(@rows), "DROP TABLE test_tbl", -1, ); my %prepared; foreach my $sql ($i_sql, $s_sql) { my $sth = $dbh->prepare($sql); ok($sth, "prepare <$sql> using '$test_dbd'") or diag($dbh->errstr || 'unknown error'); # evil hack to avoid full dbi emulating in TestLib my %store; defined $dbh->{stmt} and $store{stmt} = $dbh->{stmt}; defined $dbh->{sth} and $store{sth} = $dbh->{sth}; $prepared{$sql} = \%store; } my $row_idx = 0; SKIP: for my $idx ( 0 .. $#sqls ) { $idx % 2 and next; my $sql = $sqls[$idx]; my $result = $sqls[$idx+1]; my ($sth, @bind); if( defined $prepared{$sql} ) { $sth = $dbh; # evil hack in TestLib - $sth == $dbh (wrapper classes!) # evil hack to avoid full dbi emulating in TestLib defined $prepared{$sql}{stmt} and $dbh->{stmt} = $prepared{$sql}{stmt}; defined $prepared{$sql}{sth} and $dbh->{sth} = $prepared{$sql}{sth}; $sth->command() eq "SELECT" and $result = [$rows[$row_idx++]] and @bind = ($result->[0][0]); $sth->command() eq "INSERT" and $result = 1 and @bind = @{$rows[$row_idx]}; $sql .= " [" . join(", ", @bind) . "]"; } else { $sql =~ s/;$//; $sql =~ s/\s*;\s*(?:#(.*))//; my $comment = $1; $comment and @bind = split /,/, $comment; $sth = $dbh->prepare($sql); ok($sth, "prepare <$sql> using '$test_dbd'") or diag($dbh->errstr || 'unknown error'); } # if execute errors we will handle it, not PrintError: my $n = $sth->execute(@bind); ok($n, "execute <$sql> using '$test_dbd'") or diag($sth->errstr || 'unknown error'); next if (!defined($n)); is( $n, $result, "execute($sql) == $result using '$test_dbd'") unless( 'ARRAY' eq ref $result ); next unless $sql =~ /SELECT/; my $allrows = $sth->fetch_rows(); my $expected_rows = $result; is( $sth->rows, scalar( @{$expected_rows} ), "execute <$sql> == " . scalar( @{$expected_rows} ) . " using '$test_dbd'" ); is_deeply( $allrows, $expected_rows, "SELECT results for $sql using $test_dbd" ); # run SELECT 2nd time to test bug from RT#81523 $sth->finish(); $n = $sth->execute(@bind); ok($n, "execute <$sql> using '$test_dbd' 2nd time") or diag($sth->errstr || 'unknown error'); is( $n, $result, "execute($sql) == $result using '$test_dbd'") unless( 'ARRAY' eq ref $result ); $allrows = $sth->fetch_rows(); $expected_rows = $result; is( $sth->rows, scalar( @{$expected_rows} ), "execute <$sql> == " . scalar( @{$expected_rows} ) . " using '$test_dbd'" ); is_deeply( $allrows, $expected_rows, "SELECT results for $sql using '$test_dbd' 2nd time" ); } } done_testing(); SQL-Statement-1.407/t/06virtual.t000644 000765 000024 00000140604 12527133655 016372 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs test_dir default_recommended); use Params::Util qw(_CODE _ARRAY); use Scalar::Util qw(looks_like_number); my ( $required, $recommended ) = prove_reqs( { default_recommended(), ( MLDBM => 0 ) } ); show_reqs( $required, $recommended ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); my $testdir = test_dir(); my @massValues = map { [ $_, ( "a" .. "f" )[ int rand 6 ], int rand 10 ] } ( 1 .. 3999 ); # (this code shamelessly stolen from Math::Complex's t/Trig.t, with some mods to near) use Math::Trig; my $eps = 1e-11; my $have_soundex = 0; eval qq{ require Text::Soundex; \$have_soundex = 1; }; if ($^O eq 'unicos') { # See lib/Math/Complex.pm and t/lib/complex.t. $eps = 1e-10; } sub near ($$$) { my $d = $_[1] ? abs($_[0]/$_[1] - 1) : abs($_[0]); local $Test::Builder::Level = $Test::Builder::Level + 1; looks_like_number($_[0]) or return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/nan/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); $_[0] =~ m/inf/i and return cmp_ok($_[0], "eq", $_[1], "near? $_[0] ~= $_[1]"); cmp_ok($d, '<', $eps, "$_[2] => near? $_[0] ~= $_[1]") or diag("near? $_[0] ~= $_[1]"); } # SKIP: foreach my $test_dbd (@test_dbds) { my $dbh; note("Running tests for $test_dbd"); my $temp = ""; # XXX # my $test_dbd_tbl = "${test_dbd}::Table"; # $test_dbd_tbl->can("fetch") or $temp = "$temp"; $test_dbd eq "DBD::File" and $temp = "TEMP"; $test_dbd eq "SQL::Statement" and $temp = "TEMP"; my %extra_args; if ( $test_dbd eq "DBD::DBM" ) { if ( $recommended->{MLDBM} ) { $extra_args{dbm_mldbm} = "Storable"; } else { skip( 'DBD::DBM test runs without MLDBM', 1 ); } } $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, f_dir => $testdir, %extra_args, } ); my ( $sth, $str ); my $now = time(); my @timelist; for my $hour ( 1 .. 10 ) { push( @timelist, $now - ( $hour * 3600 ) ); } for my $sql ( split /\n/, sprintf( <<"", ($now) x 7, @timelist ) CREATE $temp TABLE biz (sales INTEGER, class CHAR, color CHAR, BUGNULL CHAR) INSERT INTO biz VALUES (1000, 'Car', 'White', NULL) INSERT INTO biz VALUES ( 500, 'Car', 'Blue', NULL ) INSERT INTO biz VALUES ( 400, 'Truck', 'White', NULL ) INSERT INTO biz VALUES ( 700, 'Car', 'Red', NULL ) INSERT INTO biz VALUES ( 300, 'Truck', 'White', NULL ) CREATE $temp TABLE baz (ordered INTEGER, class CHAR, color CHAR) INSERT INTO baz VALUES ( 250, 'Car', 'White' ), ( 100, 'Car', 'Blue' ), ( 150, 'Car', 'Red' ) INSERT INTO baz VALUES ( 80, 'Truck', 'White' ), ( 60, 'Truck', 'Green' ) -- Yes, we introduce new cars :) INSERT INTO baz VALUES ( 666, 'Truck', 'Yellow -- no, blue' ) -- Double dash inside quotes does not introduce comment CREATE $temp TABLE numbers (c_foo INTEGER, foo CHAR, bar INTEGER) CREATE $temp TABLE trick (id INTEGER, foo CHAR) INSERT INTO trick VALUES (1, '1foo') INSERT INTO trick VALUES (11, 'foo') CREATE TYPE TIMESTAMP CREATE $temp TABLE log (id INT, host CHAR, signature CHAR, message CHAR, time_stamp TIMESTAMP) INSERT INTO log VALUES (1, 'bert', '/netbsd', 'Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,', %d) INSERT INTO log VALUES (2, 'bert', '/netbsd', '2006, 2007, 2008, 2009, 2010', %d) INSERT INTO log VALUES (3, 'bert', '/netbsd', 'The NetBSD Foundation, Inc. All rights reserved.', %d) INSERT INTO log VALUES (4, 'bert', '/netbsd', 'Copyright (c) 1982, 1986, 1989, 1991, 1993', %d) INSERT INTO log VALUES (5, 'bert', '/netbsd', 'The Regents of the University of California. All rights reserved.', %d) INSERT INTO log VALUES (6, 'bert', '/netbsd', '', %d) INSERT INTO log VALUES (7, 'bert', '/netbsd', 'NetBSD 5.99.39 (BERT) #0: Fri Oct 8 06:23:03 CEST 2010', %d) INSERT INTO log VALUES (8, 'ernie', 'rpc.statd', 'starting', %d) INSERT INTO log VALUES (9, 'ernie', 'savecore', 'no core dump', %d) INSERT INTO log VALUES (10, 'ernie', 'postfix/postfix-script', 'starting the Postfix mail system', %d) INSERT INTO log VALUES (11, 'ernie', 'rpcbind', 'connect from 127.0.0.1 to dump()', %d) INSERT INTO log VALUES (12, 'ernie', 'sshd', 'last message repeated 2 times', %d) INSERT INTO log VALUES (13, 'ernie', 'shutdown', 'poweroff by root:', %d) INSERT INTO log VALUES (14, 'ernie', 'shutdown', 'rebooted by root', %d) INSERT INTO log VALUES (15, 'ernie', 'sshd', 'Server listening on :: port 22.', %d) INSERT INTO log VALUES (16, 'ernie', 'sshd', 'Server listening on 0.0.0.0 port 22.', %d) INSERT INTO log VALUES (17, 'ernie', 'sshd', 'Received SIGHUP; restarting.', %d) ) { ok( $sth = $dbh->prepare($sql), "prepare $sql on $test_dbd" ) or diag( $dbh->errstr() ); ok( $sth->execute(), "execute $sql on $test_dbd" ) or diag( $sth->errstr() ); } my @tests = ( ### GROUP BY Tests ### { test => 'GROUP BY one column', sql => "SELECT class,SUM(sales) as foo, MAX(sales) FROM biz GROUP BY class", fetch_by => 'class', result => { Car => { MAX => '1000', foo => 2200, class => 'Car' }, Truck => { MAX => '400', foo => 700, class => 'Truck' } }, }, { test => "GROUP BY several columns", sql => "SELECT color,class,SUM(sales), MAX(sales) FROM biz GROUP BY color,class", fetch_by => [ 'color', 'class' ], result => { Blue => { Car => { color => 'Blue', class => 'Car', SUM => 500, MAX => 500, }, }, Red => { Car => { color => 'Red', class => 'Car', SUM => 700, MAX => 700, }, }, White => { Car => { color => 'White', class => 'Car', SUM => 1000, MAX => 1000, }, Truck => { color => 'White', class => 'Truck', SUM => 700, MAX => 400, }, } }, }, { test => 'AGGREGATE FUNCTIONS WITHOUT GROUP BY', sql => "SELECT SUM(sales), MAX(sales) FROM biz", result => [ [ 2900, 1000 ], ] }, { test => 'COUNT(distinct column) WITHOUT GROUP BY', sql => "SELECT COUNT(DISTINCT class) FROM biz", result => [ [ 2 ], ] }, { test => 'COUNT(distinct column) WITH GROUP BY', sql => "SELECT distinct class, COUNT(distinct color) FROM biz GROUP BY class", fetch_by => 'class', result => { Car => { class => 'Car', COUNT => 3, }, Truck => { class => 'Truck', COUNT => 1, }, }, }, { test => 'COUNT(*) with GROUP BY', sql => "SELECT class, COUNT(*) FROM biz GROUP BY class", fetch_by => 'class', result => { Car => { class => 'Car', COUNT => 3, }, Truck => { class => 'Truck', COUNT => 2, }, }, }, { test => 'ORDER BY on aliased column', sql => "SELECT DISTINCT biz.class, baz.color AS foo FROM biz, baz WHERE biz.class = baz.class ORDER BY foo", result => [ [ qw(Car Blue) ], [ qw(Truck Green) ], [ qw(Car Red) ], [ qw(Car White) ], [ qw(Truck White) ], [ Truck => 'Yellow -- no, blue' ], ], }, { test => 'COUNT(DISTINCT *) fails', sql => "SELECT class, COUNT(distinct *) FROM biz GROUP BY class", prepare_err => qr/Keyword DISTINCT is not allowed for COUNT/m, }, { test => 'GROUP BY required', sql => "SELECT class, COUNT(color) FROM biz", execute_err => qr/Column 'biz\.class' must appear in the GROUP BY clause or be used in an aggregate function/, }, ### Aggregate Functions ### { test => 'SUM(bar) of empty table', sql => "SELECT SUM(bar) FROM numbers", result => [ [undef] ], }, { test => 'COUNT(bar) of empty table with GROUP BY', sql => "SELECT COUNT(bar),c_foo FROM numbers GROUP BY c_foo", result => [ [ 0, undef ] ], }, { test => 'COUNT(*) of empty table', sql => "SELECT COUNT(*) FROM numbers", result => [ [0] ], }, { test => 'Mass insert of random numbers', sql => "INSERT INTO numbers VALUES (?, ?, ?)", params => \@massValues, }, { test => 'Number of rows in aggregated Table', sql => "SELECT foo AS boo, COUNT (*) AS counted FROM numbers GROUP BY boo", result_cols => [qw(boo counted)], result_code => sub { my $sth = $_[0]; my $res = $sth->fetch_rows(); cmp_ok( scalar( @{$res} ), '==', '6', 'Number of rows in aggregated Table' ); my $all_counted = 0; foreach my $row ( @{$res} ) { $all_counted += $row->[1]; } cmp_ok( $all_counted, '==', 3999, 'SUM(COUNTED)' ); }, }, { test => 'Aggregate functions MIN, MAX, AVG', sql => "SELECT MIN(c_foo), MAX(c_foo), AVG(c_foo) FROM numbers", result => [ [ 1, 3999, 2000 ], ], }, { test => 'COUNT(*) internal for nasty table', sql => "SELECT COUNT(*) FROM trick", result => [ [2] ], }, ### Date/Time Functions ### { test => 'current_date int', sql => "SELECT CURRENT_DATE()", result_like => qr/^\d{4}-\d{2}-\d{2}$/, }, { test => 'current_time int', sql => "SELECT CURRENT_TIME", result_like => qr/^\d{2}:\d{2}:\d{2}$/, }, { test => 'current_timestamp int', sql => "SELECT CURRENT_TIMESTAMP()", result_like => qr/^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}$/, }, { test => 'curdate int', sql => "SELECT CURDATE", result_like => qr/^\d{4}-\d{2}-\d{2}$/, }, { test => 'curtime int', sql => "SELECT CURTIME()", result_like => qr/^\d{2}:\d{2}:\d{2}$/, }, { test => 'now int', sql => "SELECT NOW", result_like => qr/^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}$/, }, { test => 'unix_timestamp int', sql => "SELECT UNIX_TIMESTAMP()", result_like => qr/^\d{10,}$/, }, { test => 'current_time precision', sql => "SELECT CURRENT_TIME (1)", result_like => qr/^\d{2}:\d{2}:\d{2}\.\d{1}$/, }, { test => 'current_timestamp precision', sql => "SELECT CURRENT_TIMESTAMP (2)", result_like => qr/^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}\.\d{2}$/, }, { test => 'curtime precision', sql => "SELECT CURTIME (3)", result_like => qr/^\d{2}:\d{2}:\d{2}\.\d{3}$/, }, { test => 'now precision', sql => "SELECT NOW(4)", result_like => qr/^\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}\.\d{4}$/, }, { test => 'unix_timestamp precision', sql => "SELECT UNIX_TIMESTAMP(5)", result_like => qr/^\d{10,}\.\d{5}$/, }, ### String Functions ### { test => 'ascii char', sql => "SELECT ASCII('A')", result => [ [65] ], }, { test => 'ascii str', sql => "SELECT ASCII('ABC')", result => [ [65] ], }, { test => 'char blank', sql => "SELECT CHAR()", result => [ [''] ], }, { test => 'char char', sql => "SELECT CHAR(65)", result => [ ['A'] ], }, { test => 'char char unicode', sql => "SELECT CHAR(CONV('263A', 16))", result => [ [chr(0x263a)] ], }, { test => 'char str', sql => "SELECT CHAR(65,66,67)", result => [ ['ABC'] ], }, { test => 'char str unicode', sql => "SELECT CHAR(CONV('263A', 16), 9787, CONV('10011000111100', 2))", result => [ [chr(9786).chr(9787).chr(9788)] ], }, { test => 'bit_length 6bit', sql => "SELECT BIT_LENGTH(' oo')", result => [ [22] ], }, { test => 'bit_length 7bit', sql => "SELECT BIT_LENGTH('foo')", result => [ [23] ], }, { test => 'bit_length unicode', sql => "SELECT BIT_LENGTH(CHAR(9786, 9787, 9788))", result => [ [62] ], comment=> '14+24+24', }, { test => 'character_length', sql => "SELECT CHARACTER_LENGTH('foo')", result => [ [3] ], }, { test => 'char_length', sql => "SELECT CHAR_LENGTH('foo')", result => [ [3] ], }, { test => 'character_length unicode', sql => "SELECT CHARACTER_LENGTH(CHAR(9786, 9787, 9788))", result => [ [3] ], }, { test => 'char_length unicode', sql => "SELECT CHAR_LENGTH(CHAR(9786, 9787, 9788))", result => [ [3] ], }, { test => 'coalesce', sql => "SELECT COALESCE(NULL,'z')", result => [ ['z'] ], }, { test => 'nvl', sql => "SELECT NVL(NULL,'z')", result => [ ['z'] ], }, { test => 'ifnull', sql => "SELECT IFNULL(NULL,'z')", result => [ ['z'] ], }, { test => 'concat good', sql => "SELECT CONCAT('A','B')", result => [ ['AB'] ], }, { test => 'concat bad', sql => "SELECT CONCAT('A',NULL)", result => [ [undef] ], }, { test => 'conv 2->64', sql => "SELECT CONV('10101001111011101101011', 2, 64)", result => [ ['VPdr'] ], }, { test => 'conv 2->16', sql => "SELECT CONV('10101001111011101101011', 2, 16)", result => [ ['54f76b'] ], }, { test => 'conv 2->10', sql => "SELECT CONV('10101001111011101101011', 2, 10)", result => [ [5568363] ], }, { test => 'conv 2->8', sql => "SELECT CONV('10101001111011101101011', 2, 8)", result => [ [25173553] ], }, { test => 'conv 2->2', sql => "SELECT CONV('10101001111011101101011', 2, 2)", result => [ ['10101001111011101101011'] ], }, { test => 'conv 10->16 integer with trailing 0', sql => "select conv('16', 10, 16)", result => [ ['10'] ], }, { test => 'conv 10->16 integer 0', sql => "select conv('0', 10, 16)", result => [ ['0'] ], }, { test => 'decode', sql => q{SELECT DISTINCT DECODE(color,'White','W','Red','R','B') AS cfc FROM biz ORDER BY cfc}, result => [ ['B'], ['R'], ['W'] ], }, { test => 'insert good 1:1', sql => "SELECT INSERT('foodieland', 4, 3, 'bar')", result => [ ['foobarland'] ], }, { test => 'insert good non-1:1', sql => "SELECT INSERT('foodland', 4, 1, 'bar')", result => [ ['foobarland'] ], }, { test => 'insert bad 1', sql => "SELECT INSERT(NULL, 4, 1, 'bar')", result => [ [undef] ], }, { test => 'insert bad 2', sql => "SELECT INSERT('foodland', 4, 1, NULL)", result => [ [undef] ], }, { test => 'left good', sql => "SELECT LEFT('foodland', 4)", result => [ ['food'] ], }, { test => 'left bad 1', sql => "SELECT LEFT(NULL, 4)", result => [ [undef] ], }, { test => 'left bad 2', sql => "SELECT LEFT('foodland', NULL)", result => [ [undef] ], }, { test => 'right good', sql => "SELECT RIGHT('foodland', 4)", result => [ ['land'] ], }, { test => 'right bad 1', sql => "SELECT RIGHT(NULL, 4)", result => [ [undef] ], }, { test => 'right bad 2', sql => "SELECT RIGHT('foodland', NULL)", result => [ [undef] ], }, { test => 'locate 2param', sql => "SELECT LOCATE('a','bar')", result => [ [2] ], }, { test => 'locate 3param', sql => "SELECT LOCATE('a','barafa',3)", result => [ [4] ], }, { test => 'position 2param', sql => "SELECT POSITION('a','bar')", result => [ [2] ], }, { test => 'position 3param', sql => "SELECT POSITION('a','barafa',3)", result => [ [4] ], }, { test => 'lower', sql => "SELECT LOWER('A')", result => [ ['a'] ], }, { test => 'upper', sql => "SELECT UPPER('a')", result => [ ['A'] ], }, { test => 'lcase', sql => "SELECT LCASE('A')", result => [ ['a'] ], }, { test => 'ucase', sql => "SELECT UCASE('a')", result => [ ['A'] ], }, { test => 'ltrim', sql => q{SELECT LTRIM(' fun ')}, result => [ ['fun '] ], }, { test => 'rtrim', sql => q{SELECT RTRIM(' fun ')}, result => [ [' fun'] ], }, { test => 'octet_length', sql => "SELECT OCTET_LENGTH('foo')", result => [ [3] ], }, { test => 'octet_length unicode', sql => "SELECT OCTET_LENGTH(CHAR(64, 169, 9786, 65572))", result => [ [10] ], comment=> '1+2+3+4', }, { test => 'regex match', sql => "SELECT REGEX('jeff','/EF/i')", result => [ [1] ], }, { test => 'regex no match', sql => "SELECT REGEX('jeff','/zzz/')", result => [ [0] ], }, { test => 'repeat', sql => q{SELECT REPEAT('zfunkY', 3)}, result => [ ['zfunkYzfunkYzfunkY'] ], }, { test => 'replace', sql => q{SELECT REPLACE('zfunkY','s/z(.+)ky/$1/i')}, result => [ ['fun'] ], }, { test => 'substitute', sql => q{SELECT SUBSTITUTE('zfunkY','s/z(.+)ky/$1/i')}, result => [ ['fun'] ], }, ($have_soundex ? ( { test => 'soundex match', sql => "SELECT SOUNDEX('jeff','jeph')", result => [ [1] ], }, { test => 'soundex no match', sql => "SELECT SOUNDEX('jeff','quartz')", result => [ [0] ], }, ) : ()), { test => 'space', sql => q{SELECT SPACE(10)}, result => [ [' ' x 10] ], }, { test => 'substr', sql => q{SELECT SUBSTR('zfunkY',2,3)}, result => [ ['fun'] ], }, { test => 'substring', sql => "SELECT DISTINCT color FROM biz WHERE SUBSTRING(class FROM 1 FOR 1)='T'", result => [ ['White'] ], }, { test => 'translate', sql => q{SELECT TRANSLATE('foobar forever', 'oae', '0@3')}, result => [ ['f00b@r f0r3v3r'] ], }, { test => 'trim simple', sql => q{SELECT TRIM(' fun ')}, result => [ ['fun'] ], }, { test => 'trim leading', todo => "Analyze why this fails; may be thinking FROM keyword is for table specs", sql => q{SELECT TRIM(LEADING FROM ' fun ')}, result => [ ['fun '] ], }, { test => 'trim trailing', todo => "Analyze why this fails; may be thinking FROM keyword is for table specs", sql => q{SELECT TRIM(TRAILING FROM ' fun ')}, result => [ [' fun'] ], }, { test => 'trim leading ;', todo => "Analyze why this fails; may be thinking FROM keyword is for table specs", sql => q{SELECT TRIM(LEADING ';' FROM ';;; fun ')}, result => [ [' fun '] ], }, { test => 'unhex str', sql => "SELECT UNHEX('414243')", result => [ ['ABC'] ], }, { test => 'unhex str unicode', sql => "SELECT UNHEX('263A' || HEX(9787) || CONV('10011000111100', 2, 16), 'UCS-2')", result => [ [chr(9786).chr(9787).chr(9788)] ], }, { test => 'bin from dec', sql => "SELECT BIN('9788')", result => [ ['10011000111100'] ], }, { test => 'oct from dec', sql => "SELECT OCT('420')", result => [ ['644'] ], }, ### Numeric Functions ### { test => 'abs', sql => "SELECT ABS(-4)", result => [ [4] ], }, { test => 'ceiling int', sql => "SELECT CEILING(5)", result => [ [5] ], }, { test => 'ceiling positive', sql => "SELECT CEILING(4.1)", result => [ [5] ], }, { test => 'ceil negative', sql => "SELECT CEIL(-4.5)", result => [ [-4] ], }, { test => 'floor int', sql => "SELECT FLOOR(-5)", result => [ [-5] ], }, { test => 'floor positive', sql => "SELECT FLOOR(4.999999999999)", result => [ [4] ], }, { test => 'floor negative', sql => "SELECT FLOOR(-4.1)", result => [ [-5] ], }, { test => 'exp', sql => "SELECT EXP(1)", result => [ [sinh(1)+cosh(1)] ], }, { test => 'log as log10', sql => "SELECT LOG(6)", result => [ [log(6) / log(10)] ], }, { test => 'log as log2', sql => "SELECT LOG(2, 32)", result => [ [log(32) / log(2)] ], }, { test => 'ln', sql => "SELECT LN(3)", result => [ [log(3)] ], }, { test => 'mod', sql => "SELECT MOD(8, 5)", result => [ [3] ], }, { test => 'power', sql => "SELECT POWER(2, 4)", result => [ [16] ], }, { test => 'pow', sql => "SELECT POW(2, 4)", result => [ [16] ], }, { test => 'rand', sql => "SELECT FLOOR(RAND(4))", result_like => qr/^[0123]$|^-0$/, }, { test => 'rand with seed', sql => "SELECT FLOOR(RAND(4), UNIX_TIMESTAMP())", result_like => qr/^-?[0123]$|^-0$/, }, { test => 'round int', sql => "SELECT ROUND(4.999999999999)", result => [ [5] ], }, { test => 'round tenth', sql => "SELECT ROUND(4.542222222222, 1)", result => [ [4.5] ], }, { test => 'sign -1', sql => "SELECT SIGN(-25.5)", result => [ [-1] ], }, { test => 'sign 1', sql => "SELECT SIGN(53645)", result => [ [1] ], }, { test => 'sign 0', sql => "SELECT SIGN(0)", result => [ [0] ], }, { test => 'sign null', sql => "SELECT SIGN(NULL)", result => [ [undef] ], }, { test => 'sqrt', sql => "SELECT SQRT(64)", result => [ [8] ], }, { test => 'truncate int', sql => "SELECT TRUNCATE(4.999999999999)", result => [ [4] ], }, { test => 'trunc int', sql => "SELECT TRUNC(-4.9)", result => [ [-4] ], }, { test => 'truncate tenth', sql => "SELECT TRUNCATE(4.934, 1)", result => [ [4.9] ], }, { test => 'trunc int', sql => "SELECT TRUNC(-4.99999, 1)", result => [ [-4.9] ], }, ### Trigonometric Functions ### # (this code shamelessly stolen from Math::Complex's t/Trig.t and converted to this test format) { test => 'sin(1)', sql => "SELECT SIN(1)", result_near => sin(1), }, { test => 'cos(1)', sql => "SELECT COS(1)", result_near => cos(1), }, { test => 'tan(1)', sql => "SELECT TAN(1)", result_near => tan(1), }, { test => 'sec(1)', sql => "SELECT SEC(1)", result_near => sec(1), }, { test => 'csc(1)', sql => "SELECT CSC(1)", result_near => csc(1), }, { test => 'cosec(1)', sql => "SELECT COSEC(1)", result_near => cosec(1), }, { test => 'cot(1)', sql => "SELECT COT(1)", result_near => cot(1), }, { test => 'cotan(1)', sql => "SELECT COTAN(1)", result_near => cotan(1), }, { test => 'asin(1)', sql => "SELECT ASIN(1)", result_near => asin(1), }, { test => 'acos(1)', sql => "SELECT ACOS(1)", result_near => acos(1), }, { test => 'atan(1)', sql => "SELECT ATAN(1)", result_near => atan(1), }, { test => 'asec(1)', sql => "SELECT ASEC(1)", result_near => asec(1), }, { test => 'acsc(1)', sql => "SELECT ACSC(1)", result_near => acsc(1), }, { test => 'acosec(1)', sql => "SELECT ACOSEC(1)", result_near => acosec(1), }, { test => 'acot(1)', sql => "SELECT ACOT(1)", result_near => acot(1), }, { test => 'acotan(1)', sql => "SELECT ACOTAN(1)", result_near => acotan(1), }, { test => 'sinh(1)', sql => "SELECT SINH(1)", result_near => sinh(1), }, { test => 'cosh(1)', sql => "SELECT COSH(1)", result_near => cosh(1), }, { test => 'tanh(1)', sql => "SELECT TANH(1)", result_near => tanh(1), }, { test => 'sech(1)', sql => "SELECT SECH(1)", result_near => sech(1), }, { test => 'csch(1)', sql => "SELECT CSCH(1)", result_near => csch(1), }, { test => 'cosech(1)', sql => "SELECT COSECH(1)", result_near => cosech(1), }, { test => 'coth(1)', sql => "SELECT COTH(1)", result_near => coth(1), }, { test => 'cotanh(1)', sql => "SELECT COTANH(1)", result_near => cotanh(1), }, { test => 'asinh(1)', sql => "SELECT ASINH(1)", result_near => asinh(1), }, { test => 'acosh(1)', sql => "SELECT ACOSH(1)", result_near => acosh(1), }, { test => 'atanh(0.9)', sql => "SELECT ATANH(0.9)", result_near => atanh(0.9), }, { test => 'asech(0.9)', sql => "SELECT ASECH(0.9)", # atanh(1.0) would be an error. result_near => asech(0.9), }, { test => 'acsch(2)', sql => "SELECT ACSCH(2)", result_near => acsch(2), }, { test => 'acosech(2)', sql => "SELECT ACOSECH(2)", result_near => acosech(2), }, { test => 'acoth(2)', sql => "SELECT ACOTH(2)", result_near => acoth(2), }, { test => 'acotanh(2)', sql => "SELECT ACOTANH(2)", result_near => acotanh(2), }, { test => 'pi', sql => "SELECT PI", result_near => pi, }, { test => 'atan2(1, 0)', sql => "SELECT ATAN2(1, 0)", result_near => atan2(1, 0), }, { test => 'atan2(1, 1)', sql => "SELECT ATAN2(1, 1)", result_near => atan(1, 1), }, { test => 'atan2(-1, -1) to -3pi/4', sql => "SELECT ATAN2(-1, -1)", result_near => atan2(-1, -1), }, { test => 'tan(0.9) as property sin/cos', sql => "SELECT TAN(0.9)", result_near => tan(0.9), }, { test => 'sinh(2)', sql => "SELECT SINH(2)", result_near => sinh(2), }, { test => 'acsch 0.1', sql => "SELECT ACSCH(0.1)", result_near => acsch(0.1), }, { test => 'deg2rad(90)', sql => "SELECT DEG2RAD(90)", result_near => deg2rad(90), }, { test => 'radians(90)', sql => "SELECT RADIANS(90)", result_near => deg2rad(90), }, { test => 'rad2deg(PI)', sql => "SELECT RAD2DEG(PI)", result_near => rad2deg(pi), }, { test => 'degrees(PI)', sql => "SELECT DEGREES(PI())", result_near => rad2deg(pi), }, { test => 'deg2grad(0.9)', sql => "SELECT DEG2GRAD(0.9)", result_near => deg2grad(0.9), }, { test => 'grad2deg(50)', sql => "SELECT GRAD2DEG(50)", result_near => grad2deg(50), }, { # XXX calculus within function parameters with functions as operands do not work test => 'rad2grad(pi/2)', sql => "SELECT RAD2GRAD(PI/2)", result_near => rad2grad(pi/2), todo => "Known limitation. Parser/Engine can not handle properly", }, { test => 'rad2grad(pi)', sql => "SELECT RAD2GRAD(PI)", result_near => rad2grad(pi), }, { test => 'grad2rad(200)', sql => "SELECT GRAD2RAD(200)", result_near => grad2rad(200), }, { test => 'lotta radians - deg2rad(10000000000)', sql => "SELECT DEG2RAD(10000000000)", result_near => deg2rad(10000000000), }, { test => 'negative degrees - rad2deg(-10000000000)', sql => "SELECT RAD2DEG(-10000000000)", result_near => rad2deg(-10000000000), }, { test => 'positive degrees - rad2deg(10000)', sql => "SELECT RAD2DEG(10000)", result_near => rad2deg(10000), }, { test => 'tanh 100', sql => "SELECT TANH(100)", result_near => tanh(100), }, { test => 'coth 100', sql => "SELECT COTH(100)", result_near => coth(100), }, { test => 'tanh -100', sql => "SELECT TANH(-100)", result_near => tanh(-100), }, { test => 'coth -100', sql => "SELECT COTH(-100)", result_near => coth(-100), }, { test => 'sech 1e5', sql => "SELECT SECH(100000)", result_near => sech(100000), }, { test => 'csch 1e5', sql => "SELECT CSCH(100000)", result_near => csch(100000), }, { test => 'tanh 1e5', sql => "SELECT TANH(100000)", result_near => tanh(100000), }, { test => 'coth 1e5', sql => "SELECT COTH(100000)", result_near => coth(100000), }, { test => 'sech -1e5', sql => "SELECT SECH(-100000)", result_near => sech(-100000), }, { test => 'csch -1e5', sql => "SELECT CSCH(-100000)", result_near => csch(-100000), comment=> 'Is meant to return a "negative zero"' }, { test => 'tanh -1e5', sql => "SELECT TANH(-100000)", result_near => tanh(-100000), }, { test => 'coth -1e5', sql => "SELECT COTH(-100000)", result_near => Math::Trig::coth(-100000), }, ### System Functions { test => 'dbname', sql => "SELECT DBNAME()", result => [ [$dbh->{Name}] ], }, { test => 'username', sql => "SELECT USERNAME()", result => [ [$dbh->{CURRENT_USER}] ], }, { test => 'user', sql => "SELECT USER()", result => [ [$dbh->{CURRENT_USER}] ], }, { test => 'SELECT with calculation in WHERE CLAUSE', sql => sprintf( "SELECT id,host,signature,message FROM log WHERE time_stamp < (%d - ( 4 * 60 ))", $now ), fetch_by => "id", result => { 8 => { id => 8, host => "ernie", signature => "rpc.statd", message => "starting", }, 9 => { id => 9, host => "ernie", signature => "savecore", message => "no core dump", }, 10 => { id => 10, host => "ernie", signature => "postfix/postfix-script", message => "starting the Postfix mail system", }, 11 => { id => 11, host => "ernie", signature => "rpcbind", message => "connect from 127.0.0.1 to dump()", }, 12 => { id => 12, host => "ernie", signature => "sshd", message => "last message repeated 2 times", }, 13 => { id => 13, host => "ernie", signature => "shutdown", message => "poweroff by root:", }, 14 => { id => 14, host => "ernie", signature => "shutdown", message => "rebooted by root", }, 15 => { id => 15, host => "ernie", signature => "sshd", message => "Server listening on :: port 22.", }, 16 => { id => 16, host => "ernie", signature => "sshd", message => "Server listening on 0.0.0.0 port 22.", }, 17 => { id => 17, host => "ernie", signature => "sshd", message => "Received SIGHUP; restarting.", }, }, }, { test => 'SELECT with calculation and logical expression in WHERE CLAUSE', sql => sprintf( "SELECT id,host,signature,message FROM log WHERE (time_stamp > (%d - 5)) AND (time_stamp < (%d + 5))", $now, $now ), fetch_by => "id", result => { 1 => { id => 1, host => "bert", signature => "/netbsd", message => "Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,", }, 2 => { id => 2, host => "bert", signature => "/netbsd", message => "2006, 2007, 2008, 2009, 2010", }, 3 => { id => 3, host => "bert", signature => "/netbsd", message => "The NetBSD Foundation, Inc. All rights reserved.", }, 4 => { id => 4, host => "bert", signature => "/netbsd", message => "Copyright (c) 1982, 1986, 1989, 1991, 1993", }, 5 => { id => 5, host => "bert", signature => "/netbsd", message => "The Regents of the University of California. All rights reserved.", }, 6 => { id => 6, host => "bert", signature => "/netbsd", message => '', }, 7 => { id => 7, host => "bert", signature => "/netbsd", message => "NetBSD 5.99.39 (BERT) #0: Fri Oct 8 06:23:03 CEST 2010", }, }, }, { test => 'SELECT with calculated items in BETWEEN in WHERE CLAUSE', sql => sprintf( "SELECT id,host,signature,message FROM log WHERE time_stamp BETWEEN ( %d - 5, %d + 5)", $now, $now ), fetch_by => "id", result => { 1 => { id => 1, host => "bert", signature => "/netbsd", message => "Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,", }, 2 => { id => 2, host => "bert", signature => "/netbsd", message => "2006, 2007, 2008, 2009, 2010", }, 3 => { id => 3, host => "bert", signature => "/netbsd", message => "The NetBSD Foundation, Inc. All rights reserved.", }, 4 => { id => 4, host => "bert", signature => "/netbsd", message => "Copyright (c) 1982, 1986, 1989, 1991, 1993", }, 5 => { id => 5, host => "bert", signature => "/netbsd", message => "The Regents of the University of California. All rights reserved.", }, 6 => { id => 6, host => "bert", signature => "/netbsd", message => '', }, 7 => { id => 7, host => "bert", signature => "/netbsd", message => "NetBSD 5.99.39 (BERT) #0: Fri Oct 8 06:23:03 CEST 2010", }, }, }, { test => 'MAX() with calculated WHERE clause', sql => sprintf( "SELECT MAX(time_stamp) FROM log WHERE time_stamp IN (%d - (2*3600), %d - (4*3600))", $now, $now ), result => [ [ $now - ( 2 * 3600 ) ] ], }, { test => 'calculation in MAX()', sql => "SELECT MAX(time_stamp - 3*3600) FROM log", result => [ [ $now - ( 3 * 3600 ) ] ], }, { test => 'Caclulation outside aggregation', todo => "Known limitation. Parser/Engine can not handle properly", passes => 'parse-DBD::CSV parse-DBD::File parse-DBD::DBM', sql => "SELECT MAX(time_stamp) - 3*3600 FROM log", result => [ [ $now - ( 3 * 3600 ) ] ], }, { test => 'function in MAX()', sql => "SELECT MAX( CHAR_LENGTH(message) ) FROM log", result => [ [73] ], }, { test => 'select simple calculated constant from table', sql => "SELECT 1+0 from log", result => [ ( [1] ) x 17 ], }, { test => 'select calculated constant with preceedence rules', sql => "SELECT 1+1*2", result => [ [3] ], }, { test => 'SELECT not calculated constant', sql => "SELECT 1", result => [ [1] ], }, ); foreach my $test (@tests) { local $TODO; defined($test->{todo}) and not (defined($test->{passes}) and $test->{passes} =~ /(?:parse|execute|result)(?:(?!-)|-\Q$test_dbd\E)/) and $TODO = $test->{todo}; if ( defined( $test->{prepare_err} ) ) { $sth = $dbh->prepare( $test->{sql} ); ok( !$sth, "prepare $test->{sql} using $test_dbd fails" ); like( $dbh->errstr(), $test->{prepare_err}, $test->{test} ); next; } $sth = $dbh->prepare( $test->{sql} ); ok( $sth, "prepare $test->{sql} using $test_dbd" ) or diag( $dbh->errstr() ); $sth or next; defined($test->{todo}) and not (defined($test->{passes}) and $test->{passes} =~ /(?:execute|result)(?:(?!-)|-\Q$test_dbd\E)/) and $TODO = $test->{todo}; if ( defined( $test->{params} ) ) { my $params; if ( defined( _CODE( $test->{params} ) ) ) { $params = [ &{ $test->{params} } ]; } elsif ( !defined( _ARRAY( $test->{params}->[0] ) ) ) { $params = [ $test->{params} ]; } else { $params = $test->{params}; } my $i = 0; my @failed; foreach my $bp ( @{ $test->{params} } ) { ++$i; my $n = $sth->execute(@$bp); $n or ok( $n, "$i: execute $test->{sql} using $test_dbd (" . DBI::neat_list($bp) . ")" ) or diag( $dbh->errstr() ) or push( @failed, $bp ); # 'SELECT' eq $sth->command() or next; # could become funny ... } @failed or ok( 1, "1 .. $i: execute $test->{sql} using $test_dbd" ); } else { my $n = $sth->execute(); if ( defined( $test->{execute_err} ) ) { ok( !$n, "execute $test->{sql} using $test_dbd fails" ); like( $dbh->errstr(), $test->{execute_err}, $test->{test} ); next; } ok( $n, "execute $test->{sql} using $test_dbd" ) or diag( $dbh->errstr() ); 'SELECT' eq $sth->command() or next; defined($test->{todo}) and not (defined($test->{passes}) and $test->{passes} =~ /result(?:(?!-)|-\Q$test_dbd\E)/) and $TODO = $test->{todo}; if ( $test->{result_cols} ) { is_deeply( $sth->col_names(), $test->{result_cols}, "Columns in $test->{test}" ); } if ( $test->{fetch_by} ) { is_deeply( $sth->fetchall_hashref( $test->{fetch_by} ), $test->{result}, $test->{test} ); } elsif ( defined( $test->{result_code} ) ) { &{ $test->{result_code} }($sth); } elsif ( defined( $test->{result_like} ) ) { my $row = $sth->fetch_rows(); like( $row && $row->[0] && $row->[0][0], $test->{result_like}, $test->{test} ); } elsif ( defined( $test->{result_near} ) ) { my $row = $sth->fetch_rows(); near( $row && $row->[0] && $row->[0][0], $test->{result_near}, $test->{test} ); } else { is_deeply( $sth->fetch_rows(), $test->{result}, $test->{test} ); } } } } done_testing(); SQL-Statement-1.407/t/08join.t000644 000765 000024 00000065775 12160006754 015654 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use TestLib qw(connect prove_reqs show_reqs test_dir default_recommended); use Params::Util qw(_CODE _ARRAY); my ( $required, $recommended ) = prove_reqs( { default_recommended(), ( MLDBM => 0 ) } ); show_reqs( $required, $recommended ); my @test_dbds = ( 'SQL::Statement', grep { /^dbd:/i } keys %{$recommended} ); my $testdir = test_dir(); my @massValues = map { [ $_, ( "a" .. "f" )[ int rand 6 ], int rand 10 ] } ( 1 .. 3999 ); SKIP: foreach my $test_dbd (@test_dbds) { my $dbh; note("Running tests for $test_dbd"); my $temp = ""; # XXX # my $test_dbd_tbl = "${test_dbd}::Table"; # $test_dbd_tbl->can("fetch") or $temp = "$temp"; $test_dbd eq "DBD::File" and $temp = "TEMP"; $test_dbd eq "SQL::Statement" and $temp = "TEMP"; my %extra_args; if ( $test_dbd eq "DBD::DBM" ) { if ( $recommended->{MLDBM} ) { $extra_args{dbm_mldbm} = "Storable"; } else { skip( 'DBD::DBM test runs without MLDBM', 1 ); } } $dbh = connect( $test_dbd, { PrintError => 0, RaiseError => 0, f_dir => $testdir, %extra_args, } ); my ( $sth, $str ); my $now = time(); my @timelist; for my $hour ( 1 .. 10 ) { push( @timelist, $now - ( $hour * 3600 ) ); } for my $sql ( split /\n/, <<"" CREATE $temp TABLE Prof (pname CHAR, pid INT) INSERT INTO Prof VALUES ('Sue', 1) INSERT INTO Prof VALUES ('Bob', 2) INSERT INTO Prof VALUES ('Tom', 3) CREATE $temp TABLE Subject (sname CHAR, pid INT) INSERT INTO Subject VALUES ('Chem', 1) INSERT INTO Subject VALUES ('Bio', 2) INSERT INTO Subject VALUES ('Math', 2) INSERT INTO Subject VALUES ('English', 4) CREATE $temp TABLE Room (rname CHAR, pid INT) INSERT INTO Room VALUES ('1C', 1) INSERT INTO Room VALUES ('2B', 2) CREATE $temp TABLE author (author_name CHAR, author_id INT) INSERT INTO author VALUES ('Neal Stephenson',1) INSERT INTO author VALUES ('Vernor Vinge',2) CREATE $temp TABLE book (book_title CHAR, author_id INT) INSERT INTO book VALUES ('Cryptonomicon',1) INSERT INTO book VALUES ('Dahlgren',3) CREATE $temp TABLE t1 (num INT, name CHAR) INSERT INTO t1 VALUES (1,'a') INSERT INTO t1 VALUES (2,'b') INSERT INTO t1 VALUES (3,'c') CREATE $temp TABLE t2 (num INT, wert CHAR) INSERT INTO t2 VALUES (1,'xxx') INSERT INTO t2 VALUES (3,'yyy') INSERT INTO t2 VALUES (5,'zzz') CREATE $temp TABLE APPL (id INT, applname CHAR, appluniq CHAR, version CHAR, appl_type CHAR) INSERT INTO APPL VALUES ( 1, 'ZQF', 'ZFQLIN', '10.2.0.4', 'Oracle DB') INSERT INTO APPL VALUES ( 2, 'YRA', 'YRA-UX', '10.2.0.2', 'Oracle DB') INSERT INTO APPL VALUES ( 3, 'PRN1', 'PRN1-4.B2', '1.1.22', 'CUPS' ) INSERT INTO APPL VALUES ( 4, 'PRN2', 'PRN2-4.B2', '1.1.22', 'CUPS' ) INSERT INTO APPL VALUES ( 5, 'PRN1', 'PRN1-4.B1', '1.1.22', 'CUPS' ) INSERT INTO APPL VALUES ( 7, 'PRN2', 'PRN2-4.B1', '1.1.22', 'CUPS' ) INSERT INTO APPL VALUES ( 8, 'sql-stmt', 'SQL::Statement', '1.21', 'Project Web-Site') INSERT INTO APPL VALUES ( 9, 'cpan.org', 'http://www.cpan.org/', '1.0', 'Web-Site') INSERT INTO APPL VALUES (10, 'httpd', 'cpan-apache', '2.2.13', 'Web-Server') INSERT INTO APPL VALUES (11, 'cpan-mods', 'cpan-mods', '8.4.1', 'PostgreSQL DB') INSERT INTO APPL VALUES (12, 'cpan-authors', 'cpan-authors', '8.4.1', 'PostgreSQL DB') CREATE $temp TABLE NODE (id INT, nodename CHAR, os CHAR, version CHAR) INSERT INTO NODE VALUES ( 1, 'ernie', 'RHEL', '5.2') INSERT INTO NODE VALUES ( 2, 'bert', 'RHEL', '5.2') INSERT INTO NODE VALUES ( 3, 'statler', 'FreeBSD', '7.2') INSERT INTO NODE VALUES ( 4, 'waldorf', 'FreeBSD', '7.2') INSERT INTO NODE VALUES ( 5, 'piggy', 'NetBSD', '5.0.2') INSERT INTO NODE VALUES ( 6, 'kermit', 'NetBSD', '5.0.2') INSERT INTO NODE VALUES ( 7, 'samson', 'NetBSD', '5.0.2') INSERT INTO NODE VALUES ( 8, 'tiffy', 'NetBSD', '5.0.2') INSERT INTO NODE VALUES ( 9, 'rowlf', 'Debian Lenny', '5.0') INSERT INTO NODE VALUES (10, 'fozzy', 'Debian Lenny', '5.0') CREATE $temp TABLE PREC (id INT, appl_id INT, node_id INT, precedence INT) INSERT INTO PREC VALUES ( 1, 1, 1, 1) INSERT INTO PREC VALUES ( 2, 1, 2, 2) INSERT INTO PREC VALUES ( 3, 2, 2, 1) INSERT INTO PREC VALUES ( 4, 2, 1, 2) INSERT INTO PREC VALUES ( 5, 3, 5, 1) INSERT INTO PREC VALUES ( 6, 3, 7, 2) INSERT INTO PREC VALUES ( 7, 4, 6, 1) INSERT INTO PREC VALUES ( 8, 4, 8, 2) INSERT INTO PREC VALUES ( 9, 5, 7, 1) INSERT INTO PREC VALUES (10, 5, 5, 2) INSERT INTO PREC VALUES (11, 6, 8, 1) INSERT INTO PREC VALUES (12, 7, 6, 2) INSERT INTO PREC VALUES (13, 10, 9, 1) INSERT INTO PREC VALUES (14, 10, 10, 1) INSERT INTO PREC VALUES (15, 8, 9, 1) INSERT INTO PREC VALUES (16, 8, 10, 1) INSERT INTO PREC VALUES (17, 9, 9, 1) INSERT INTO PREC VALUES (18, 9, 10, 1) INSERT INTO PREC VALUES (19, 11, 3, 1) INSERT INTO PREC VALUES (20, 11, 4, 2) INSERT INTO PREC VALUES (21, 12, 4, 1) INSERT INTO PREC VALUES (22, 12, 3, 2) CREATE $temp TABLE LANDSCAPE (id INT, landscapename CHAR) INSERT INTO LANDSCAPE VALUES (1, 'Logistic') INSERT INTO LANDSCAPE VALUES (2, 'Infrastructure') INSERT INTO LANDSCAPE VALUES (3, 'CPAN') CREATE $temp TABLE CONTACT (id INT, surname CHAR, familyname CHAR, phone CHAR, userid CHAR, mailaddr CHAR) INSERT INTO CONTACT VALUES ( 1, 'Hans Peter', 'Mueller', '12345', 'HPMUE', 'hp-mueller\@here.com') INSERT INTO CONTACT VALUES ( 2, 'Knut', 'Inge', '54321', 'KINGE', 'k-inge\@here.com') INSERT INTO CONTACT VALUES ( 3, 'Lola', 'Nguyen', '+1-123-45678-90', 'LNYUG', 'lola.ngyuen\@customer.com') INSERT INTO CONTACT VALUES ( 4, 'Helge', 'Brunft', '+41-123-45678-09', 'HBRUN', 'helge.brunft\@external-dc.at') -- TYPE: 1: APPL 2: NODE 3: CONTACT CREATE $temp TABLE NM_LANDSCAPE (id INT, ls_id INT, obj_id INT, obj_type INT) INSERT INTO NM_LANDSCAPE VALUES ( 1, 1, 1, 2) INSERT INTO NM_LANDSCAPE VALUES ( 2, 1, 2, 2) INSERT INTO NM_LANDSCAPE VALUES ( 3, 3, 3, 2) INSERT INTO NM_LANDSCAPE VALUES ( 4, 3, 4, 2) INSERT INTO NM_LANDSCAPE VALUES ( 5, 2, 5, 2) INSERT INTO NM_LANDSCAPE VALUES ( 6, 2, 6, 2) INSERT INTO NM_LANDSCAPE VALUES ( 7, 2, 7, 2) INSERT INTO NM_LANDSCAPE VALUES ( 8, 2, 8, 2) INSERT INTO NM_LANDSCAPE VALUES ( 9, 3, 9, 2) INSERT INTO NM_LANDSCAPE VALUES (10, 3,10, 2) INSERT INTO NM_LANDSCAPE VALUES (11, 1, 1, 1) INSERT INTO NM_LANDSCAPE VALUES (12, 2, 2, 1) INSERT INTO NM_LANDSCAPE VALUES (13, 2, 2, 3) INSERT INTO NM_LANDSCAPE VALUES (14, 3, 1, 3) CREATE $temp TABLE APPL_CONTACT (id INT, contact_id INT, appl_id INT, contact_type CHAR) INSERT INTO APPL_CONTACT VALUES (1, 3, 1, 'OWNER') INSERT INTO APPL_CONTACT VALUES (2, 3, 2, 'OWNER') INSERT INTO APPL_CONTACT VALUES (3, 4, 3, 'ADMIN') INSERT INTO APPL_CONTACT VALUES (4, 4, 4, 'ADMIN') INSERT INTO APPL_CONTACT VALUES (5, 4, 5, 'ADMIN') INSERT INTO APPL_CONTACT VALUES (6, 4, 6, 'ADMIN') ) { $sql =~ m/^\s*--/ and next; ok( $sth = $dbh->prepare($sql), "prepare $sql on $test_dbd" ) or diag( $dbh->errstr() ); ok( $sth->execute(), "execute $sql on $test_dbd" ) or diag( $sth->errstr() ); } my @tests = ( { test => 'NATURAL JOIN - with named columns in select list', sql => "SELECT pname,sname FROM Prof NATURAL JOIN Subject", result => [ [qw(Sue Chem)], [qw(Bob Bio)], [qw(Bob Math)], ], }, { test => 'NATURAL JOIN - with select list = *', sql => "SELECT * FROM Prof NATURAL JOIN Subject", result => [ [qw(Sue 1 Chem)], [qw(Bob 2 Bio)], [qw(Bob 2 Math)], ], }, { test => 'NATURAL JOIN - with computed columns', sql => "SELECT UPPER(pname) AS P,Prof.pid,pname,sname FROM Prof NATURAL JOIN Subject", result => [ [qw(SUE 1 Sue Chem)], [qw(BOB 2 Bob Bio)], [qw(BOB 2 Bob Math)], ], }, { test => 'NATURAL JOIN - with no specifier on join column', sql => "SELECT UPPER(pname) AS P,pid,pname,sname FROM Prof NATURAL JOIN Subject", result => [ [qw(SUE 1 Sue Chem)], [qw(BOB 2 Bob Bio)], [qw(BOB 2 Bob Math)], ], }, { test => 'INNER JOIN - with no specifier on join column', sql => "SELECT UPPER(pname) AS P,pid,pname,sname FROM Prof JOIN Subject using (pid)", result => [ [qw(SUE 1 Sue Chem)], [qw(BOB 2 Bob Bio)], [qw(BOB 2 Bob Math)], ], }, { test => 'LEFT JOIN', sql => "SELECT * FROM Prof LEFT JOIN Subject USING(pid)", result => [ [qw(Sue 1 Chem)], [qw(Bob 2 Bio)], [qw(Bob 2 Math)], [ 'Tom', 3, undef ], ], }, { test => 'LEFT JOIN - enumerated columns', sql => "SELECT pid,pname,sname FROM Prof LEFT JOIN Subject USING(pid)", result => [ [qw(1 Sue Chem)], [qw(2 Bob Bio)], [qw(2 Bob Math)], [ 3, 'Tom', undef ], ], }, { test => 'LEFT JOIN - perversely intentionally mis-enumerated columns', sql => "SELECT subject.pid,pname,sname FROM Prof LEFT JOIN Subject USING(pid)", result => [ [qw(1 Sue Chem)], [qw(2 Bob Bio)], [qw(2 Bob Math)], [ undef, 'Tom', undef ], ], }, { test => 'LEFT JOIN - lower case keywords', sql => "SELECT subject.pid, pname, sname FROM prof LEFT JOIN subject USING(pid)", result => [ [qw(1 Sue Chem)], [qw(2 Bob Bio)], [qw(2 Bob Math)], [ undef, 'Tom', undef ], ], }, { test => 'RIGHT JOIN', sql => "SELECT * FROM Prof RIGHT JOIN Subject USING(pid)", result => [ [qw(Sue 1 Chem)], [qw(Bob 2 Bio)], [qw(Bob 2 Math)], [ undef, undef, 'English' ], ], }, { test => 'RIGHT JOIN - enumerated columns', sql => "SELECT pid,sname,pname FROM Prof RIGHT JOIN Subject USING(pid)", result => [ [qw(1 Chem Sue)], [qw(2 Bio Bob)], [qw(2 Math Bob)], [ undef, 'English', undef ], ], }, { test => 'FULL JOIN', sql => "SELECT * FROM Prof FULL JOIN Subject USING(pid)", result => [ [qw(Sue 1 Chem)], [qw(Bob 2 Bio)], [qw(Bob 2 Math)], [ 'Tom', 3, undef ], [ undef, 4, 'English' ], ], }, { test => 'IMPLICIT JOIN - two tables', sql => "SELECT * FROM Prof AS P,Subject AS S WHERE P.pid=S.pid", result => [ [qw(Sue 1 Chem 1)], [qw(Bob 2 Bio 2)], [qw(Bob 2 Math 2)], ], }, { test => 'IMPLICIT JOIN - three tables', sql => "SELECT * FROM Prof AS P,Subject AS S,Room AS R WHERE P.pid=S.pid AND P.pid=R.pid", result => [ [qw(Sue 1 Chem 1 1C 1)], [qw(Bob 2 Bio 2 2B 2)], [qw(Bob 2 Math 2 2B 2)], ], }, { test => 'NATURAL JOIN - on unique id\'s with select list = *', sql => "SELECT * FROM author NATURAL JOIN book", result_cols => [qw(author_name author_id book_title)], result => [ [ 'Neal Stephenson', '1', 'Cryptonomicon' ], ], }, { test => 'CROSS JOIN with select list = *', sql => "SELECT * FROM t1 CROSS JOIN t2", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 1, 'a', 3, 'yyy' ], [ 1, 'a', 5, 'zzz' ], [ 2, 'b', 1, 'xxx' ], [ 2, 'b', 3, 'yyy' ], [ 2, 'b', 5, 'zzz' ], [ 3, 'c', 1, 'xxx' ], [ 3, 'c', 3, 'yyy' ], [ 3, 'c', 5, 'zzz' ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 1 | a | 3 | yyy 1 | a | 5 | zzz 2 | b | 1 | xxx 2 | b | 3 | yyy 2 | b | 5 | zzz 3 | c | 1 | xxx 3 | c | 3 | yyy 3 | c | 5 | zzz } }, { test => 'INNER JOIN with select list = *', sql => "SELECT * FROM t1 INNER JOIN t2 ON t1.num = t2.num", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 3, 'c', 3, 'yyy' ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 1 | a | 3 | yyy } }, { test => 'INNER JOINS (USING) with select list = *', sql => "SELECT * FROM t1 INNER JOIN t2 USING (num)", result_cols => [qw(num name wert)], result => [ [ 1, 'a', 'xxx' ], [ 3, 'c', 'yyy' ], ], comment => q{ num | name | wert -----+------+------ 1 | a | xxx 3 | c | yyy }, }, { test => 'INNER JOINS (NATURAL) with select list = *', sql => "SELECT * FROM t1 NATURAL INNER JOIN t2", result_cols => [qw(num name wert)], result => [ [ 1, 'a', 'xxx' ], [ 3, 'c', 'yyy' ], ], comment => q{ num | name | wert -----+------+------ 1 | a | xxx 3 | c | yyy }, }, { test => 'LEFT JOINS (using ON condition) with select list = *', sql => "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 2, 'b', undef, undef ], [ 3, 'c', 3, 'yyy' ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 2 | b | | 3 | c | 3 | yyy }, }, { test => 'LEFT JOINS (USING (num) condition) with select list = *', sql => "SELECT * FROM t1 LEFT JOIN t2 USING (num)", result_cols => [qw(num name wert)], result => [ [ 1, 'a', 'xxx' ], [ 2, 'b', undef ], [ 3, 'c', 'yyy' ], ], comment => q{ num | name | wert -----+------+------ 1 | a | xxx 2 | b | 3 | c | yyy }, }, { test => 'Right Joins (using ON condition) with select list = *', sql => "SELECT * FROM t1 RIGHT JOIN t2 ON t1.num = t2.num", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 3, 'c', 3, 'yyy' ], [ undef, undef, 5, 'zzz' ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 3 | c | 3 | yyy | | 5 | zzz }, }, { test => 'Left Joins (reverse former Right Join) with select list = *', sql => "SELECT * FROM t2 LEFT JOIN t1 ON t1.num = t2.num", result_cols => [qw(num wert num name)], result => [ [ 1, 'xxx', 1, 'a' ], [ 3, 'yyy', 3, 'c' ], [ 5, 'zzz', undef, undef ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 3 | c | 3 | yyy | | 5 | zzz }, }, { test => 'Full Joins (using ON condition) with select list = *', sql => "SELECT * FROM t1 FULL JOIN t2 ON t1.num = t2.num", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 2, 'b', undef, undef ], [ 3, 'c', 3, 'yyy' ], [ undef, undef, 5, 'zzz' ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 2 | b | | 3 | c | 3 | yyy | | 5 | zzz }, }, { test => 'Left Joins (using ON t1.num = t2.num AND t2.wert = "xxx") with select list = *', sql => "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num AND t2.wert = 'xxx'", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 2, 'b', undef, undef ], [ 3, 'c', undef, undef ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 2 | b | | 3 | c | | }, todo => 'Analyze', }, { test => 'Left Joins (using ON t1.num = t2.num WHERE (t2.wert = "xxx" OR t2.wert IS NULL)) with select list = *', sql => "SELECT * FROM t1 LEFT JOIN t2 ON t1.num = t2.num WHERE (t2.wert = 'xxx' OR t2.wert IS NULL)", result_cols => [qw(num name num wert)], result => [ [ 1, 'a', 1, 'xxx' ], [ 2, 'b', undef, undef ], [ 3, 'c', undef, undef ], ], comment => q{ num | name | num | wert -----+------+-----+------ 1 | a | 1 | xxx 2 | b | | 3 | c | | }, todo => 'Analyze', }, { test => "DEFAULT INNER (1) with named columns", sql => q{SELECT applname, appluniq, version, nodename FROM APPL, PREC, NODE WHERE appl_type LIKE '%DB' AND APPL.id=PREC.appl_id AND PREC.node_id=NODE.id}, result => [ [ 'ZQF', 'ZFQLIN', '10.2.0.4', 'ernie', ], [ 'ZQF', 'ZFQLIN', '10.2.0.4', 'bert', ], [ 'YRA', 'YRA-UX', '10.2.0.2', 'bert', ], [ 'YRA', 'YRA-UX', '10.2.0.2', 'ernie', ], [ 'cpan-mods', 'cpan-mods', '8.4.1', 'statler', ], [ 'cpan-mods', 'cpan-mods', '8.4.1', 'waldorf', ], [ 'cpan-authors', 'cpan-authors', '8.4.1', 'waldorf', ], [ 'cpan-authors', 'cpan-authors', '8.4.1', 'statler', ], ], }, { test => "DEFAULT INNER (2) with named columns", sql => q{SELECT applname, appluniq, version, landscapename, nodename FROM APPL, PREC, NODE, LANDSCAPE, NM_LANDSCAPE WHERE appl_type LIKE '%DB' AND APPL.id=PREC.appl_id AND PREC.node_id=NODE.id AND NM_LANDSCAPE.obj_id=APPL.id AND NM_LANDSCAPE.obj_type=1 AND NM_LANDSCAPE.ls_id=LANDSCAPE.id}, result => [ [ 'ZQF', 'ZFQLIN', '10.2.0.4', 'Logistic', 'ernie', ], [ 'ZQF', 'ZFQLIN', '10.2.0.4', 'Logistic', 'bert', ], [ 'YRA', 'YRA-UX', '10.2.0.2', 'Infrastructure', 'bert', ], [ 'YRA', 'YRA-UX', '10.2.0.2', 'Infrastructure', 'ernie', ], ], }, { test => "DEFAULT INNER (3) with named columns", sql => q{SELECT applname, appluniq, version, surname, familyname, phone, nodename FROM APPL, PREC, NODE, CONTACT, APPL_CONTACT WHERE appl_type='CUPS' AND APPL.id=PREC.appl_id AND PREC.node_id=NODE.id AND APPL_CONTACT.appl_id=APPL.id AND APPL_CONTACT.contact_id=CONTACT.id AND PREC.PRECEDENCE=1 ORDER BY appluniq DESC, applname ASC}, result => [ [ 'PRN2', 'PRN2-4.B2', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'kermit', ], [ 'PRN1', 'PRN1-4.B2', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'piggy', ], [ 'PRN1', 'PRN1-4.B1', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'samson', ], ], }, { test => "DEFAULT INNER (4) with named columns", sql => q{SELECT DISTINCT applname, appluniq, version, surname, familyname, phone, nodename FROM APPL, PREC, NODE, CONTACT, APPL_CONTACT WHERE appl_type='CUPS' AND APPL.id=PREC.appl_id AND PREC.node_id=NODE.id AND APPL_CONTACT.appl_id=APPL.id AND APPL_CONTACT.contact_id=CONTACT.id ORDER BY applname, appluniq, nodename}, result => [ [ 'PRN1', 'PRN1-4.B1', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'piggy', ], [ 'PRN1', 'PRN1-4.B1', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'samson', ], [ 'PRN1', 'PRN1-4.B2', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'piggy', ], [ 'PRN1', 'PRN1-4.B2', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'samson', ], [ 'PRN2', 'PRN2-4.B2', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'kermit', ], [ 'PRN2', 'PRN2-4.B2', '1.1.22', 'Helge', 'Brunft', '+41-123-45678-09', 'tiffy', ], ], }, { test => "DEFAULT INNER (5) with named columns", sql => q{SELECT CONCAT('[% NOW %]') AS "timestamp", applname, appluniq, version, nodename FROM APPL, PREC, NODE WHERE appl_type LIKE '%DB' AND APPL.id=PREC.appl_id AND PREC.node_id=NODE.id}, result => [ [ '[% NOW %]', 'ZQF', 'ZFQLIN', '10.2.0.4', 'ernie', ], [ '[% NOW %]', 'ZQF', 'ZFQLIN', '10.2.0.4', 'bert', ], [ '[% NOW %]', 'YRA', 'YRA-UX', '10.2.0.2', 'bert', ], [ '[% NOW %]', 'YRA', 'YRA-UX', '10.2.0.2', 'ernie', ], [ '[% NOW %]', 'cpan-mods', 'cpan-mods', '8.4.1', 'statler', ], [ '[% NOW %]', 'cpan-mods', 'cpan-mods', '8.4.1', 'waldorf', ], [ '[% NOW %]', 'cpan-authors', 'cpan-authors', '8.4.1', 'waldorf', ], [ '[% NOW %]', 'cpan-authors', 'cpan-authors', '8.4.1', 'statler', ], ], }, { test => "Complex INNER JOIN", sql => q{SELECT pname, sname, rname FROM Prof p JOIN Subject s ON p.pid = s.pid JOIN Room r ON p.pid = r.pid }, result => [ [qw(Sue Chem 1C)], [qw(Bob Bio 2B)], [qw(Bob Math 2B)] ], todo => 'Not supported yet!', execute_err => qr/No such column 'rname'/, }, { test => "Complex INNER JOIN (using)", sql => q{SELECT pname, sname, rname FROM Prof p JOIN Subject s USING (pid) JOIN Room r USING (pid) }, result => [ [qw(Sue Chem 1C)], [qw(Bob Bio 2B)], [qw(Bob Math 2B)] ], todo => 'Not supported yet!', prepare_err => qr/Can't find table names in FROM clause/, }, { test => "Complex NATURAL JOIN", sql => q{SELECT pname, sname, rname FROM Prof NATURAL JOIN Subject NATURAL JOIN Room }, result => [ [qw(Sue Chem 1C)], [qw(Bob Bio 2B)], [qw(Bob Math 2B)] ], todo => 'Not supported yet!', prepare_err => qr/Can't find table names in FROM clause/, }, { test => "Complex LEFT JOIN", sql => q{SELECT pname, sname, rname FROM Prof p LEFT JOIN Subject s ON p.pid = s.pid LEFT JOIN Room r ON p.pid = r.pid }, result => [ [qw(Sue Chem 1C)], [qw(Bob Bio 2B)], [qw(Bob Math 2B)], ['Tom', undef, undef] ], todo => 'Not supported yet!', execute_err => qr/No such column 'rname'/, }, ); foreach my $test (@tests) { $test->{test} or next; local $TODO; if ( $test->{todo} ) { note("break here"); } defined( $test->{todo} ) and $TODO = $test->{todo}; if ( defined( $test->{prepare_err} ) ) { $sth = $dbh->prepare( $test->{sql} ); ok( !$sth, "prepare $test->{sql} using $test_dbd fails" ); like( $dbh->errstr(), $test->{prepare_err}, $test->{test} ); next; } $sth = $dbh->prepare( $test->{sql} ); ok( $sth, "prepare $test->{sql} using $test_dbd" ) or diag( $dbh->errstr() ); $sth or next; if ( defined( $test->{params} ) ) { my $params; if ( defined( _CODE( $test->{params} ) ) ) { $params = [ &{ $test->{params} } ]; } elsif ( !defined( _ARRAY( $test->{params}->[0] ) ) ) { $params = [ $test->{params} ]; } else { $params = $test->{params}; } my $i = 0; my @failed; foreach my $bp ( @{ $test->{params} } ) { ++$i; my $n = $sth->execute(@$bp); $n or ok( $n, "$i: execute $test->{sql} using $test_dbd (" . DBI::neat_list($bp) . ")" ) or diag( $dbh->errstr() ) or push( @failed, $bp ); # 'SELECT' eq $sth->command() or next; # could become funny ... } @failed or ok( 1, "1 .. $i: execute $test->{sql} using $test_dbd" ); } else { my $n = $sth->execute(); if ( defined( $test->{execute_err} ) ) { ok( !$n, "execute $test->{sql} using $test_dbd fails" ); like( $dbh->errstr(), $test->{execute_err}, $test->{test} ); next; } ok( $n, "execute $test->{sql} using $test_dbd" ) or diag( $dbh->errstr() ); 'SELECT' eq $sth->command() or next; if ( $test->{result_cols} ) { is_deeply( $sth->col_names(), $test->{result_cols}, "Columns in $test->{test}" ); } if ( $test->{fetch_by} ) { my $got_result = $sth->fetchall_hashref( $test->{fetch_by} ); is_deeply( $got_result, $test->{result}, $test->{test} ); } elsif ( $test->{result_code} ) { &{ $test->{result_code} }($sth); } else { my $got_result = $sth->fetch_rows(); is_deeply( $got_result, $test->{result}, $test->{test} ); } } } } done_testing(); SQL-Statement-1.407/t/09ops.t000644 000765 000024 00000005706 12160006754 015503 0ustar00snostaff000000 000000 #!/usr/bin/perl -w $|=1; use strict; #use lib qw( ../lib ); use vars qw($DEBUG); use Data::Dumper; use Test::More tests => 18; use SQL::Statement; use SQL::Parser; printf "SQL::Statement v.%s\n", $SQL::Statement::VERSION; my($stmt,$cache)=(undef,{}); my $p = SQL::Parser->new(); $p->{RaiseError}=1; $p->{PrintError}=0; $DEBUG=0; if ($DEBUG) { parse('SELECT * FROM x WHERE y newopfunc z'); parse('CREATE FUNCTION newopfunc'); parse('SELECT * FROM x WHERE y newopfunc z'); my $s = SQL::Statement->new('CREATE OPERATOR foo',$p); $s = SQL::Statement->new('SELECT * FROM x WHERE y foo z',$p); exit; } # fail on unknown TYPE, create the type, succeed # #diag('TYPE'); ok(!parse('CREATE TABLE x (id NEWTYPE)'),'unknwon type'); ok(parse('CREATE TYPE newtype'),'create type'); ok(parse('CREATE TABLE x (id NEWTYPE)'),'user-defined type'); # succeed on known TYPE, drop the type, fail # ok(parse('CREATE TABLE x (id INT)'),'known type'); ok(parse('DROP TYPE int'),'drop type'); ok(!parse('CREATE TABLE x (id INT)'),'unknown type'); parse('CREATE TYPE INT'); # put it back :-) #diag('KEYWORD'); # succeed on unknown KEYWORD, create the keyword, fail # ok(parse('SELECT * FROM newkeyword'),'unknown keyword'); ok(parse('CREATE KEYWORD newkeyword'),'create keyword'); ok(!parse('SELECT * FROM newkeyword'),'user-defined keyword'); # fail on known KEYWORD, drop the keyword, succeed # ok(!parse('SELECT * FROM table'),'known keyword'); ok(parse('DROP KEYWORD table'),'drop keyword'); ok(parse('SELECT * FROM table'),'keyword as identifier'); #diag('OPERATOR'); # fail on unknown OP, create the op, succeed # ok(!parse('SELECT * FROM x WHERE y newop z'),'unknown operator'); ok(parse('CREATE OPERATOR newop'),'create operator'); ok(parse('SELECT * FROM x WHERE y newop z'),'user-defined operator'); #do_('CREATE TABLE x (id INT)'); #do_("INSERT INTO x VALUES($_)") for 0..7; ##ok( '0^1^2^' eq fetchStr("SELECT * FROM x WHERE id < 3"), '; #ok( '0^1^2^' eq fetchStr("SELECT * FROM x WHERE id newop 3"), 'exec operator'); # succeed on known OP, drop the op, fail # ok(parse('SELECT * FROM x WHERE y LIKE z'),'known operator'); ok(parse("DROP OPERATOR 'LIKE'"),'drop operator'); ok(!parse('SELECT * FROM x WHERE y LIKE z'),'unkown operator'); parse('CREATE OPERATOR LIKE'); # put it back :-) sub parse { my($sql)=@_; eval { $stmt = SQL::Statement->new($sql,$p) }; warn $@ if $@ and $DEBUG; return ($@) ? 0 : 1; } sub do_ { my($sql,@params)=@_; @params = () unless @params; $stmt = SQL::Statement->new($sql,$p); eval { $stmt->execute($cache,@params) }; return ($@) ? 0 : 1; } sub fetchStr { my($sql,@params)=@_; do_($sql,@params); my $str=''; while (my $r=$stmt->fetch) { $str .= sprintf "%s^",join'~',@$r; } return $str; } sub newop { my ( $self, $owner, $left, $right ) = @_; return $left < $right; } __END__ "a disjunction of conjunctions of literals, where each literal is an elementary relational formula or its negation" SQL-Statement-1.407/t/10limit.t000644 000765 000024 00000002173 12160006754 016003 0ustar00snostaff000000 000000 #!/usr/bin/perl -w $|=1; use strict; #use lib qw( ../lib ); use vars qw($DEBUG); use Data::Dumper; use Test::More tests => 2; use SQL::Statement; printf "SQL::Statement v.%s\n", $SQL::Statement::VERSION; $DEBUG=0; my $p = SQL::Parser->new(); my($stmt,$cache)=(undef,{}); do_(" CREATE TEMP TABLE tbl (c1 INT) "); do_(" INSERT INTO tbl VALUES($_) ") for 0..9; # MySQL LIMIT is 0-based! ok( '5^6^7^' eq fetchStr("SELECT * FROM tbl ORDER BY c1 LIMIT 5,3") , 'limit with order by'); ok( '5^6^7^' eq fetchStr("SELECT * FROM tbl LIMIT 5,3") , 'limit without order by'); sub parse { my($sql)=@_; eval { $stmt = SQL::Statement->new($sql,$p) }; warn $@ if $@ and $DEBUG; return ($@) ? 0 : 1; } sub do_ { my($sql,@params)=@_; @params = () unless @params; $stmt = SQL::Statement->new($sql,$p); eval { $stmt->execute($cache,@params) }; return ($@) ? 0 : 1; } sub fetchStr { my($sql,@params)=@_; do_($sql,@params); my $str=''; while (my $r=$stmt->fetch) { $str .= sprintf "%s^",join'~',@$r; } return $str; } __DATA__ SELECT a FROM b JOIN c WHERE c=? AND e=7 ORDER BY f DESC LIMIT 5,2 SQL-Statement-1.407/t/12eval.t000644 000765 000024 00000003055 12160006754 015616 0ustar00snostaff000000 000000 #!/usr/bin/perl -w $| = 1; use strict; use Test::More tests => 13; use lib qw' ./ ./t '; use SQLtest; my $table = SQL::Eval::Table->new( { col_names => [qw(c1 c2 c3)], col_nums => { c1 => 0, c2 => 1, c3 => 2 }, row => [ 1, 2, 3 ], } ); ok( 3 == scalar @{ $table->row() }, 'eval row()' ); ok( 2 == $table->column('c2'), 'eval column()' ); my $eval = SQL::Eval->new( {} ); ok( $eval->params( [ 1, 2, 3 ] ), 'eval params($val)' ); ok( 3 == scalar @{ $eval->params() }, 'eval params()' ); $eval->{tables}->{a} = $table; ok( 3 == $eval->column( 'a', 'c3' ), 'eval column($tbl,$col)' ); my $ram = SQL::Statement::RAM::Table->new( 'dummy', [], [ [] ] ); ok( !eval_seek( $ram, 0, -100 ), 'ram seek(bad whence)' ); $ram->{index} = -100; ok( !eval_seek( $ram, 0, 1 ), 'ram seek(bad index)' ); ok( eval_seek( $ram, 0, 2 ), 'ram seek(pos=2)' ); my $func = SQL::Statement::Util::Function->new( 'a', 'b', 'c' ); ok( 'function' eq $func->type, '$function->type' ); ok( 'a' eq $func->name, '$function->name' ); my $col = SQL::Statement::Util::Column->new( 'a', 'b', 'c' ); ok( 'column' eq $col->type, '$column->type' ); eval { $func->validate() }; ok( $@, 'function validate - no sub' ); $func = SQL::Statement::Util::Function->new( 'ok', 'Test::More::ok' ); ok( $func->validate(), 'function validate' ); sub eval_seek { my ( $ram, $pos, $whence ) = @_; eval { $ram->seek( undef, $pos, $whence ) }; # diag $@ if $@; return ($@) ? 0 : 1; } SQL-Statement-1.407/t/14parse.t000644 000765 000024 00000001554 12527533320 016006 0ustar00snostaff000000 000000 #!/usr/bin/perl -w use strict; use warnings; use lib qw(t); use Test::More; use Test::Deep; use SQL::Statement; use SQL::Parser; my($stmt,$cache)=(undef,{}); my $p = SQL::Parser->new(); ok(cmp_parse('SELECT 1', 'SELECT 1'), 'sanity check'); foreach my $op (qw( <> <= >= )) { ok(cmp_parse( "SELECT * FROM x WHERE col1 ${op} col2", "SELECT * FROM x WHERE col1${op}col2" ), "'${op}' without spaces"); } done_testing(); sub cmp_parse { my ($sql_given,$sql_want) = @_; my($stmt_given,$stmt_want); eval { $stmt_given = SQL::Statement->new($sql_given,$p); $stmt_want = SQL::Statement->new($sql_want,$p); }; return 0 if $@; foreach (qw( command columns column_aliases tables )) { return 0 if !eq_deeply($stmt_given->{$_}, $stmt_want->{$_}); } return 1; } SQL-Statement-1.407/t/17quoting.t000644 000765 000024 00000025502 12160006754 016363 0ustar00snostaff000000 000000 #!/usr/bin/perl use warnings; use strict; use Test::More tests => 44; use Data::Dumper; # test 1 BEGIN { use_ok('SQL::Statement'); use_ok('SQL::Parser'); } my $loaded = 1; END { print "not ok 1\n" unless $loaded; } my $stmt; my $cache = {}; my $parser = SQL::Parser->new( 'ANSI', { RaiseError => 0, PrintError => 0 } ); for my $sql ( split( "\n", join( '', <new( $sql, $parser ); ok( $stmt->execute($cache), $sql ); } $stmt = SQL::Statement->new( q{SELECT "TBL WITH SPACES"."COLUMN WITH SPACES" FROM "TBL WITH SPACES" WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "TBL WITH SPACES"."COLUMN WITH SPACES" ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( STDERR Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $stmt = SQL::Statement->new( q{SELECT "COLUMN WITH SPACES" FROM "TBL WITH SPACES" WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "COLUMN WITH SPACES" ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $stmt = SQL::Statement->new( q{SELECT "COLUMN WITH SPACES" AS CWS FROM "TBL WITH SPACES" WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "COLUMN WITH SPACES" AS CWS ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $cache = {}; for my $sql ( split( ';', join( '', <new( $sql, $parser ); ok( $stmt->execute($cache), $sql ); } $stmt = SQL::Statement->new( q{SELECT T1."COLUMN WITH SPACES" FROM T1 WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT T1."COLUMN WITH SPACES" ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( STDERR Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $stmt = SQL::Statement->new( q{SELECT "COLUMN WITH SPACES" FROM T1 WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "COLUMN WITH SPACES" ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $stmt = SQL::Statement->new( q{SELECT "COLUMN WITH SPACES" AS CWS FROM T1 WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "COLUMN WITH SPACES" AS CWS ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $cache = {}; for my $sql ( split( ';', join( '', <new( $sql, $parser ); ok( $stmt->execute($cache), $sql ); } $stmt = SQL::Statement->new( q{SELECT "TBL WITH SPACES".CWS FROM "TBL WITH SPACES" WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "TBL WITH SPACES".CWS ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $stmt = SQL::Statement->new( q{SELECT CWS FROM "TBL WITH SPACES" WHERE id=1}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT CWS ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { $stmt->execute($cache); my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'foo' eq $row->[0] ), q{got 'foo'} ); } } $cache = {}; for my $sql ( split( ';', join( '', <new( $sql, $parser ); ok( $stmt->execute($cache), $sql ); } $stmt = SQL::Statement->new( q{SELECT CWS FROM T1 WHERE "SET"=0}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT CWS ... WHERE "SET"=0: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 'bar' eq $row->[0] ), q{got 'bar'} ); } } $stmt = SQL::Statement->new( q{SELECT "SET" FROM T1 WHERE CWS='bar'}, $parser ); ok( !defined( $parser->structure()->{errstr} ), q{Parsing SELECT "SET" ...: } . ( $parser->structure()->{errstr} || '' ) ); if ( defined( $parser->structure()->{errstr} ) ) { # print( Dumper( $cache ) ); # print( Dumper( $parser->structure() ) ); SKIP: { skip( "Parsing select statement fails", 2 ); } } else { my $rc = $stmt->execute($cache); ok( $rc == 1, 'SELECTED 1 row' ); my $count = 0; while ( my $row = $stmt->fetch() ) { #print( Dumper( $row ) ); last if ($count); ++$count; ok( ( scalar( @{$row} ) == 1 ) && defined( $row->[0] ) && ( 0 == $row->[0] ), q{got '0' for "SET"} ); } } SQL-Statement-1.407/t/23dialects.t000644 000765 000024 00000002210 12160006754 016451 0ustar00snostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; my $CLASS = "Local::Test::Dialect"; # Test making a dialect { package Local::Test::Dialect; use SQL::Dialects::Role; sub get_config { # There's some deliberate whitespace abuse in here return <get_config_as_hash(), { things => { ELEPHANTS => 1, FEELINGS => 1, STUFF => 1, }, reserved_words => { FOO => 1, BAR => 1, BAZ => 1 } } ); # Test role injection { { package SQL::Dialects::Test::NoRole; sub get_config { return <new(); ok eval { $parser->dialect("Test::NoRole"); 1; } or diag($@); } SQL-Statement-1.407/t/SQLtest.pm000644 000765 000024 00000002276 12160006754 016240 0ustar00snostaff000000 000000 ################ package SQLtest; ################ use strict; use warnings; #use lib qw( ../lib ); use SQL::Statement; printf "SQL::Statement v.%s\n", $SQL::Statement::VERSION; our ( @ISA, @EXPORT, $DEBUG, $parser, $stmt, $cache ); $cache = {}; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(&new_parser &parse &do_ &execute &fetchStr $parser $stmt); sub new_parser { $parser = (@_) ? SQL::Parser->new(@_) : SQL::Parser->new(); } sub parse { my ($sql) = @_; eval { $stmt = SQL::Statement->new( $sql, $parser ) }; warn $@ if $@ and $DEBUG; return ($@) ? 0 : 1; } sub do_ { my ( $sql, @params ) = @_; @params = () unless @params; $stmt = SQL::Statement->new( $sql, $parser ); eval { $stmt->execute( $cache, @params ) }; return ($@) ? 0 : 1; } sub execute { my @params = @_; @params = () unless @params; eval { $stmt->execute( $cache, @params ) }; return ($@) ? 0 : 1; } sub fetchStr { my ( $sql, @params ) = @_; do_( $sql, @params ); my $str = ''; while ( my $r = $stmt->fetch ) { @$r = map { defined $_ ? $_ : '' } @$r; $str .= sprintf "%s^", join '~', @$r; } $str =~ s/\^$//; return $str; } 1; SQL-Statement-1.407/t/TestLib.pm000644 000765 000024 00000024052 12160006754 016243 0ustar00snostaff000000 000000 package TestLib; use strict; use warnings; use vars qw(@ISA @EXPORT @EXPORT_OK); use Exporter; use File::Spec; use Cwd; use File::Path; @ISA = qw(Exporter); @EXPORT_OK = qw(test_dir prove_reqs show_reqs connect default_recommended); my $test_dsn = delete $ENV{DBI_DSN}; my $test_user = delete $ENV{DBI_USER}; my $test_pass = delete $ENV{DBI_PASS}; my $test_dir; END { defined($test_dir) and rmtree $test_dir } sub test_dir { unless ( defined($test_dir) ) { $test_dir = File::Spec->rel2abs( File::Spec->curdir() ); $test_dir = File::Spec->catdir( $test_dir, "test_output_" . $$ ); $test_dir = VMS::Filespec::unixify($test_dir) if ( $^O eq 'VMS' ); rmtree $test_dir; mkpath $test_dir; } return $test_dir; } sub check_mod { my ( $module, $version ) = @_; my $mod_path = $module; $mod_path =~ s|::|/|g; $mod_path .= '.pm'; eval { require $mod_path }; $@ and return ( 0, $@ ); my $mod_ver = $module->VERSION(); $version = eval $version; $mod_ver = eval $mod_ver; $@ and return ( 0, $@ ); $version <= $mod_ver and return ( 1, $mod_ver ); return ( 0, sprintf( "%s->VERSION() of %s doesn't satisfy requirement of %s", $module, $mod_ver, $version ) ); } my %defaultRecommended = ( 'DBI' => '1.616', 'DBD::File' => '0.40', 'DBD::CSV' => '0.30', 'DBD::DBM' => '0.06', # 'DBD::AnyData' => '0.110', ); sub default_recommended { return %defaultRecommended; } sub prove_reqs { my %requirements; my %recommends; { my %req = ( 'SQL::Statement' => '1.32', ); my %missing; while ( my ( $m, $v ) = each %req ) { my ( $ok, $msg ) = check_mod( $m, $v ); $ok and $requirements{$m} = $msg; $ok or $missing{$m} = $msg; } if (%missing) { my $missingMsg = "YOU ARE MISSING REQUIRED MODULES: [ " . join( ", ", keys %missing ) . " ]:\n" . join( "\n", values(%missing) ); if ( $INC{'Test/More.pm'} ) { Test::More::BAIL_OUT $missingMsg; } else { print STDERR "\n\n$missingMsg\n\n"; exit 0; } } } { my %req = $_[0] ? %{ $_[0] } : %defaultRecommended; while ( my ( $m, $v ) = each %req ) { my ( $ok, $msg ) = check_mod( $m, $v ); if ( !$ok and $INC{'Test/More.pm'} ) { Test::More::note($msg); } $ok and $recommends{$m} = $msg; } } return ( \%requirements, \%recommends ); } sub show_reqs { my @proved_reqs = @_; my $print; if ( $INC{'Test/More.pm'} ) { require File::Basename; $print = (File::Basename::basename($0) =~ m/00/ ? Test::More->can("diag") : Test::More->can("note")); } else { $print = \*CORE::print; } &$print("# Using required:\n") if ( $proved_reqs[0] ); &$print( "# $_: " . $proved_reqs[0]->{$_} . "\n" ) for sort keys %{ $proved_reqs[0] }; &$print("# Using recommended:\n") if ( $proved_reqs[1] ); &$print( "# $_: " . $proved_reqs[1]->{$_} . "\n" ) for sort keys %{ $proved_reqs[1] }; return; } sub connect { my $type = shift; defined($type) and $type =~ m/^dbi:/i and return TestLib::DBD->new( $type, @_ ); defined($type) and $type =~ s/^dbd::/dbi:/i and return TestLib::DBD->new( "$type:", @_ ); return TestLib::Direct->new(@_); } package TestLib::Direct; use Carp qw(croak); use Params::Util qw(_ARRAY0 _ARRAY _HASH0 _HASH); use Scalar::Util qw(blessed); sub new { my ( $class, $flags ) = @_; $flags ||= {}; my $parser = SQL::Parser->new( 'ANSI', $flags ); my %instance = ( parser => $parser, cache => {}, ); my $self = bless( \%instance, $class ); return $self; } sub parser { return $_[0]->{parser}; } sub command { my $self = $_[0]; return $self->{stmt}->command(); } sub prepare { my ( $self, $sql, $attrs ) = @_; my $stmt = SQL::Statement->new( $sql, $self->{parser} ); $self->{stmt} = $stmt; $self->{stmt}->{errstr} or return $self; return; } sub execute { my $self = shift; my @params = @_; # bind params my @args; $args[0] = defined( _HASH0( $params[0] ) ) && !blessed( $params[0] ) ? shift(@params) : $self->{cache}; $args[1] = \@params; return $self->{stmt}->execute(@args); } sub do { my ( $self, $sql, $attrs, @args ) = @_; return $self->prepare( $sql, $attrs )->execute(@args); } sub col_names { my $self = $_[0]; defined( $self->{stmt}->{NAME} ) and defined( _ARRAY( $self->{stmt}->{NAME} ) ) and return $self->{stmt}->{NAME}; my @col_names = map { $_->{name} || $_->{value} } @{ $self->{stmt}->{column_defs} }; return \@col_names; } sub all_cols { my $self = $_[0]; return $self->{stmt}->{all_cols}; } sub tbl_names { my $self = $_[0]; my @tables = sort map { $_->name() } $self->{stmt}->tables(); return \@tables; } sub columns { my ( $self, @args ) = @_; return $self->{stmt}->columns(@args); } sub tables { my ( $self, @args ) = @_; return $self->{stmt}->tables(@args); } sub row_values { my ( $self, @args ) = @_; return $self->{stmt}->row_values(@args); } sub where_hash { my $self = $_[0]; return $self->{stmt}->where_hash(); } sub where { my $self = $_[0]; return $self->{stmt}->where(); } sub params { my $self = $_[0]; return $self->{stmt}->params(); } sub limit { my $self = $_[0]; return $self->{stmt}->limit(); } sub offset { my $self = $_[0]; return $self->{stmt}->offset(); } sub order { my ( $self, @args ) = @_; return $self->{stmt}->order(@args); } sub selectrow_array { my $self = shift; $self->do(@_); my $result = $self->{stmt}->fetch_row(); return wantarray ? @$result : $result->[0]; } sub fetch_row { my $self = $_[0]; return $self->{stmt}->fetch_row(); } sub fetch_rows { my $self = $_[0]; my $rc = $self->{stmt}->fetch_rows(); return $rc; } # clone DBI function sub fetchall_hashref { my ( $self, $key_field ) = @_; my $i = 0; my $names_hash = { map { $_ => $i++ } @{ $self->{stmt}->{NAME} } }; my @key_fields = ( ref $key_field ) ? @$key_field : ($key_field); my @key_indexes; my $num_of_fields = $self->{stmt}->{'NUM_OF_FIELDS'}; foreach (@key_fields) { my $index = $names_hash->{$_}; # perl index not column $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_ >= 1 && $_ <= $num_of_fields; croak("Field '$_' does not exist (not one of @{[keys %$names_hash]})") unless defined $index; push @key_indexes, $index; } my $rows = {}; my $all_rows = $self->{stmt}->fetch_rows(); my $NAME = $self->{stmt}->{NAME}; foreach my $row ( @{$all_rows} ) { my $ref = $rows; $ref = $ref->{ $row->[$_] } ||= {} for @key_indexes; @{$ref}{@$NAME} = @$row; } return $rows; } sub rows { return $_[0]->{stmt}->{NUM_OF_ROWS}; } sub errstr { defined( $_[0]->{stmt} ) and return $_[0]->{stmt}->errstr(); return $_[0]->{parser}->errstr(); } sub finish { delete $_[0]->{stmt}->{data}; } package TestLib::DBD; sub new { my ( $class, $dsn, $attrs ) = @_; $attrs ||= {}; my $dbh = DBI->connect( $dsn, undef, undef, $attrs ); my %instance = ( dbh => $dbh, ); my $self = bless( \%instance, $class ); return $self; } sub parser { return $_[0]->{dbh}->{sql_parser_object}; } sub command { my $self = $_[0]; return $self->{sth}->{sql_stmt}->command(); } sub prepare { my ( $self, $sql, $attr ) = @_; my $sth = $self->{dbh}->prepare( $sql, $attr ); $self->{sth} = $sth and return $self; return; } sub execute { my $self = shift; return $self->{sth}->execute(@_); } sub do { my ( $self, $sql, $attrs, @args ) = @_; return $self->prepare( $sql, $attrs )->execute(@args); } sub selectrow_array { my $self = shift; $self->do(@_); my $result = $self->{sth}->fetchrow_arrayref(); return wantarray ? @$result : $result->[0]; } sub col_names { my $self = $_[0]; return $self->{sth}->{NAME}; } sub all_cols { my $self = $_[0]; return $self->{sth}->{sql_stmt}->{all_cols}; } sub tbl_names { my $self = $_[0]; my @tables = sort map { $_->name() } $self->{sth}->{sql_stmt}->tables(); return \@tables; } sub columns { my ( $self, @args ) = @_; return $self->{sth}->{sql_stmt}->columns(@args); } sub tables { my ( $self, @args ) = @_; return $self->{sth}->{sql_stmt}->tables(@args); } sub row_values { my ( $self, @args ) = @_; return $self->{sth}->{sql_stmt}->row_values(@args); } sub where_hash { my $self = $_[0]; return $self->{sth}->{sql_stmt}->where_hash(); } sub where { my $self = $_[0]; return $self->{sth}->{sql_stmt}->where(); } sub params { my $self = $_[0]; return $self->{sth}->{sql_stmt}->params(); } sub limit { my $self = $_[0]; return $self->{sth}->{sql_stmt}->limit(); } sub offset { my $self = $_[0]; return $self->{sth}->{sql_stmt}->offset(); } sub order { my ( $self, @args ) = @_; return $self->{sth}->{sql_stmt}->order(@args); } sub fetch_row { my $self = $_[0]; return $self->{sth}->fetch(); } sub fetch_rows { my $self = $_[0]; return $self->{sth}->fetchall_arrayref(); } sub fetchall_hashref { my $self = shift; return $self->{sth}->fetchall_hashref(@_); } sub rows { return $_[0]->{sth}->rows(); } sub errstr { defined( $_[0]->{sth} ) and return $_[0]->{sth}->errstr(); return $_[0]->{dbh}->errstr(); } sub finish { $_[0]->{sth}->finish(); } 1; SQL-Statement-1.407/lib/SQL/000755 000765 000024 00000000000 12531016333 015272 5ustar00snostaff000000 000000 SQL-Statement-1.407/lib/SQL/Dialects/000755 000765 000024 00000000000 12531016333 017022 5ustar00snostaff000000 000000 SQL-Statement-1.407/lib/SQL/Eval.pm000755 000765 000024 00000037570 12531013462 016536 0ustar00snostaff000000 000000 # -*- perl -*- package SQL::Eval; require 5.008; use strict; use warnings FATAL => "all"; use vars qw($VERSION); $VERSION = '1.407'; use Carp qw(croak); sub new($) { my ( $proto, $attr ) = @_; my ($self) = {%$attr}; bless( $self, ( ref($proto) || $proto ) ); } sub param($;$) { $_[1] < 0 and croak "Illegal parameter number: $_[1]"; @_ == 3 and return $_[0]->{params}->[ $_[1] ] = $_[2]; $_[0]->{params}->[ $_[1] ]; } sub params(;$) { @_ == 2 and return $_[0]->{params} = $_[1]; $_[0]->{params}; } sub table($) { $_[0]->{tables}->{ $_[1] } } sub column($$) { $_[0]->table( $_[1] )->column( $_[2] ) } sub _gen_access_fastpath($) { $_[0]->table( $_[1] )->_gen_access_fastpath() } package SQL::Eval::Table; use strict; use warnings FATAL => "all"; use Carp qw(croak); use Params::Util qw(_ARRAY0 _HASH0); sub new($) { my ( $proto, $attr ) = @_; my ($self) = {%$attr}; defined( $self->{col_names} ) and defined( _ARRAY0( $self->{col_names} ) ) or croak("attribute 'col_names' must be defined as an array"); exists( $self->{col_nums} ) or $self->{col_nums} = _map_colnums( $self->{col_names} ); defined( $self->{col_nums} ) and defined( _HASH0( $self->{col_nums} ) ) or croak("attribute 'col_nums' must be defined as a hash"); $self->{capabilities} = {} unless ( defined( $self->{capabilities} ) ); bless( $self, ( ref($proto) || $proto ) ); } sub _map_colnums { my $col_names = $_[0]; my %col_nums; $col_nums{ $col_names->[$_] } = $_ for ( 0 .. scalar @$col_names - 1 ); \%col_nums; } sub row() { $_[0]->{row} } sub column($) { $_[0]->{row}->[ $_[0]->column_num( $_[1] ) ] } sub column_num($) { $_[0]->{col_nums}->{ $_[1] }; } sub col_nums() { $_[0]->{col_nums} } sub col_names() { $_[0]->{col_names}; } sub _gen_access_fastpath($) { my ($self) = @_; $self->can("column") == SQL::Eval::Table->can("column") && $self->can("column_num") == SQL::Eval::Table->can("column_num") ? sub { $self->{row}->[ $self->{col_nums}->{ $_[0] } ] } : sub { $self->column( $_[0] ) }; } sub capability($) { my ( $self, $capname ) = @_; exists $self->{capabilities}->{$capname} and return $self->{capabilities}->{$capname}; $capname eq "insert_new_row" and $self->{capabilities}->{insert_new_row} = $self->can("insert_new_row"); $capname eq "delete_one_row" and $self->{capabilities}->{delete_one_row} = $self->can("delete_one_row"); $capname eq "delete_current_row" and $self->{capabilities}->{delete_current_row} = ( $self->can("delete_current_row") and $self->capability("inplace_delete") ); $capname eq "update_one_row" and $self->{capabilities}->{update_one_row} = $self->can("update_one_row"); $capname eq "update_current_row" and $self->{capabilities}->{update_current_row} = ( $self->can("update_current_row") and $self->capability("inplace_update") ); $capname eq "update_specific_row" and $self->{capabilities}->{update_specific_row} = $self->can("update_specific_row"); $capname eq "rowwise_update" and $self->{capabilities}->{rowwise_update} = ( $self->capability("update_one_row") or $self->capability("update_current_row") or $self->capability("update_specific_row") ); $capname eq "rowwise_delete" and $self->{capabilities}->{rowwise_delete} = ( $self->capability("delete_one_row") or $self->capability("delete_current_row") ); $self->{capabilities}->{$capname}; } sub drop ($$) { croak "Abstract method " . ref( $_[0] ) . "::drop called" } sub fetch_row ($$) { croak "Abstract method " . ref( $_[0] ) . "::fetch_row called" } sub push_row ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_row called" } sub push_names ($$$) { croak "Abstract method " . ref( $_[0] ) . "::push_names called" } sub truncate ($$) { croak "Abstract method " . ref( $_[0] ) . "::truncate called" } sub seek ($$$$) { croak "Abstract method " . ref( $_[0] ) . "::seek called" } 1; __END__ =head1 NAME SQL::Eval - Base for deriving evaluation objects for SQL::Statement =head1 SYNOPSIS require SQL::Statement; require SQL::Eval; # Create an SQL statement; use a concrete subclass of # SQL::Statement my $stmt = MyStatement->new("SELECT * FROM foo, bar", SQL::Parser->new('Ansi')); # Get an eval object by calling open_tables; this # will call MyStatement::open_table my $eval = $stmt->open_tables($data); # Set parameter 0 to 'Van Gogh' $eval->param(0, 'Van Gogh'); # Get parameter 2 my $param = $eval->param(2); # Get the SQL::Eval::Table object referring the 'foo' table my $fooTable = $eval->table('foo'); =head1 DESCRIPTION This module implements two classes that can be used for deriving subclasses to evaluate SQL::Statement objects. The SQL::Eval object can be thought as an abstract state engine for executing SQL queries and the SQL::Eval::Table object is a table abstraction. It implements methods for fetching or storing rows, retrieving column names and numbers and so on. See the C script as an example for implementing a subclass. While reading on, keep in mind that these are abstract classes, you *must* implement at least some of the methods described below. In addition, you need not derive from SQL::Eval or SQL::Eval::Table, you just need to implement the method interface. All methods throw a Perl exception in case of errors. =head2 Method interface of SQL::Eval =over 8 =item new Constructor; use it like this: $eval = SQL::Eval->new(\%attr); Blesses the hash ref \%attr into the SQL::Eval class (or a subclass). =item param Used for getting or setting input parameters, as in the SQL query INSERT INTO foo VALUES (?, ?); Example: $eval->param(0, $val); # Set parameter 0 $eval->param(0); # Get parameter 0 =item params Used for getting or setting the complete array of input parameters. Example: $eval->params($params); # Set the array $eval->params(); # Get the array =item table Returns or sets a table object. Example: $eval->table('foo', $fooTable); # Set the 'foo' table object $eval->table('foo'); # Return the 'foo' table object =item column Return the value of a column with a given name; example: $col = $eval->column('foo', 'id'); # Return the 'id' column of # the current row in the # 'foo' table This is equivalent to and a shorthand for $col = $eval->table('foo')->column('id'); =item _gen_access_fastpath Return a subroutine reference for fast accessing columns for read-only access. This routine simply returns the C<_gen_access_fastpath> of the referenced table. =back =head2 Method interface of SQL::Eval::Table =over 8 =item new Constructor; use it like this: $eval = SQL::Eval::Table->new(\%attr); Blesses the hash ref \%attr into the SQL::Eval::Table class (or a subclass). The following attributes are used by C: =over 12 =item col_names Array reference containing the names of the columns in order they appear in the table. This attribute B be provided by the derived class. =item col_nums Hash reference containing the column names as keys and the column indexes as values. If this is omitted (does not exist), it will be created from C. =item capabilities Hash reference containing additional capabilities. =item _gen_access_fastpath Return a subroutine reference for fast accessing columns for read-only access. When the instantiated object doesn't provide own methods for C and C a subroutine reference is returned which directly access the internal data structures. For all other cases a subroutine directly calling C<< $self->column($_[0]) >> is returned. =back =item row Used to get the current row as an array ref. Do not confuse getting the current row with the fetch_row method! In fact this method is valid only after a successful C<$table-Efetchrow()>. Example: $row = $table->row(); =item column Get the column with a given name in the current row. Valid only after a successful C<$table-Efetchrow()>. Example: $col = $table->column($colName); =item column_num Return the number of the given column name. Column numbers start with 0. Returns undef, if a column name is not defined, so that you can use this for verifying column names. Example: $colNum = $table->column_num($colNum); =item col_nums Returns an hash ref of column names with the column names as keys and the column indexes as the values. =item col_names Returns an array ref of column names ordered by their index within the table. =item capability Returns a boolean value whether the table has the specified capability or not. This method might be overridden by derived classes, but ensure that in that case the parent capability method is called when the derived class does not handle the requested capability. The following capabilities are used (and requested) by SQL::Statement: =over 12 =item update_one_row Defines whether the table is able to update one single row. This capability is used for backward compatibility and might have (depending on table implementation) several limitations. Please carefully study the documentation of the table or ask the author of the table, if this information is not provided. This capability is evaluated automatically on first request and must not be handled by any derived classes. =item update_specific_row Defines if the table is able to update one single row, but keeps the original content of the row to update. This capability is evaluated automatically on first request and must not be handled by derived classes. =item update_current_row Defines if the table is able to update the currently touched row. This capability requires the capability of C. This capability is evaluated automatically on first request and must not be handled by derived classes. =item rowwise_update Defines if the table is able to do row-wise updates which means one of C, C or C. The C is only evaluated if the table has the C capability. This capability is evaluated automatically on first request and must not be handled by derived classes. =item inplace_update Defines if an update of a row has side effects (capability is not available) or can be done without harming any other currently running task on the table. Example: The table storage is using a hash on the C of the table. Real perl hashes do not care when an item is updated while the hash is traversed using C. C 1.06 has a bug, which does not adjust the traversal pointer when an item is deleted. C recognizes such situations and adjusts the traversal pointer. This might not be possible for all implementations which can update single rows. This capability could be provided by a derived class only. =item delete_one_row Defines whether the table can delete one single row by it's content or not. This capability is evaluated automatically on first request and must not be handled by derived classes. =item delete_current_row Defines whether a table can delete the current traversed row or not. This capability requires the C capability. This capability is evaluated automatically on first request and must not be handled by derived classes. =item rowwise_delete Defines if any row-wise delete operation is provided by the table. C delete capabilities are C and C. This capability is evaluated automatically on first request and must not be handled by derived classes. =item inplace_delete Defines if the deletion of a row has side effects (capability is not available) or can be done without harming any other currently running task on the table. This capability should be provided by a derived class only. =item insert_new_row Defines if a table can easily insert a new row without need to seek or truncate. This capability is provided by defining the table class method C. This capability is evaluated automatically on first request and must not be handled by derived classes. =back If the capabilities I and I are provided, the table primitive C is not required anymore and may be omitted. =back The above methods are implemented by SQL::Eval::Table. The following methods are not, so that they *must* be implemented by the subclass. See the C or C for example. =over 8 =item drop Drops the table. All resources allocated by the table must be released after C<$table->drop($data)>. =item fetch_row Fetches the next row from the table. Returns C, if the last row was already fetched. The argument $data is for private use of the subclass. Example: $row = $table->fetch_row($data); Note, that you may use $row = $table->row(); for retrieving the same row again, until the next call of C. C requires that the last fetched row is available again and again via C<$table->row()>. =item push_row As fetch_row except for storing rows. Example: $table->push_row($data, $row); =item push_names Used by the I statement to set the column names of the new table. Receives an array ref of names. Example: $table->push_names($data, $names); =item seek Similar to the seek method of a filehandle; used for setting the number of the next row being written. Example: $table->seek($data, $whence, $rowNum); Actually the current implementation only uses C (first row) and C (beyond last row, end of file). =item truncate Truncates a table after the current row. Example: $table->truncate($data); =back =head1 INTERNALS The current implementation is quite simple: An SQL::Eval object is an hash ref with only two attributes. The C attribute is an array ref of parameters. The C attribute is an hash ref of table names (keys) and table objects (values). SQL::Eval::Table instances are implemented as hash refs. Attributes used are C (the array ref of the current row), C (an hash ref of column names as keys and column numbers as values) and C, an array ref of column names with the column numbers as indexes. =head1 MULTITHREADING All methods are working with instance-local data only, thus the module is reentrant and thread safe, if you either don't share handles between threads or grant serialized use. =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you will automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc SQL::Eval perldoc SQL::Statement You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 AUTHOR AND COPYRIGHT Written by Jochen Wiedmann and currently maintained by Jens Rehsack. This module is Copyright (C) 1998 by Jochen Wiedmann Am Eisteich 9 72555 Metzingen Germany Email: joe@ispsoft.de Phone: +49 7123 14887 and Copyright (C) 2009, 2010 by Jens Rehsack < rehsackATcpan.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 =cut SQL-Statement-1.407/lib/SQL/Parser.pm000644 000765 000024 00000311504 12531013463 017071 0ustar00snostaff000000 000000 ###################################################################### package SQL::Parser; ###################################################################### # # This module is copyright (c), 2001,2005 by Jeff Zucker. # This module is copyright (c), 2007-2010 by Jeff Zucker, Jens Rehsack. # All rights reserved. # # It may be freely distributed under the same terms as Perl itself. # See below for help and copyright information (search for SYNOPSIS). # ###################################################################### use strict; use warnings FATAL => "all"; use vars qw($VERSION); use constant FUNCTION_NAMES => join( '|', qw(TRIM SUBSTRING) ); use constant BAREWORD_FUNCTIONS => join( '|', qw(TRIM SUBSTRING CURRENT_DATE CURDATE CURRENT_TIME CURTIME CURRENT_TIMESTAMP NOW UNIX_TIMESTAMP PI DBNAME) ); use Carp qw(carp croak); use Params::Util qw(_ARRAY0 _ARRAY _HASH); use Scalar::Util qw(looks_like_number); use Text::Balanced qw(extract_bracketed); $VERSION = '1.407'; BEGIN { if ( $ENV{SQL_USER_DEFS} ) { require SQL::UserDefs; } } ############################# # PUBLIC METHODS ############################# sub new { my $class = shift; my $dialect = shift || 'ANSI'; $dialect = 'ANSI' if ( uc $dialect eq 'ANSI' ); $dialect = 'AnyData' if ( ( uc $dialect eq 'ANYDATA' ) or ( uc $dialect eq 'CSV' ) ); $dialect = 'AnyData' if ( $dialect eq 'SQL::Eval' ); my $flags = shift || {}; $flags->{dialect} = $dialect; $flags->{PrintError} = 1 unless ( defined( $flags->{PrintError} ) ); my $self = bless( $flags, $class ); $self->dialect( $self->{dialect} ); $self->set_feature_flags( $self->{select}, $self->{create} ); $self->LOAD('LOAD SQL::Statement::Functions'); return $self; } sub parse { my ( $self, $sql ) = @_; $self->dialect( $self->{dialect} ) unless ( $self->{dialect_set} ); $sql =~ s/^\s+//; $sql =~ s/\s+$//; $self->{struct} = { dialect => $self->{dialect} }; $self->{tmp} = {}; $self->{original_string} = $sql; $self->{struct}->{original_string} = $sql; ################################################################ # # COMMENTS # C-STYLE # my $comment_re = $self->{comment_re} || '(\/\*.*?\*\/)'; $self->{comment_re} = $comment_re; my $starts_with_comment; if ( $sql =~ /^\s*$comment_re(.*)$/s ) { $self->{comment} = $1; $sql = $2; $starts_with_comment = 1; } # SQL STYLE # # SQL-style comment can not begin inside quotes. if ( $sql =~ s/^([^']*?(?:'[^']*'[^'])*?)(--.*)(\n|$)/$1$3/ ) { $self->{comment} = $2; } ################################################################ $sql = $self->clean_sql($sql); my ($com) = $sql =~ m/^\s*(\S+)\s+/s; if ( !$com ) { return 1 if ($starts_with_comment); return $self->do_err("Incomplete statement!"); } $com = uc $com; $self->{opts}->{valid_commands}->{CALL} = 1; $self->{opts}->{valid_commands}->{LOAD} = 1; if ( $self->{opts}->{valid_commands}->{$com} ) { my $rv = $self->$com($sql); delete $self->{struct}->{literals}; return $self->do_err("No command found!") unless ( $self->{struct}->{command} ); $self->replace_quoted_ids(); my @tables = @{ $self->{struct}->{table_names} } if ( defined( _ARRAY0( $self->{struct}->{table_names} ) ) ); push( @{ $self->{struct}->{org_table_names} }, @tables ); # REMOVE schema.table info if present @tables = map { s/^.*\.([^\.]+)$/$1/; ( -1 == index( $_, '"' ) ) ? lc $_ : $_ } @tables; if ( exists( $self->{struct}->{join} ) && !defined( _HASH( $self->{struct}->{join} ) ) ) { delete $self->{struct}->{join}; } else { $self->{struct}->{join}->{table_order} = $self->{struct}->{table_names} if ( defined( $self->{struct}->{join}->{table_order} ) && !defined( _ARRAY0( $self->{struct}->{join}->{table_order} ) ) ); @{ $self->{struct}->{join}->{keycols} } = map { lc $_ } @{ $self->{struct}->{join}->{keycols} } if ( $self->{struct}->{join}->{keycols} ); @{ $self->{struct}->{join}->{shared_cols} } = map { lc $_ } @{ $self->{struct}->{join}->{shared_cols} } if ( $self->{struct}->{join}->{shared_cols} ); } if ( defined( $self->{struct}->{column_defs} ) && defined( _ARRAY( $self->{struct}->{column_defs} ) ) ) { my $colname; # FIXME SUBSTR('*') my @fine_defs = grep { defined( $_->{fullorg} ) && ( -1 == index( $_->{fullorg}, '*' ) ) } @{ $self->{struct}->{column_defs} }; foreach my $col (@fine_defs) { my $colname = $col->{fullorg}; #$cn = lc $cn unless ( $cn =~ m/^(?:\w+\.)?"/ ); push( @{ $self->{struct}->{org_col_names} }, $self->{struct}->{ORG_NAME}->{$colname} || $colname ); } unless ( $com eq 'CREATE' ) { $self->{struct}->{table_names} = \@tables; # For RR aliases, added quoted id protection from upper casing foreach my $col (@fine_defs) { # defined( $col->{fullorg} ) && ( -1 == index( $col->{fullorg}, '*' ) ) or next; my $orgname = $colname = $col->{fullorg}; $colname =~ m/^(?:\p{Word}+\.)?"/ or $colname = lc $colname; defined( $self->{struct}->{ORG_NAME}->{$colname} ) and next; $self->{struct}->{ORG_NAME}->{$colname} = $self->{struct}->{ORG_NAME}->{$orgname}; } #my @uCols = map { ( $_ =~ /^(\w+\.)?"/ ) ? $_ : lc $_ } @{ $self->{struct}->{column_names} }; #$self->{struct}->{column_names} = \@uCols; } } return $rv; } else { $self->{struct} = {}; if ( $ENV{SQL_USER_DEFS} ) { return SQL::UserDefs::user_parse( $self, $sql ); } return $self->do_err("Command '$com' not recognized or not supported!"); } } sub replace_quoted_commas { my ( $self, $id ) = @_; $id =~ s/\?COMMA\?/,/gs; return $id; } sub replace_quoted_ids { my ( $self, $id ) = @_; $self->{struct}->{quoted_ids} or $self->{struct}->{literals} or return; if ($id) { if ( $id =~ /^\?QI(\d+)\?$/ ) { return '"' . $self->{struct}->{quoted_ids}->[$1] . '"'; } elsif ( $id =~ /^\?(\d+)\?$/ ) { return $self->{struct}->{literals}->[$1]; } else { return $id; } } return unless defined $self->{struct}->{table_names}; my @tables = @{ $self->{struct}->{table_names} }; for my $t (@tables) { if ( $t =~ /^\?QI(.+)\?$/ ) { $t = '"' . $self->{struct}->{quoted_ids}->[$1] . '"'; } elsif( $t =~ /^\?(\d+)\?$/ ) { $t = $self->{struct}->{literals}->[$1]; } } $self->{struct}->{table_names} = \@tables; delete $self->{struct}->{quoted_ids}; } sub structure { $_[0]->{struct} } sub command { my $x = $_[0]->{struct}->{command} || '' } sub feature { my ( $self, $opt_class, $opt_name, $opt_value ) = @_; if ( defined $opt_value ) { if ( $opt_class eq 'select' ) { $self->set_feature_flags( { "join" => $opt_value } ); } elsif ( $opt_class eq 'create' ) { $self->set_feature_flags( undef, { $opt_name => $opt_value } ); } else { # patch from chromatic $self->{opts}->{$opt_class}->{$opt_name} = $opt_value; # $self->{$opt_class}->{$opt_name} = $opt_value; } } else { return $self->{opts}->{$opt_class}->{$opt_name}; } } sub errstr { $_[0]->{struct}->{errstr} } sub list { my $self = shift; my $com = uc shift; return () if $com !~ /COMMANDS|RESERVED|TYPES|OPS|OPTIONS|DIALECTS/i; $com = 'valid_commands' if $com eq 'COMMANDS'; $com = 'valid_comparison_operators' if $com eq 'OPS'; $com = 'valid_data_types' if $com eq 'TYPES'; $com = 'valid_options' if $com eq 'OPTIONS'; $com = 'reserved_words' if $com eq 'RESERVED'; $self->dialect( $self->{dialect} ) unless $self->{dialect_set}; return sort keys %{ $self->{opts}->{$com} } unless $com eq 'DIALECTS'; my $dDir = "SQL/Dialects"; my @dialects; for my $dir (@INC) { local *D; if ( opendir( D, "$dir/$dDir" ) ) { @dialects = grep /.*\.pm$/, readdir(D); last; } } @dialects = map { s/\.pm$//; $_ } @dialects; return @dialects; } sub dialect { my ( $self, $dialect ) = @_; return $self->{dialect} unless ($dialect); return $self->{dialect} if ( $self->{dialect_set} ); $self->{opts} = {}; my $mod_class = "SQL::Dialects::$dialect"; $self->_load_class($mod_class) unless $mod_class->can("get_config"); # This is here for backwards compatibility with existing dialects # before the had the role to add new methods. $self->_inject_role( "SQL::Dialects::Role", $mod_class ) unless ( $mod_class->can("get_config_as_hash") ); $self->{opts} = $mod_class->get_config_as_hash(); $self->create_op_regexen(); $self->{dialect} = $dialect; $self->{dialect_set}++; return $self->{dialect}; } sub _load_class { my ( $self, $class ) = @_; my $mod = $class; $mod =~ s{::}{/}g; $mod .= ".pm"; local ( $!, $@ ); eval { require "$mod"; } or return $self->do_err($@); return 1; } sub _inject_role { my ( $self, $role, $dest ) = @_; eval qq{ package $dest; use $role; 1; } or croak "Can't inject $role into $dest: $@"; } 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 # my @notops; for (@allops) { push( @notops, $_ ) if /NOT/i; } $self->{opts}->{valid_comparison_NOT_ops_regex} = '^\s*(.+)\s+(' . join( '|', @notops ) . ')\s+(.*)\s*$' if scalar @notops; # # <>, <=, >= operators # my @compops; for (@allops) { push( @compops, $_ ) if /<=|>=|<>/; } $self->{opts}->{valid_comparison_twochar_ops_regex} = '^\s*(.+)\s+(' . join( '|', @compops ) . ')\s+(.*)\s*$' if scalar @compops; # # everything # $self->{opts}->{valid_comparison_ops_regex} = '^\s*(.+)\s+(' . join( '|', @allops ) . ')\s+(.*)\s*$' if scalar @allops; # # end DAA # } ################################################################## # SQL COMMANDS ################################################################## #################################################### # DROP TABLE #################################################### sub DROP { my ( $self, $stmt ) = @_; 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 ) { $stmt = "DROP TABLE $1"; $self->{struct}->{ignore_missing_table} = 1; } if ( $stmt =~ /^\s*DROP\s+(\S+)\s+(.+)$/si ) { my $com2 = $1 || ''; $table_name = $2; if ( $com2 !~ /^TABLE$/i ) { return $self->do_err("The command 'DROP $com2' is not recognized or not supported!"); } $table_name =~ s/^\s+//; $table_name =~ s/\s+$//; if ( $table_name =~ /(\S+) (RESTRICT|CASCADE)/i ) { $table_name = $1; $self->{struct}->{drop_behavior} = uc $2; } } else { return $self->do_err("Incomplete DROP statement!"); } return undef unless $self->TABLE_NAME($table_name); $table_name = $self->replace_quoted_ids($table_name); $self->{tmp}->{is_table_name} = { $table_name => 1 }; $self->{struct}->{table_names} = [$table_name]; return 1; } #################################################### # DELETE FROM WHERE #################################################### sub DELETE { my ( $self, $str ) = @_; $self->{struct}->{command} = 'DELETE'; $str =~ s/^DELETE\s+FROM\s+/DELETE /i; # Make FROM optional my ( $table_name, $where_clause ) = $str =~ /^DELETE (\S+)(.*)$/i; return $self->do_err('Incomplete DELETE statement!') if !$table_name; return undef unless $self->TABLE_NAME($table_name); $self->{tmp}->{is_table_name} = { $table_name => 1 }; $self->{struct}->{table_names} = [$table_name]; $self->{struct}->{column_defs} = [ { type => 'column', value => '*' } ]; $where_clause =~ s/^\s+//; $where_clause =~ s/\s+$//; if ($where_clause) { $where_clause =~ s/^WHERE\s*(.*)$/$1/i; return undef unless $self->SEARCH_CONDITION($where_clause); } return 1; } ############################################################## # SELECT ############################################################## # SELECT [] # | # FROM # [WHERE ] # [ORDER BY ] # [LIMIT ] ############################################################## sub SELECT { my ( $self, $str ) = @_; $self->{struct}->{command} = 'SELECT'; 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; } # else { # return $self->do_err("Couldn't find FROM clause in SELECT!"); # } # return undef unless $self->FROM_CLAUSE($from_clause); my $has_from_clause = $self->FROM_CLAUSE($from_clause) if ($from_clause); return undef unless ( $self->SELECT_CLAUSE($str) ); if ($where_clause) { return undef unless ( $self->SEARCH_CONDITION($where_clause) ); } if ($groupby_clause) { return undef unless ( $self->GROUPBY_LIST($groupby_clause) ); } if ($order_clause) { return undef unless ( $self->SORT_SPEC_LIST($order_clause) ); } if ($limit_clause) { return undef unless ( $self->LIMIT_CLAUSE($limit_clause) ); } if ( ( $self->{struct}->{join}->{clause} and $self->{struct}->{join}->{clause} eq 'ON' ) or ( $self->{struct}->{multiple_tables} and !( scalar keys %{ $self->{struct}->{join} } ) ) ) { return undef unless ( $self->IMPLICIT_JOIN() ); } if ( $self->{struct}->{set_quantifier} && ( 'DISTINCT' eq $self->{struct}->{set_quantifier} ) && $self->{struct}->{has_set_functions} && !defined( _ARRAY( $self->{struct}->{group_by} ) ) ) { delete $self->{struct}->{set_quantifier}; carp "Specifying DISTINCT when using aggregate functions isn't reasonable - ignored." if ( $self->{PrintError} ); } return 1; } sub GROUPBY_LIST { my ( $self, $gclause ) = @_; return 1 unless ($gclause); my $cols = $self->ROW_VALUE_LIST($gclause); return undef if ( $self->{struct}->{errstr} ); @{ $self->{struct}->{group_by} } = map { $_->{fullorg} } @{$cols}; return 1; } sub IMPLICIT_JOIN { my $self = $_[0]; delete $self->{struct}->{multiple_tables}; if ( !$self->{struct}->{join}->{clause} or $self->{struct}->{join}->{clause} ne 'ON' ) { $self->{struct}->{join}->{type} = 'INNER'; $self->{struct}->{join}->{clause} = 'IMPLICIT'; } if ( defined $self->{struct}->{keycols} ) { my @keys; my @keys2 = @keys = @{ $self->{struct}->{keycols} }; $self->{struct}->{join}->{table_order} = $self->order_joins( \@keys2 ); @{ $self->{struct}->{join}->{keycols} } = @keys; delete $self->{struct}->{keycols}; } else { return $self->do_err("No equijoin condition in WHERE or ON clause"); } return 1; } sub EXPLICIT_JOIN { my ( $self, $remainder ) = @_; return undef unless ($remainder); my ( $tableA, $tableB, $keycols, $jtype, $natural ); if ( $remainder =~ m/^(.+?) (NATURAL|INNER|LEFT|RIGHT|FULL|CROSS|UNION|JOIN)(.+)$/is ) { $tableA = $1; $remainder = $2 . $3; } else { ( $tableA, $remainder ) = $remainder =~ m/^(\S+) (.*)/i; } if ( $remainder =~ m/^NATURAL (.+)/ ) { $self->{struct}->{join}->{clause} = 'NATURAL'; $natural++; $remainder = $1; } if ( $remainder =~ m/^(INNER|LEFT|RIGHT|FULL|CROSS|UNION) JOIN (.+)/i ) { $jtype = $self->{struct}->{join}->{clause} = uc($1); $remainder = $2; $jtype = "$jtype OUTER" if $jtype !~ /INNER|UNION/i; } if ( $remainder =~ m/^(LEFT|RIGHT|FULL|CROSS) OUTER JOIN (.+)/i ) { $jtype = $self->{struct}->{join}->{clause} = uc($1) . " OUTER"; $remainder = $2; } if ( $remainder =~ m/^JOIN (.+)/i ) { $jtype = 'INNER'; $self->{struct}->{join}->{clause} = 'DEFAULT INNER'; $remainder = $1; } if ( $self->{struct}->{join} ) { if ( $remainder && $remainder =~ m/^(.+?) USING \(([^\)]+)\)(.*)/i ) { $self->{struct}->{join}->{clause} = 'USING'; $tableB = $1; my $keycolstr = $2; $remainder = $3; @$keycols = split( /,/, $keycolstr ); } if ( $remainder && $remainder =~ m/^(.+?) ON (.+)/i ) { $self->{struct}->{join}->{clause} = 'ON'; $tableB = $1; my $keycolstr = $2; $remainder = $3; if ( $keycolstr =~ m/ OR /i ) { return $self->do_err( qq{Can't use OR in an ON clause!}, 1 ); } @$keycols = split / AND /i, $keycolstr; return undef unless $self->TABLE_NAME_LIST( $tableA . ',' . $tableB ); # $self->{tmp}->{is_table_name}->{"$tableA"} = 1; # $self->{tmp}->{is_table_name}->{"$tableB"} = 1; for my $keycol (@$keycols) { my %is_done; my ( $arg1, $arg2 ) = split( m/ = /, $keycol ); my ( $c1, $c2 ) = ( $arg1, $arg2 ); $c1 =~ s/^.*\.([^\.]+)$/$1/; $c2 =~ s/^.*\.([^\.]+)$/$1/; if ( $c1 eq $c2 ) { return undef unless ( $arg1 = $self->ROW_VALUE($c1) ); if ( $arg1->{type} eq 'column' and !$is_done{$c1} ) { push( @{ $self->{struct}->{keycols} }, $arg1->{value} ); $is_done{$c1} = 1; } } else { return undef unless ( $arg1 = $self->ROW_VALUE($arg1) ); return undef unless ( $arg2 = $self->ROW_VALUE($arg2) ); if ( $arg1->{type} eq 'column' and $arg2->{type} eq 'column' ) { push( @{ $self->{struct}->{keycols} }, $arg1->{value} ); push( @{ $self->{struct}->{keycols} }, $arg2->{value} ); # delete $self->{struct}->{where_clause}; } } } } elsif ( $remainder =~ /^(.+?)$/i ) { $tableB = $1; $remainder = $2; } $remainder =~ s/^\s+// if ($remainder); } if ($jtype) { $jtype = "NATURAL $jtype" if ($natural); if ( $natural and $keycols ) { return $self->do_err(qq{Can't use NATURAL with a USING or ON clause!}); } return undef unless ( $self->TABLE_NAME_LIST("$tableA,$tableB") ); $self->{struct}->{join}->{type} = $jtype; $self->{struct}->{join}->{keycols} = $keycols if ($keycols); return 1; } return $self->do_err("Couldn't parse explicit JOIN!"); } sub SELECT_CLAUSE { my ( $self, $str ) = @_; return undef unless ($str); if ( $str =~ s/^(DISTINCT|ALL) (.+)$/$2/i ) { $self->{struct}->{set_quantifier} = uc($1); } return undef unless ( $self->SELECT_LIST($str) ); } sub FROM_CLAUSE { my ( $self, $str ) = @_; return undef unless $str; if ( $str =~ m/ JOIN /i ) { return undef unless $self->EXPLICIT_JOIN($str); } else { return undef unless $self->TABLE_NAME_LIST($str); } } sub INSERT { my ( $self, $str ) = @_; my $col_str; $str =~ s/^INSERT\s+INTO\s+/INSERT /i; # allow INTO to be optional my ( $table_name, $val_str ) = $str =~ m/^INSERT\s+(.+?)\s+VALUES\s+(\(.+\))$/i; if ( $table_name and $table_name =~ m/[()]/ ) { ( $table_name, $col_str, $val_str ) = $str =~ m/^INSERT\s+(.+?)\s+\((.+?)\)\s+VALUES\s+(\(.+\))$/i; } return $self->do_err('No table name specified!') unless ($table_name); return $self->do_err('Missing values list!') unless ( defined $val_str ); return undef unless ( $self->TABLE_NAME($table_name) ); $self->{struct}->{command} = 'INSERT'; $self->{struct}->{table_names} = [$table_name]; if ($col_str) { return undef unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST($col_str) ); } else { $self->{struct}->{column_defs} = [ { type => 'column', value => '*' } ]; } $self->{struct}->{values} = []; for (my ($v,$line_str) = $val_str; (($line_str,$v)=extract_bracketed($v,"('",'')) && defined $line_str; ) { return undef unless ( $self->LITERAL_LIST(substr($line_str,1,-1)) ); last unless $v =~ s/\A\s*,\s*//; } return 1; } ################################################################### # UPDATE ::= # # UPDATE SET [ WHERE ] # ################################################################### sub UPDATE { my ( $self, $str ) = @_; $self->{struct}->{command} = 'UPDATE'; my ( $table_name, $remainder ) = $str =~ m/^UPDATE (.+?) SET (.+)$/i; return $self->do_err('Incomplete UPDATE clause') unless ( $table_name && $remainder ); return undef unless ( $self->TABLE_NAME($table_name) ); $self->{tmp}->{is_table_name} = { $table_name => 1 }; $self->{struct}->{table_names} = [$table_name]; my ( $set_clause, $where_clause ) = $remainder =~ m/(.*?) WHERE (.*)$/i; $set_clause = $remainder if ( !$set_clause ); return undef unless ( $self->SET_CLAUSE_LIST($set_clause) ); if ($where_clause) { return undef unless ( $self->SEARCH_CONDITION($where_clause) ); } my @vals = @{ $self->{struct}->{values}->[0] }; my $num_val_placeholders = 0; for my $v (@vals) { ++$num_val_placeholders if ( $v->{type} eq 'placeholder' ); } $self->{struct}->{num_val_placeholders} = $num_val_placeholders; return 1; } ############ # FUNCTIONS ############ sub LOAD { my ( $self, $str ) = @_; $self->{struct}->{command} = 'LOAD'; $self->{struct}->{no_execute} = 1; my ($package) = $str =~ /^LOAD\s+(.+)$/; $str = $package; $package =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; $self->_load_class($package); my %subs = eval '%' . $package . '::'; for my $sub ( keys %subs ) { next unless ( $sub =~ m/^SQL_FUNCTION_([A-Z_0-9]+)$/ ); my $funcName = uc $1; my $subname = $package . '::' . 'SQL_FUNCTION_' . $funcName; $self->{opts}->{function_names}->{$funcName} = $subname; delete $self->{opts}->{_udf_function_names}; } 1; } sub CREATE_RAM_TABLE { my ( $self, $stmt ) = @_; $self->{struct}->{is_ram_table} = 1; $self->{struct}->{command} = 'CREATE_RAM_TABLE'; my ( $table_name, $table_element_def, %is_col_name ); if ( $stmt =~ /^(\S+)\s+LIKE\s*(.+)$/si ) { $table_name = $1; $table_element_def = $2; if ( $table_element_def =~ /^(.*)\s+KEEP CONNECTION\s*$/i ) { $table_element_def = $1; $self->{struct}->{ram_table_keep_connection} = 1; } } else { return $self->CREATE("CREATE TABLE $stmt"); } return undef unless $self->TABLE_NAME($table_name); for my $col ( split ',', $table_element_def ) { push( @{ $self->{struct}->{column_defs} }, $self->ROW_VALUE($col) ); } $self->{struct}->{table_names} = [$table_name]; return 1; } sub CREATE_FUNCTION { my ( $self, $stmt ) = @_; $self->{struct}->{command} = 'CREATE_FUNCTION'; $self->{struct}->{no_execute} = 1; my ( $func, $subname ); $stmt =~ s/\s*EXTERNAL//i; if ( $stmt =~ /^(\S+)\s+NAME\s+(.*)$/smi ) { $func = trim($1); $subname = trim($2); } $func ||= $stmt; $subname ||= $func; if ( $func =~ /^\?QI(\d+)\?$/ ) { $func = $self->{struct}->{quoted_ids}->[$1]; } if ( $subname =~ /^\?QI(\d+)\?$/ ) { $subname = $self->{struct}->{quoted_ids}->[$1]; } $self->{opts}->{function_names}->{ uc $func } = $subname; delete $self->{opts}->{_udf_function_names}; return 1; } sub CALL { my ( $self, $stmt ) = @_; $stmt =~ s/^CALL\s+(.*)/$1/i; $self->{struct}->{command} = 'CALL'; $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 } = $subname; delete $self->{opts}->{_udf_function_names}; $self->feature( 'valid_comparison_operators', uc $func, 1 ); return $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 ); return $self->create_op_regexen(); } sub replace_quoted($) { my ( $self, $str ) = @_; my @l = map { $self->replace_quoted_ids($_) } split( ',', $self->replace_quoted_commas($str) ); return @l; } ######### # CREATE ######### sub CREATE { my ( $self, $stmt ) = @_; my $features = 'TYPE|KEYWORD|FUNCTION|OPERATOR|PREDICATE'; if ( $stmt =~ m/^\s*CREATE\s+($features)\s+(.+)$/si ) { my ( $sub, $arg ) = ( $1, $2 ); $sub = 'CREATE_' . uc $sub; return $self->$sub($arg); } $stmt =~ s/^CREATE (LOCAL|GLOBAL) /CREATE /si; if ( $stmt =~ m/^\s*CREATE\s+(?:TEMP|TEMPORARY)\s+TABLE\s+(.+)$/si ) { $stmt = "CREATE TABLE $1"; $self->{struct}->{is_ram_table} = 1; } $self->{struct}->{command} = 'CREATE'; my ( $table_name, $table_element_def, %is_col_name ); if ( $stmt =~ m/^(.*) ON COMMIT (DELETE|PRESERVE) ROWS\s*$/si ) { $stmt = $1; $self->{struct}->{commit_behaviour} = $2; # return $self->do_err( # "Can't specify commit behaviour for permanent tables." # ) # if !defined $self->{struct}->{table_type} # or $self->{struct}->{table_type} !~ /TEMPORARY/; } if ( $stmt =~ m/^CREATE TABLE (\S+) \((.*)\)$/si ) { $table_name = $1; $table_element_def = $2; } elsif ( $stmt =~ m/^CREATE TABLE (\S+) AS (.*)$/si ) { $table_name = $1; my $subquery = $2; return undef unless $self->TABLE_NAME($table_name); $self->{struct}->{table_names} = [$table_name]; # undo subquery replaces $subquery =~ s/\?(\d+)\?/'$self->{struct}{literals}[$1]'/g; $subquery =~ s/\?QI(\d+)\?/"$self->{struct}->{quoted_ids}->[$1]"/g; $subquery =~ s/\?COMMA\?/,/gs; $self->{struct}->{subquery} = $subquery; if ( -1 != index( $subquery, '?' ) ) { ++$self->{struct}->{num_placeholders}; } return 1; } else { return $self->do_err("Can't find column definitions!"); } return undef unless ( $self->TABLE_NAME($table_name) ); $table_element_def =~ s/\s+\(/(/g; my $primary_defined; while ( $table_element_def =~ s/( # start of grouping 1 \( # match a bracket; vi compatible bracket -> \)( [^)]+ # everything up to but not including the comma, no nesting of brackets is required ) # end of grouping 1 , # the comma to be removed to allow splitting on commas ( # start of grouping 2; vi compatible bracket -> \( .*?\) # everything up to and including the end bracket )/$1?COMMA?$2/sgx ) { } for my $col ( split( ',', $table_element_def ) ) { if ( $col =~ m/^\s*(?:CONSTRAINT\s+(\S+)\s*)? # optional name of foreign key FOREIGN\s+KEY\s*\(\s* # start of list of; vi compatibile bracket -> ( (\s*[^)]+\s*) # field names in this table \s*\)\s* # end of field names in this table REFERENCES # key word \s*(\S+)\s* # table name being referenced in foreign key \(\s* # start of list of; vi compatible bracket -> ( (\s*[^)]+\s*) # field names in foreign table \s*\)\s* # end of field names in foreign table $/x ) { my ( $name, $local_cols, $referenced_table, $referenced_cols ) = ( $1, $2, $3, $4 ); my @local_cols = $self->replace_quoted($local_cols); $referenced_table = $self->replace_quoted_ids($referenced_table); my @referenced_cols = $self->replace_quoted($referenced_cols); if ( defined $name ) { $name = $self->replace_quoted_ids($name); } else { $name = $self->replace_quoted_ids($table_name); my ($quote_char) = ''; if ( $name =~ s/(\W)$// ) { $quote_char = ($1); } foreach my $local_col (@local_cols) { my $col_name = $local_col; $col_name =~ s/^\W//; $col_name =~ s/\W$//; $name .= '_' . $col_name; } $name .= '_fkey' . $quote_char; } $self->{struct}->{table_defs}->{$name}->{type} = 'FOREIGN'; $self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols; $self->{struct}->{table_defs}->{$name}->{referenced_table} = $referenced_table; $self->{struct}->{table_defs}->{$name}->{referenced_cols} = \@referenced_cols; next; } elsif ( $col =~ m/^\s*(?:CONSTRAINT\s+(\S+)\s*)? # optional name of foreign key PRIMARY\s+KEY\s*\(\s* # start of list of; vi compatibile bracket -> ( (\s*[^)]+\s*) # field names in this table \s*\)\s* # end of field names in this table $/x ) { my ( $name, $local_cols ) = ( $1, $2 ); my @local_cols = $self->replace_quoted($local_cols); if ( defined $name ) { $name = $self->replace_quoted_ids($name); } else { $name = $table_name; if ( $name =~ s/(\W)$// ) { $name .= '_pkey' . $1; } else { $name .= '_pkey'; } } $self->{struct}->{table_defs}->{$name}->{type} = 'PRIMARY'; $self->{struct}->{table_defs}->{$name}->{local_cols} = \@local_cols; next; } # it seems, perl 5.6 isn't greedy enough .. let's help a bit my ($data_types_regex) = join( '|', sort { length($b) <=> length($a) } keys %{ $self->{opts}->{valid_data_types} } ); $data_types_regex =~ s/ /\\ /g; # backslash spaces to allow the /x modifier below my ( $name, $type, $constraints ) = ( $col =~ m/\s*(\S+)\s+ # capture the column name ((?:$data_types_regex|\S+) # check for all allowed data types OR anything that looks like a bad data type to give a good error (?:\s*\(\d+(?:\?COMMA\?\d+)?\))?) # allow the data type to have a precision specifier such as NUMERIC(4,6) on it \s*(\W.*|$) # capture the constraints if any /ix ); return $self->do_err("Column definition is missing a data type!") unless ($type); return undef unless ( $self->IDENTIFIER($name) ); $name = $self->replace_quoted_ids($name); $constraints =~ s/^\s+//; $constraints =~ s/\s+$//; if ($constraints) { $constraints =~ s/PRIMARY KEY/PRIMARY_KEY/i; $constraints =~ s/NOT NULL/NOT_NULL/i; my @c = split m/\s+/, $constraints; my %has_c; for my $constr (@c) { if ( $constr =~ m/^\s*(UNIQUE|NOT_NULL|PRIMARY_KEY)\s*$/i ) { my $cur_c = uc $1; if ( $has_c{$cur_c}++ ) { return $self->do_err(qq~Duplicate column constraint: '$constr'!~); } if ( $cur_c eq 'PRIMARY_KEY' and $primary_defined++ ) { return $self->do_err(qq{Can't have two PRIMARY KEYs in a table!}); } $constr =~ s/_/ /g; push @{ $self->{struct}->{table_defs}->{columns}->{$name}->{constraints} }, $constr; } else { return $self->do_err("Unknown column constraint: '$constr'!"); } } } $type = uc $type; my $length; if ( $type =~ m/(.+)\((.+)\)/ ) { $type = $1; $length = $2; } if ( !$self->{opts}->{valid_data_types}->{$type} ) { return $self->do_err("'$type' is not a recognized data type!"); } $self->{struct}->{table_defs}->{columns}->{$name}->{data_type} = $type; $self->{struct}->{table_defs}->{columns}->{$name}->{data_length} = $length; push( @{ $self->{struct}->{column_defs} }, { type => 'column', value => $name, fullorg => $name, } ); my $tmpname = $name; $tmpname = lc $tmpname unless ( $tmpname =~ m/^(?:\p{Word}+\.)?"/ ); return $self->do_err("Duplicate column names!") if $is_col_name{$tmpname}++; } $self->{struct}->{table_names} = [$table_name]; return 1; } ############### # SQL SUBRULES ############### sub SET_CLAUSE_LIST { my ( $self, $set_string ) = @_; my @sets = split( /,/, $set_string ); my ( @cols, @vals ); for my $set (@sets) { my ( $col, $val ) = split( m/ = /, $set ); return $self->do_err('Incomplete SET clause!') unless ( defined($col) && defined($val) ); push( @cols, $col ); push( @vals, $val ); } return undef unless ( $self->{struct}->{column_defs} = $self->ROW_VALUE_LIST( join ',', @cols ) ); return undef unless ( $self->LITERAL_LIST( join ',', @vals ) ); return 1; } sub SET_QUANTIFIER { my ( $self, $str ) = @_; if ( $str =~ /^(DISTINCT|ALL)\s+(.*)$/si ) { $self->{struct}->{set_quantifier} = uc $1; $str = $2; } return $str; } # # DAA v1.11 # modify to transform || strings into # CONCAT(); note that we # only xform the topmost expressions; # if a concat is contained within a subfunction, # it should get handled by ROW_VALUE() # sub transform_concat { my ( $obj, $colstr ) = @_; pos($colstr) = 0; my $parens = 0; my $spos = 0; my @concats = (); my $alias = ( $colstr =~ s/^(.+)(\s+AS\s+\S+)$/$1/ ) ? $2 : ''; while ( $colstr =~ /\G.*?([\(\)\|])/gcs ) { if ( $1 eq '(' ) { $parens++; } elsif ( $1 eq ')' ) { $parens--; } elsif (( !$parens ) && ( substr( $colstr, $-[1] + 1, 1 ) eq '|' ) ) { # # its a concat outside of parens, push prior string on stack # push @concats, substr( $colstr, $spos, $-[1] - $spos ); $spos = $+[1] + 1; pos($colstr) = $spos; } } # # no concats, return original # return $colstr unless scalar @concats; # # don't forget the last one! # push @concats, substr( $colstr, $spos ); return 'CONCAT(' . join( ', ', @concats ) . ")$alias"; } # # DAA v1.10 # improved column list extraction # original doesn't seem to handle # commas within function argument lists # # DAA v1.11 # modify to transform || strings into # CONCAT() # sub extract_column_list { my ( $self, $colstr ) = @_; my @collist = (); pos($colstr) = 0; my $parens = 0; my $spos = 0; while ( $colstr =~ m/\G.*?([\(\),])/gcs ) { if ( $1 eq '(' ) { $parens++; } elsif ( $1 eq ')' ) { $parens--; } elsif ( !$parens ) { # its a comma outside of parens push( @collist, substr( $colstr, $spos, $-[1] - $spos ) ); $collist[-1] =~ s/^\s+//; $collist[-1] =~ s/\s+$//; return $self->do_err('Bad column list!') if ( $collist[-1] eq '' ); $spos = $+[1]; } } return $self->do_err('Unbalanced parentheses!') if ($parens); # don't forget the last one! push( @collist, substr( $colstr, $spos ) ); $collist[-1] =~ s/^\s+//; $collist[-1] =~ s/\s+$//; return $self->do_err('Bad column list!') if ( $collist[-1] eq '' ); # scan for and convert string concats to CONCAT() foreach ( 0 .. $#collist ) { $collist[$_] = $self->transform_concat( $collist[$_] ) if ( $collist[$_] =~ m/\|\|/ ); } return @collist; } sub SELECT_LIST { my ( $self, $col_str ) = @_; if ( $col_str =~ m/^\s*\*\s*$/ ) { $self->{struct}->{column_defs} = [ { type => 'column', value => '*' } ]; $self->{struct}->{column_aliases} = {}; return 1; } my @col_list = $self->extract_column_list($col_str); return undef unless ( scalar(@col_list) ); my ( @newcols, %aliases ); for my $col (@col_list) { # DAA: # need better alias test here, since AS is a common # keyword that might be used in a function my ( $fld, $alias ) = ( $col =~ m/^(.+?)\s+(?:AS\s+)?([A-Z]\p{Word}*|\?QI\d+\?)$/i ) ? ( $1, $2 ) : ( $col, undef ); $col = $fld; if ( $col =~ m/^(\S+)\.\*$/ ) { my $table = $1; if ( defined($alias) ) { return $self->do_err("'$table.*' cannot be aliased"); } $table = $self->{tmp}->{is_table_alias}->{$table} if ( $self->{tmp}->{is_table_alias}->{$table} ); $table = $self->{tmp}->{is_table_alias}->{"\L$table"} if ( $self->{tmp}->{is_table_alias}->{"\L$table"} ); return undef unless ( $self->TABLE_NAME($table) ); $table = $self->replace_quoted_ids($table); push( @newcols, { type => 'column', value => "$table.*", } ); } else { my $newcol; $newcol = $self->SET_FUNCTION_SPEC($col); return if ( $self->{struct}->{errstr} ); $newcol ||= $self->ROW_VALUE($col); return if ( $self->{struct}->{errstr} ); return $self->do_err("Invalid SELECT entry '$col'") unless ( defined( _HASH($newcol) ) ); # FIXME this might be better done later and only if not 2 functions with the same name are selected if ( !defined($alias) && ( ( 'function' eq $newcol->{type} ) || ( 'setfunc' eq $newcol->{type} ) ) ) { $alias = $newcol->{name}; } if ( defined($alias) ) { $alias = $self->replace_quoted_ids($alias); $newcol->{alias} = $alias; $aliases{ $newcol->{fullorg} } = $alias; $self->{struct}->{ORG_NAME}->{ $newcol->{fullorg} } = $alias; $self->{struct}->{ALIASES}->{$alias} = $newcol->{fullorg}; } push( @newcols, $newcol ); } } $self->{struct}->{column_aliases} = \%aliases; $self->{struct}->{column_defs} = \@newcols; return 1; } sub SET_FUNCTION_SPEC { my ( $self, $col_str ) = @_; if ( $col_str =~ m/^(COUNT|AVG|SUM|MAX|MIN) \((.*)\)\s*$/i ) { my $set_function_name = uc $1; my $set_function_arg_str = $2; my $distinct = 'ALL'; if ( $set_function_arg_str =~ s/(DISTINCT|ALL) (.+)$/$2/i ) { $distinct = uc $1; } my $count_star = ( $set_function_name eq 'COUNT' ) && ( $set_function_arg_str eq '*' ); my $set_function_arg; if ($count_star) { return $self->do_err("Keyword DISTINCT is not allowed for COUNT(*)") if ( 'DISTINCT' eq $distinct ); $set_function_arg = { type => 'column', value => '*' }; } else { $set_function_arg = $self->ROW_VALUE($set_function_arg_str); return if ( $self->{struct}->{errstr} ); return unless ( defined( _HASH($set_function_arg) ) ); } $self->{struct}->{has_set_functions} = 1; my $value = { name => $set_function_name, arg => $set_function_arg, argstr => lc($set_function_arg_str), distinct => $distinct, type => 'setfunc', fullorg => $col_str, }; return $value; } else { return undef; } } sub LIMIT_CLAUSE { my ( $self, $limit_clause ) = @_; # $limit_clause = trim($limit_clause); $limit_clause =~ s/^\s+//; $limit_clause =~ s/\s+$//; return 1 if !$limit_clause; my ( $offset, $limit, $junk ) = split /,/, $limit_clause; return $self->do_err('Bad limit clause!') if ( defined $limit and $limit =~ /[^\d]/ ) or ( defined $offset and $offset =~ /[^\d]/ ) or defined $junk; if ( defined $offset and !defined $limit ) { $limit = $offset; undef $offset; } $self->{struct}->{limit_clause} = { limit => $limit, offset => $offset, }; return 1; } sub SORT_SPEC_LIST { my ( $self, $order_clause ) = @_; return 1 if !$order_clause; my @ocols; my @order_columns = split ',', $order_clause; for my $col (@order_columns) { my $newcol; my $newarg; if ( $col =~ /\s*(\S+)\s+(ASC|DESC)/si ) { $newcol = $1; $newarg = uc $2; } elsif ( $col =~ /^\s*(\S+)\s*$/si ) { $newcol = $1; $newarg = 'ASC'; } else { return $self->do_err('Junk after column name in ORDER BY clause!'); } $newcol = $self->COLUMN_NAME($newcol) or return; if ( $newcol =~ /^(.+)\..+$/s ) { my $table = $1; $self->_verify_tablename( $table, "ORDER BY" ); } push( @ocols, { $newcol => $newarg } ); } $self->{struct}->{sort_spec_list} = \@ocols; return 1; } sub SEARCH_CONDITION { my ( $self, $str ) = @_; $str =~ s/^\s*WHERE (.+)/$1/; $str =~ s/^\s+//; $str =~ s/\s+$//; return $self->do_err("Couldn't find WHERE clause!") unless $str; # # DAA # make these OO so subclasses can override them # $str = $self->repl_btwin($str); # # DAA # add another abstract method so subclasses # can inject their own syntax transforms # $str = $self->transform_syntax($str); my $open_parens = $str =~ tr/\(//; my $close_parens = $str =~ tr/\)//; if ( $open_parens != $close_parens ) { return $self->do_err("Mismatched parentheses in WHERE clause!"); } $str = nongroup_numeric( $self->nongroup_string($str) ); my $pred = $open_parens ? $self->parens_search( $str, [] ) : $self->non_parens_search( $str, [] ); return $self->do_err("Couldn't find predicate!") unless $pred; $self->{struct}->{where_clause} = $pred; return 1; } ############################################################ # UTILITY FUNCTIONS CALLED TO PARSE PARENS IN WHERE CLAUSE ############################################################ sub repl_btwin { my ( $self, $str ) = @_; # DAA make OO for subclassing my @lids; my $i = -1; while ( $str =~ m/\G.*(?:IN|BETWEEN)\s+\(/g ) { my $start = pos($str) - 1; my $lparens = 1; my $rparens = 0; while ( $str =~ m/\G.*?([\(\)])/gcs ) { ++$lparens if ( '(' eq $1 ); ++$rparens if ( ')' eq $1 ); last if ( $lparens == $rparens ); } my $now = pos($str); ++$i; my $subst = "?LI$i?"; my $term = substr( $str, $start, $now - $start, $subst ); $term = substr( $term, 1, length($term) - 2 ); push( @lids, $term ); pos($str) = $start + length($subst); } $self->{struct}->{list_ids} = \@lids; return $str; } # groups clauses by nested parens # # DAA # rewrite to correct paren scan # and optimize code, and remove # recursion # sub parens_search { my ( $self, $str, $predicates ) = @_; my $index = scalar( @{$predicates} ); # to handle WHERE (a=b) AND (c=d) # but needs escape space to not foul up AND/OR # locate all open parens # locate all close parens # apply non_paren_search to contents of # inner parens my $lparens = ( $str =~ tr/\(// ); my $rparens = ( $str =~ tr/\)// ); return $self->do_err( 'Unmatched ' . ( ( $lparens > $rparens ) ? 'left' : 'right' ) . " parentheses in '$str'!" ) unless ( $lparens == $rparens ); return $self->non_parens_search( $str, $predicates ) unless $lparens; my @lparens = (); while ( $str =~ m/\G.*?([\(\)])/gcs ) { push( @lparens, $-[1] ), next if ( $1 eq '(' ); # # got a close paren, so pop the position of matching # left paren and extract the expression, removing the # parens # my $pos = pop @lparens; my $predlen = $+[1] - $pos; my $pred = substr( $str, $pos + 1, $predlen - 2 ); # # note that this will pass thru any prior ^$index^ xlation, # so we don't need to recurse to recover the predicate # substr( $str, $pos, $predlen ) = $pred, pos($str) = $pos + length($pred), next unless ( $pred =~ / (AND|OR) /i ); # # handle AND/OR # push( @$predicates, substr( $str, $pos + 1, $predlen - 2 ) ); my $replacement = "^$#$predicates^"; substr( $str, $pos, $predlen ) = $replacement; pos($str) = $pos + length($replacement); } return $self->non_parens_search( $str, $predicates ); } # creates predicates from clauses that either have no parens # or ANDs or have been previously grouped by parens and ANDs # # DAA # rewrite to fix paren scanning # sub non_parens_search { my ( $self, $str, $predicates ) = @_; my $neg = 0; my $nots = {}; $neg = 1, $nots = { pred => 1 } if ( $str =~ s/^NOT (\^.+)$/$1/i ); my ( $pred1, $pred2, $op ); my $and_preds = []; ( $str, $and_preds ) = group_ands($str); $str = $and_preds->[$1] if $str =~ /^\s*~(\d+)~\s*$/; return $self->non_parens_search( $$predicates[$1], $predicates ) if ( $str =~ /^\s*\^(\d+)\^\s*$/ ); if ( $str =~ /\G(.*?)\s+(AND|OR)\s+(.*)$/igcs ) { ( $pred1, $op, $pred2 ) = ( $1, $2, $3 ); if ( $pred1 =~ /^\s*\^(\d+)\^\s*$/ ) { $pred1 = $self->non_parens_search( $$predicates[$1], $predicates ); } else { $pred1 =~ s/\~(\d+)\~$/$and_preds->[$1]/g; $pred1 = $self->non_parens_search( $pred1, $predicates ); } # # handle pred2 as a full predicate # $pred2 =~ s/\~(\d+)\~$/$and_preds->[$1]/g; $pred2 = $self->non_parens_search( $pred2, $predicates ); return { neg => $neg, nots => $nots, arg1 => $pred1, op => uc $op, arg2 => $pred2, }; } # # terminal predicate # need to check for singleton functions here # my $xstr = $str; my ( $k, $v ); if ( $str =~ /^\s*([A-Z]\p{Word}*)\s*\[/gcs ) { # # we've got a function, check if its a singleton # my $parens = 1; my $spos = $-[1]; my $epos = 0; $epos = $-[1], $parens += ( $1 eq '[' ) ? 1 : -1 while ( ( $parens > 0 ) && ( $str =~ /\G.*?([\[\]])/gcs ) ); $k = substr( $str, $spos, $epos - $spos + 1 ); $k =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g; # # for now we assume our parens are balanced # now look for a predicate operator and a right operand # $v = $1, $v =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g if ( $str =~ /\G\s+\S+\s*(.+)\s*$/gcs ); } else { $xstr =~ s/\?(\d+)\?/$self->{struct}{literals}[$1]/g; ( $k, $v ) = $xstr =~ /^(\S+?)\s+\S+\s*(.+)\s*$/; } push @{ $self->{struct}{where_cols}{$k} }, $v if defined $k; return $self->PREDICATE($str); } # groups AND clauses that aren't already grouped by parens # sub group_ands { my $str = shift; my $and_preds = shift || []; return ( $str, $and_preds ) unless $str =~ / AND / and $str =~ / OR /; return $str, $and_preds unless ( $str =~ /^(.*?) AND (.*)$/i ); my ( $front, $back ) = ( $1, $2 ); my $index = scalar @$and_preds; $front = $1 if ( $front =~ /^.* OR (.*)$/i ); $back = $1 if ( $back =~ /^(.*?) (OR|AND) .*$/i ); my $newpred = "$front AND $back"; push @$and_preds, $newpred; $str =~ s/\Q$newpred/~$index~/i; return group_ands( $str, $and_preds ); } # replaces string function parens with square brackets # e.g TRIM (foo) -> TRIM[foo] # # DAA update to support UDFs # and remove recursion # sub nongroup_string { my ( $self, $str ) = @_; # # add in any user defined functions # my $f = join( '|', FUNCTION_NAMES, $self->_udf_function_names ); # # we need a scan here to permit arbitrarily nested paren # arguments to functions # my $parens = 0; my $pos; my @lparens = (); while ( $str =~ /\G.*?((\b($f)\s*\()|[\(\)])/igcs ) { if ( $1 eq ')' ) { # # close paren, see if any pending function open # paren matches it # --$parens; $pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ']', pos($str) = $pos, pop(@lparens) if ( @lparens && ( $lparens[-1] == $parens ) ); } elsif ( $1 eq '(' ) { # # just an open paren, count it and go on # ++$parens; } else { # # new function definition, capture its open paren # also uppercase the function name # $pos = $+[0]; substr( $str, $-[3], length($3) ) = uc $3; substr( $str, $+[0] - 1, 1 ) = '['; pos($str) = $pos; push @lparens, $parens; ++$parens; } } # return $self->do_err('Unmatched ' . # (($parens > 0) ? 'left' : 'right') . ' parentheses!') # if $parens; # # DAA # remove scoped recursion # # return ( $str =~ /($f)\s*\(/i ) ? # nongroup_string($str) : $str; return $str; } # replaces math parens with square brackets # e.g (4-(6+7)*9) -> MATH[4-MATH[6+7]*9] # sub nongroup_numeric { my $str = $_[0]; my $has_op; # # DAA # optimize regex # if ( $str =~ m/\(([\p{Word} \*\/\+\-\[\]\?]+)\)/ ) { my $match = $1; if ( $match !~ m/(LIKE |IS|BETWEEN|IN)/i ) { my $re = quotemeta($match); $str =~ s/\($re\)/MATH\[$match\]/; } else { $has_op++; } } # # DAA # remove scoped recursion # return ( !$has_op and $str =~ /\(([\p{Word} \*\/\+\-\[\]\?]+)\)/ ) ? nongroup_numeric($str) : $str; } ############################################################ ######################################################### # LITERAL_LIST ::= [,] ######################################################### sub LITERAL_LIST { my ( $self, $str ) = @_; my @tokens = split /,/, $str; my @values; for my $tok (@tokens) { my $val = $self->ROW_VALUE($tok); return $self->do_err(qq('$tok' is not a valid value or is not quoted!)) unless $val; push @values, $val; } push( @{ $self->{struct}->{values} }, \@values ); return 1; } ############################################################################# # LITERAL ::= | | | NULL/TRUE/FALSE ############################################################################# sub LITERAL { my ( $self, $str ) = @_; # # DAA # strip parens (if any) # $str = $1 while ( $str =~ m/^\s*\(\s*(.+)\s*\)\s*$/ ); return 'null' if $str =~ m/^NULL$/i; # NULL return 'boolean' if $str =~ m/^(?:TRUE|FALSE)$/i; # TRUE/FALSE # return 'empty_string' if $str =~ /^~E~$/i; # NULL if ( $str eq '?' ) { $self->{struct}->{num_placeholders}++; return 'placeholder'; } # return 'placeholder' if $str eq '?'; # placeholder question mark return 'string' if $str =~ m/^'.*'$/s; # quoted string # return 'number' if $str =~ m/^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/; # number return 'number' if ( looks_like_number($str) ); # number return undef; } ################################################################### # PREDICATE ################################################################### sub PREDICATE { my ( $self, $str ) = @_; my ( $arg1, $op, $arg2, $opexp ); $opexp = $self->{opts}{valid_comparison_NOT_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i if $self->{opts}{valid_comparison_NOT_ops_regex}; $opexp = $self->{opts}{valid_comparison_twochar_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i if ( !defined($op) && $self->{opts}{valid_comparison_twochar_ops_regex} ); $opexp = $self->{opts}{valid_comparison_ops_regex}, ( $arg1, $op, $arg2 ) = $str =~ /$opexp/i if ( !defined($op) && $self->{opts}{valid_comparison_ops_regex} ); # ### USER-DEFINED PREDICATE # unless ( defined $arg1 && defined $op && defined $arg2 ) { $arg1 = $str; $op = 'USER_DEFINED'; $arg2 = ''; } $op = uc $op; # my $uname = $self->is_func($arg1); # if (!$uname) { # $arg1 =~ s/^(\S+).*$/$1/; # return $self->do_err("Bad predicate: '$arg1'!"); # } my $negated = 0; # boolean value showing if predicate is negated my %not; # hash showing elements modified by NOT # # e.g. "NOT bar = foo" -> %not = (arg1=>1) # "bar NOT LIKE foo" -> %not = (op=>1) # "NOT bar NOT LIKE foo" -> %not = (arg1=>1,op=>1); # "NOT bar IS NOT NULL" -> %not = (arg1=>1,op=>1); # "bar = foo" -> %not = undef; # $not{arg1}++ if ( $arg1 =~ s/^NOT (.+)$/$1/i ); $not{op}++ if ( $op =~ s/^(.+) NOT$/$1/i || $op =~ s/^NOT (.+)$/$1/i ); $negated = 1 if %not and scalar keys %not == 1; return undef unless $arg1 = $self->ROW_VALUE($arg1); if ( $op ne 'USER_DEFINED' ) { # USER-PREDICATE; return undef unless $arg2 = $self->ROW_VALUE($arg2); } else { # $arg2 = $self->ROW_VALUE($arg2); } if ( defined( _HASH($arg1) ) and defined( _HASH($arg2) ) and ( ( $arg1->{type} || '' ) eq 'column' ) and ( ( $arg2->{type} || '' ) eq 'column' ) and ( $op eq '=' ) ) { push( @{ $self->{struct}->{keycols} }, $arg1->{value} ); push( @{ $self->{struct}->{keycols} }, $arg2->{value} ); } return { neg => $negated, nots => \%not, arg1 => $arg1, op => $op, arg2 => $arg2, }; } sub _udf_function_names { $_[0]->{opts}->{_udf_function_names} or return $_[0]->{opts}->{_udf_function_names} = join( "|", map { uc $_ } keys %{ $_[0]->{opts}->{function_names} } ); $_[0]->{opts}->{_udf_function_names}; } sub undo_string_funcs { my ( $self, $str ) = @_; my $f = join( '|', FUNCTION_NAMES, $self->_udf_function_names ); # eliminate recursion: # we have to scan for closing brackets, since we may # have intervening MATH elements with brackets my ( $brackets, $pos, @lbrackets ) = (0); while ( $str =~ /\G.*?((\b($f)\s*\[)|[\[\]])/igcs ) { if ( $1 eq ']' ) { # close paren, see if any pending function open # paren matches it $brackets--; $pos = $+[0], substr( $str, $+[0] - 1, 1 ) = ')', pos($str) = $pos, pop @lbrackets if ( @lbrackets && ( $lbrackets[-1] == $brackets ) ); } elsif ( $1 eq '[' ) { # just an open paren, count it and go on $brackets++; } else { # new function definition, capture its open paren # also uppercase the function name $pos = $+[0]; substr( $str, $-[3], length($3) ) = uc $3; substr( $str, $+[0] - 1, 1 ) = '('; pos($str) = $pos; push @lbrackets, $brackets; $brackets++; } } return $str; } sub undo_math_funcs { my $str = $_[0]; # eliminate recursion while ( $str =~ s/MATH\[([^\]\[]+?)\]/($1)/ ) { } return $str; } # # DAA # need better nested function/parens handling # sub extract_func_args { my ( $self, $value ) = @_; my @final_args = (); my ( $spos, $parens, $epos, $delim ) = ( 0, 0, 0, 0 ); while ( $value =~ m/\G.*?([\(\),])/gcs ) { $epos = $+[0]; $delim = $1; unless ( $parens or ( $delim ne ',' ) ) { push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos - 1 ) ) ); $spos = $epos; next; } unless ( $delim eq ',' ) { $parens += ( $delim eq '(' ) ? 1 : -1; } } # don't forget the last argument if ( $spos != length($value) ) { $epos = length($value); push( @final_args, $self->ROW_VALUE( substr( $value, $spos, $epos - $spos ) ) ); # XXX } return @final_args; } ################################################################### # ROW_VALUE ::= | ################################################################### sub ROW_VALUE { my ( $self, $str ) = @_; $str =~ s/^\s+//; $str =~ s/\s+$//; $str = $self->undo_string_funcs($str); $str = undo_math_funcs($str); my ( $orgstr, $f, $bf ) = ( $str, FUNCTION_NAMES, BAREWORD_FUNCTIONS ); # USER-DEFINED FUNCTION my ( $user_func_name, $user_func_args, $is_func ); # DAA # need better paren check here if ( $str =~ m/^([^\s\(]+)\s*(.*)\s*$/ ) { $user_func_name = $1; $user_func_args = $2; # convert operator-like function to parenthetical format if ( ( $is_func = $self->is_func($user_func_name) ) && ( $user_func_args !~ m/^\(.*\)$/ ) && ( $is_func =~ /^(?:$bf)$/i ) ) { $orgstr = $str = "$user_func_name ($user_func_args)"; } } else { $user_func_name = $str; $user_func_name =~ s/^(\S+).*$/$1/; $user_func_args = ''; $is_func = $self->is_func($user_func_name); } # BLKB # Limiting the parens convert shortcut, so that "SELECT LOG(1), PI" works as a # two functions, and "SELECT x FROM log" works as a table undef $is_func if ( $is_func && $is_func !~ /^(?:$bf)$/i && $str !~ m/^\S+\s*\(.*\)\s*$/ ); if ( $is_func && ( uc($is_func) !~ m/^($f)$/ ) ) { my ( $name, $value ) = ( $user_func_name, '' ); if ( $str =~ m/^(\S+)\s*\((.*)\)\s*$/ ) { $name = $1; $value = $2; $is_func = $self->is_func($name); } if ($is_func) { # # DAA # need a better argument extractor, since it can # contain arbitrary (possibly parenthesized) # expressions/functions # # if ($value =~ /\(/ ) { # $value = $self->ROW_VALUE($value); # } # my @args = split ',',$value; my @final_args = $self->extract_func_args($value); my $usr_sub = $self->{opts}->{function_names}->{$is_func}; $self->{struct}->{procedure} = {}; if ($usr_sub) { $value = { type => 'function', name => lc $name, subname => $usr_sub, value => \@final_args, fullorg => $orgstr, }; return $value; } } } my $type; # MATH # if ( $str =~ m/[\*\+\-\/\%]/ ) { my @vals; my $i = -1; my $open_parens = $str =~ tr/\(//; my $close_parens = $str =~ tr/\)//; if ( $open_parens != $close_parens ) { return $self->do_err("Mismatched parentheses in term '$str'!"); } # $str =~ s/([^\s\*\+\-\/\%\)\(]+)/push @vals,$1;++$i;"?$i?"/ge; while ( $str =~ m/\G.*?([^\s\*\+\-\/\%\)\(]+)/g ) { my $term = $1; my $start = pos($str) - length($term); if ( $self->is_func($term) ) { my $lparens = 0; my $rparens = 0; while ( $str =~ m/\G.*?([\(\)])/gcs ) { ++$lparens if ( '(' eq $1 ); ++$rparens if ( ')' eq $1 ); last if ( $lparens == $rparens ); } my $now = pos($str); ++$i; $term = substr( $str, $start, $now - $start, "?$i?" ); push( @vals, $term ); pos($str) = $start + length("?$i?"); } else { push( @vals, $term ); ++$i; substr( $str, $start, length($term), "?$i?" ); pos($str) = $start + length("?$i?"); } } my @newvalues; foreach my $val (@vals) { my $newval = $self->ROW_VALUE($val); if ( $newval && $newval->{type} !~ m/number|column|placeholder|function/ ) { return $self->do_err(qq[String '$val' not allowed in Numeric expression!]); } push( @newvalues, $newval ); } return { type => 'function', name => 'numeric_exp', str => $str, value => \@newvalues, fullorg => $orgstr, }; } # SUBSTRING (value FROM start [FOR length]) # if ( $str =~ m/^SUBSTRING \((.+?) FROM (.+)\)\s*$/i ) { my $name = 'SUBSTRING'; my $start = $2; my $value = $self->ROW_VALUE($1); my $length; if ( $start =~ /^(.+?) FOR (.+)$/i ) { $start = $1; $length = $2; $length = $self->ROW_VALUE($length); } $start = $self->ROW_VALUE($start); $str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; if ( ( $start->{type} eq 'string' ) or ( $start->{length} && ( $start->{length}->{type} eq 'string' ) ) ) { return $self->do_err("Can't use a string as a SUBSTRING position: '$str'!"); } return undef unless ($value); return $self->do_err("Can't use a number in SUBSTRING: '$str'!") if $value->{type} eq 'number'; return { type => 'function', name => $name, value => [$value], start => $start, length => $length, fullorg => $orgstr, }; } # TRIM ( [ [TRAILING|LEADING|BOTH] ['char'] FROM ] value ) # if ( $str =~ m/^(TRIM) \((.+)\)\s*$/i ) { my $name = uc $1; my $value = $2; my ( $trim_spec, $trim_char ); if ( $value =~ m/^(.+) FROM ([^\(\)]+)$/i ) { my $front = $1; $value = $2; if ( $front =~ m/^\s*(TRAILING|LEADING|BOTH)(.*)$/i ) { $trim_spec = uc $1; $trim_char = $2; $trim_char =~ s/^\s+//; $trim_char =~ s/\s+$//; undef $trim_char if ( length($trim_char) == 0 ); } else { $trim_char = $front; $trim_char =~ s/^\s+//; $trim_char =~ s/\s+$//; } } $trim_char ||= ''; $trim_char =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; $value = $self->ROW_VALUE($value); return undef unless ($value); $str =~ s/\?(\d+)\?/$self->{struct}->{literals}->[$1]/g; my $value_type = $value->{type} if ref $value eq 'HASH'; $value_type = $value->[0] if ( defined( _ARRAY($value) ) ); return $self->do_err("Can't use a number in TRIM: '$str'!") if ( $value_type and $value_type eq 'number' ); return { type => 'function', name => $name, value => [$value], trim_spec => $trim_spec, trim_char => $trim_char, fullorg => $orgstr, }; } # UNKNOWN FUNCTION if ( $str =~ m/^(\S+) \(/ ) { return $self->do_err("Unknown function '$1'"); } # STRING CONCATENATION # if ( $str =~ m/\|\|/ ) { my @vals = split( m/ \|\| /, $str ); my @newvals; for my $val (@vals) { my $newval = $self->ROW_VALUE($val); return undef unless ($newval); return $self->do_err("Can't use a number in string concatenation: '$str'!") if ( $newval->{type} eq 'number' ); push @newvals, $newval; } return { type => 'function', name => 'str_concat', value => \@newvals, fullorg => $orgstr, }; } # NULL, BOOLEAN, PLACEHOLDER, NUMBER # if ( $type = $self->LITERAL($str) ) { undef $str if ( $type eq 'null' ); $str = 1 if ( $type eq 'boolean' and $str =~ /^TRUE$/i ); $str = 0 if ( $type eq 'boolean' and $str =~ /^FALSE$/i ); # if ($type eq 'empty_string') { # $str = ''; # $type = 'string'; # } $str = '' if ( $str and $str eq q('') ); return { type => $type, value => $str, fullorg => $orgstr, }; } # QUOTED STRING LITERAL # if ( $str =~ m/\?(\d+)\?/ ) { return { type => 'string', value => $self->{struct}->{literals}->[$1], fullorg => $self->{struct}->{literals}->[$1], }; } elsif ( $str =~ /^\?LI(\d+)\?$/ ) { return $self->ROW_VALUE_LIST( $self->{struct}->{list_ids}->[$1] ); } # COLUMN NAME # return undef unless ( $str = $self->COLUMN_NAME($str) ); if ( $str =~ m/^(.*)\./ ) { my $table_name = $1; $self->_verify_tablename( $table_name, "WHERE" ); } # push @{ $self->{struct}->{where_cols}},$str # unless $self->{tmp}->{where_cols}->{"$str"}; ++$self->{tmp}->{where_cols}->{$str}; return { type => 'column', value => $str, fullorg => $orgstr, }; } ######################################################### # ROW_VALUE_LIST ::= [,...] ######################################################### sub ROW_VALUE_LIST { my ( $self, $row_str ) = @_; my @row_list = split ',', $row_str; if ( !( scalar @row_list ) ) { return $self->do_err('Missing row value list!'); } my @newvals; my $newval; for my $row_val (@row_list) { $row_val =~ s/^\s+//; $row_val =~ s/\s+$//; return undef if !( $newval = $self->ROW_VALUE($row_val) ); push @newvals, $newval; } return \@newvals; } ############################################### # COLUMN NAME ::= [.] ############################################### sub COLUMN_NAME { my ( $self, $str ) = @_; my ( $table_name, $col_name ); if ( $str =~ m/^\s*(\S+)\.(\S+)$/s ) { ( $table_name, $col_name ) = ( $1, $2 ); if ( !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} ) { return $self->do_err('Dialect does not support multiple tables!'); } return undef unless ( $table_name = $self->TABLE_NAME($table_name) ); $table_name = $self->replace_quoted_ids($table_name); $self->_verify_tablename($table_name); } else { $col_name = $str; } $col_name =~ s/^\s+//; $col_name =~ s/\s+$//; my $user_func = $col_name; $user_func =~ s/^(\S+).*$/$1/; if ( $col_name !~ m/^(TRIM|SUBSTRING)$/i ) { undef $user_func unless ( $self->{opts}->{function_names}->{ uc $user_func } ); } if ( !$user_func ) { return undef unless ( ( $col_name eq '*' ) || $self->IDENTIFIER($col_name) ); } # # MAKE COL NAMES ALL UPPER CASE UNLESS IS DELIMITED IDENTIFIER my $orgcol = $col_name; if ( $col_name =~ m/^\?QI(\d+)\?$/ ) { $col_name = '"' . $self->{struct}->{quoted_ids}->[$1] . '"'; } else { $col_name = lc $col_name unless ( ( $self->{struct}->{command} eq 'CREATE' ) ############################################## # # JZ addition to RR's alias patch # or ( $col_name =~ m/^(?:\p{Word}+\.)?"/ ) ); } # $col_name = $self->{struct}->{column_aliases}->{$col_name} if ( $self->{struct}->{column_aliases}->{$col_name} ); # $orgcol = $self->replace_quoted_ids($orgcol); ############################################## if ($table_name) { my $alias = $self->{tmp}->{is_table_alias}->{"\L$table_name"}; $table_name = $alias if ( defined($alias) ); $table_name = lc $table_name unless ( $table_name =~ m/^"/ ); $col_name = "$table_name.$col_name" if ( -1 == index( $col_name, '.' ) ); } return $col_name; } ######################################################### # COLUMN NAME_LIST ::= [,...] ######################################################### sub COLUMN_NAME_LIST { my ( $self, $col_str ) = @_; my @col_list = split( ',', $col_str ); return $self->do_err('Missing column name list!') unless ( scalar(@col_list) ); my @newcols; for my $col (@col_list) { $col =~ s/^\s+//; $col =~ s/\s+$//; my $newcol; return undef unless ( $newcol = $self->COLUMN_NAME($col) ); push( @newcols, $newcol ); } return \@newcols; } ##################################################### # TABLE_NAME_LIST := [,...] ##################################################### sub TABLE_NAME_LIST { my ( $self, $table_name_str ) = @_; my %aliases = (); my @tables; $table_name_str =~ s/(\?\d+\?),/$1:/g; # fudge commas in functions my @table_names = split ',', $table_name_str; if ( scalar @table_names > 1 and !$self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} ) { return $self->do_err('Dialect does not support multiple tables!'); } my $bf = BAREWORD_FUNCTIONS; my %is_table_alias; for my $table_str (@table_names) { $table_str =~ s/(\?\d+\?):/$1,/g; # unfudge commas in functions $table_str =~ s/\s+\(/\(/g; # fudge spaces in functions my ( $table, $alias ); my (@tstr) = split( m/\s+/, $table_str ); if ( @tstr == 1 ) { $table = $tstr[0]; } elsif ( @tstr == 2 ) { $table = $tstr[0]; $alias = $tstr[1]; } elsif ( @tstr == 3 ) { return $self->do_err("Can't find alias in FROM clause!") unless ( uc( $tstr[1] ) eq 'AS' ); $table = $tstr[0]; $alias = $tstr[2]; } else { return $self->do_err("Can't find table names in FROM clause!"); } $table =~ s/\(/ \(/g; # unfudge spaces in functions my $u_name = $table; $u_name =~ s/^(\S+)\s*(.*$)/$1/; my $u_args = $2; if ( ( $u_name = $self->is_func($u_name) ) && ( $u_name =~ /^(?:$bf)$/i || $table =~ /^$u_name\s*\(/i ) ) { $u_args = " $u_args" if ($u_args); my $u_func = $self->ROW_VALUE( $u_name . $u_args ); $self->{struct}->{table_func}->{$u_name} = $u_func; $self->{struct}->{temp_table} = 1; $table = $u_name; } else { return undef unless ( $self->TABLE_NAME($table) ); } $table = $self->replace_quoted_ids($table); push( @tables, $table =~ m/^"/ ? $table : $table ); if ($alias) { return unless ( $self->TABLE_NAME($alias) ); $alias = $self->replace_quoted_ids($alias); if ( $alias =~ m/^"/ ) { push( @{ $aliases{$table} }, $alias ); $is_table_alias{$alias} = $table; } else { push( @{ $aliases{$table} }, "\L$alias" ); $is_table_alias{"\L$alias"} = $table; } } } my %is_table_name = map { $_ => 1 } @tables; $self->{tmp}->{is_table_alias} = \%is_table_alias; $self->{tmp}->{is_table_name} = \%is_table_name; $self->{struct}->{table_names} = \@tables; $self->{struct}->{table_alias} = \%aliases; $self->{struct}->{multiple_tables} = 1 if ( @tables > 1 ); return 1; } sub is_func($) { my ( $self, $name ) = @_; $name =~ s/^(\S+).*$/$1/; return $name if ( $self->{opts}->{function_names}->{$name} ); return uc $name if ( $self->{opts}->{function_names}->{ uc $name } ); undef; } ############################# # TABLE_NAME := ############################# sub TABLE_NAME { my ( $self, $table_name ) = @_; if ( $table_name =~ m/^(.+?)\.([^\.]+)$/ ) { my $schema = $1; # ignored $table_name = $2; } if ( $table_name =~ m/\s*(\S+)\s+\S+/s ) { return $self->do_err("Junk after table name '$1'!"); } $table_name =~ s/\s+//s; if ( !$table_name ) { return $self->do_err('No table name specified!'); } return $table_name if ( $self->IDENTIFIER($table_name) ); # return undef if !($self->IDENTIFIER($table_name)); # return 1; } sub _verify_tablename { my ( $self, $table_name, $location ) = @_; if ( defined($location) ) { $location = " in $location"; } else { $location = ""; } if ( $table_name =~ m/^"/ ) { if ( !$self->{tmp}->{is_table_name}->{$table_name} and !$self->{tmp}->{is_table_alias}->{$table_name} ) { return $self->do_err("Table '$table_name' referenced$location but not found in FROM list!"); } } else { my @tblnamelist = ( keys( %{ $self->{tmp}->{is_table_name} } ), keys( %{ $self->{tmp}->{is_table_alias} } ) ); my $tblnames = join( "|", @tblnamelist ); unless ( $table_name =~ m/^(?:$tblnames)$/i ) { return $self->do_err( "Table '$table_name' referenced$location but not found in FROM list (" . join( ",", @tblnamelist ) . ")!" ); } } return 1; } ################################################################### # IDENTIFIER ::= { | _ }... # # and must not be a reserved word or over 128 chars in length ################################################################### sub IDENTIFIER { my ( $self, $id ) = @_; if ( $id =~ m/^\?QI(.+)\?$/ or $id =~ m/^\?(.+)\?$/ ) { return 1; } if ( $id =~ m/^(.+)\.([^\.]+)$/ ) { my $schema = $1; # ignored $id = $2; } return 1 if $id =~ m/^".+?"$/s; # QUOTED IDENTIFIER my $err = "Bad table or column name: '$id' "; # BAD CHARS if ( $id =~ /\W/ ) { $err .= "has chars not alphanumeric or underscore!"; return $self->do_err($err); } # CSV requires optional start with _ my $badStartRx = uc( $self->{dialect} ) eq 'ANYDATA' ? qr/^\d/ : qr/^[_\d]/; if ( $id =~ $badStartRx ) { # BAD START $err .= "starts with non-alphabetic character!"; return $self->do_err($err); } if ( length $id > 128 ) { # BAD LENGTH $err .= "contains more than 128 characters!"; return $self->do_err($err); } $id = uc $id; if ( $self->{opts}->{reserved_words}->{$id} ) { # BAD RESERVED WORDS $err .= "is a SQL reserved word!"; return $self->do_err($err); } return 1; } ######################################## # PRIVATE METHODS AND UTILITY FUNCTIONS ######################################## sub order_joins { my ( $self, $links ) = @_; for my $link (@$links) { if ( $link !~ /\./ ) { return []; } } @$links = map { s/^(.+)\..*$/$1/; $1; } @$links; my @all_tables; my %relations; my %is_table; while (@$links) { my $t1 = shift @$links; my $t2 = shift @$links; return undef unless defined $t1 and defined $t2; push @all_tables, $t1 unless $is_table{$t1}++; push @all_tables, $t2 unless $is_table{$t2}++; $relations{$t1}{$t2}++; $relations{$t2}{$t1}++; } my @tables = @all_tables; my @order = shift @tables; my %is_ordered = ( $order[0] => 1 ); my %visited; while (@tables) { my $t = shift @tables; my @rels = keys %{ $relations{$t} }; for my $t2 (@rels) { next unless $is_ordered{$t2}; push @order, $t; $is_ordered{$t}++; last; } if ( !$is_ordered{$t} ) { push @tables, $t if $visited{$t}++ < @all_tables; } } return $self->do_err("Unconnected tables in equijoin statement!") if @order < @all_tables; return \@order; } # PROVIDE BACKWARD COMPATIBILIT FOR JOCHEN'S FEATURE ATTRIBUTES TO NEW # # sub set_feature_flags { my ( $self, $select, $create ) = @_; if ( defined $select ) { delete $self->{select}; $self->{opts}->{valid_options}->{SELECT_MULTIPLE_TABLES} = $self->{opts}->{select}->{join} = $select->{join}; } if ( defined $create ) { delete $self->{create}; for my $key ( keys %$create ) { my $type = $key; $type =~ s/type_(.*)/\U$1/; $self->{opts}->{valid_data_types}->{$type} = $self->{opts}->{create}->{$key} = $create->{$key}; } } } sub clean_sql { my ( $self, $sql ) = @_; my $fields; my $i = -1; my $e = '\\'; $e = quotemeta($e); # # patch from cpan@goess.org, adds support for col2='' # # $sql =~ s~'(([^'$e]|$e.|'')+)'~push(@$fields,$1);$i++;"?$i?"~ge; $sql =~ s~(?do_err("Mismatched single quote before: <$sql>"); } if ( $sql =~ m/\?\?(\d)\?/ ) { $sql = $fields->[$1]; $self->do_err("Mismatched single quote: <$sql>"); } foreach (@$fields) { $_ =~ s/$e'/'/g; s/^'(.*)'$/$1/; } # # From Steffen G. to correctly return newlines from $dbh->quote; # foreach (@$fields) { $_ =~ s/([^\\])\\r/$1\r/g; } foreach (@$fields) { $_ =~ s/([^\\])\\n/$1\n/g; } $self->{struct}->{literals} = $fields; my $qids; $i = -1; $e = q/""/; # $sql =~ s~"(([^"$e]|$e.)+)"~push(@$qids,$1);$i++;"?QI$i?"~ge; $sql =~ s/"(([^"]|"")+)"/push(@$qids,$1);$i++;"?QI$i?"/ge; #@$qids = map { s/$e'/'/g; s/^'(.*)'$/$1/; $_} @$qids; $self->{struct}->{quoted_ids} = $qids if ($qids); # $sql =~ s~'(([^'\\]|\\.)+)'~push(@$fields,$1);$i++;"?$i?"~ge; # @$fields = map { s/\\'/'/g; s/^'(.*)'$/$1/; $_} @$fields; #print "$sql [@$fields]\n";# if $sql =~ /SELECT/; ## before line 1511 my $comment_re = $self->{comment_re}; # if ( $sql =~ s/($comment_re)//gs) { # $self->{comment} = $1; # } if ( $sql =~ m/(.*)$comment_re$/s ) { $sql = $1; $self->{comment} = $2; } if ( $sql =~ m/^(.*)--(.*)(\n|$)/ ) { $sql = $1; $self->{comment} = $2; } $sql =~ s/\n/ /g; $sql =~ s/\s+/ /g; $sql =~ s/(\S)\(/$1 (/g; # ensure whitespace before ( $sql =~ s/\)(\S)/) $1/g; # ensure whitespace after ) $sql =~ s/\(\s*/(/g; # trim whitespace after ( $sql =~ s/\s*\)/)/g; # trim whitespace before ) # # $sql =~ s/\s*\(/(/g; # trim whitespace before ( # $sql =~ s/\)\s*/)/g; # trim whitespace after ) # for my $op (qw(= <> < > <= >= \|\|)) # { # $sql =~ s/(\S)$op/$1 $op/g; # $sql =~ s/$op(\S)/$op $1/g; # } $sql =~ s/(\S)([<>]?=|<>|<|>|\|\|)/$1 $2/g; $sql =~ s/([<>]?=|<>|<|>|\|\|)(\S)/$1 $2/g; $sql =~ s/< >/<>/g; $sql =~ s/< =/<=/g; $sql =~ s/> =/>=/g; $sql =~ s/\s*,/,/g; $sql =~ s/,\s*/,/g; $sql =~ s/^\s+//; $sql =~ s/\s+$//; return $sql; } sub trim { my $str = $_[0] or return (''); $str =~ s/^\s+//; $str =~ s/\s+$//; return $str; } sub do_err { my ( $self, $err, $errstr ) = @_; # $err = $errtype ? "DIALECT ERROR: $err" : "SQL ERROR: $err"; $self->{struct}->{errstr} = $err; carp $err if ( $self->{PrintError} ); croak $err if ( $self->{RaiseError} ); return; } # # DAA # abstract method so subclasses can provide # their own syntax transformations # sub transform_syntax { my ( $self, $str ) = @_; return $str; } sub DESTROY { my $self = $_[0]; undef $self->{opts}; undef $self->{struct}; undef $self->{tmp}; undef $self->{dialect}; undef $self->{dialect_set}; } 1; __END__ =pod =head1 NAME SQL::Parser -- validate and parse SQL strings =head1 SYNOPSIS use SQL::Parser; # CREATE A PARSER OBJECT my $parser = SQL::Parser->new(); $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 =head1 DESCRIPTION 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. B: 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 me. See L for details of the now-deprecated hash method if you still need them. =head1 METHODS =head2 new() Create a new parser object use SQL::Parser; my $parser = SQL::Parser->new(); 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. 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 C parameter is a reference to a hash that can contain error settings for the PrintError and RaiseError attributes. 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. =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 C<$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 compatibility '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. =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 enabled (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 ); # return 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_comparison_operators','LIKE'); See the section below on "Backwards Compatibility" for use of the feature() method with SQL::Statement 0.1x style parameters. =begin undocumented =head2 clean_sql =head2 command =head2 create_op_regexen =head2 do_err =head2 errstr =head2 extract_column_list =head2 extract_func_args =head2 group_ands =head2 is_func =head2 list =head2 non_parens_search =head2 nongroup_numeric =head2 nongroup_string =head2 order_joins =head2 parens_search =head2 parse =head2 repl_btwin =head2 replace_quoted =head2 replace_quoted_commas =head2 replace_quoted_ids =head2 set_feature_flags =head2 structure =head2 transform_concat =head2 trim =head2 transform_syntax =head2 undo_math_funcs =head2 undo_string_funcs =end undocumented =head1 Supported SQL syntax 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 TEMPORARY tables in CREATE are supported by the parser but ignored by the executor. To see the list of Supported SQL syntax formerly kept in this pod, see L. =head1 Subclassing SQL::Parser In the event you need to either extend or modify SQL::Parser's default behavior, the following methods may be overridden: =over =item C<$self->EC Processes the BETWEEN...AND... predicates; default converts to 2 range predicates. =item C<$self->EC Process the IN (...list...) predicates; default converts to a series of OR'd '=' predicate, or AND'd '<>' predicates for NOT IN. =item C<$self->EC Abstract method; default simply returns the original string. Called after repl_btwn() and repl_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 The parse structure This section outlines the B hash interface to the parsed structure. It is included B. You should use the SQL::Statement object interface to the structure instead. See L. B 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 structure. B Once a SQL::Parser object has been created with the new() method, the parse() method can be used to parse any number of SQL strings. It takes a single required parameter -- a string containing a SQL command. The SQL string may optionally be terminated by a semicolon. The parse() method returns a true value if the parse is successful and a false value if the parse finds SQL syntax errors. Examples: 1) my $success = $parser->parse('SELECT * FROM foo'); 2) my $sql = 'SELECT * FROM foo'; my $success = $parser->parse( $sql ); 3) my $success = $parser->parse(qq! SELECT id,phrase FROM foo WHERE id < 7 AND phrase <> 'bar' ORDER BY phrase; !); 4) my $success = $parser->parse('SELECT * FRoOM foo '); In examples #1,#2, and #3, the value of $success will be true because the strings passed to the parse() method are valid SQL strings. In example #4, however, the value of $success will be false because the string contains a SQL syntax error ('FRoOM' instead of 'FROM'). In addition to checking the return value of parse() with a variable like $success, you may use the PrintError and RaiseError attributes as you would in a DBI script: * If PrintError is true, then SQL syntax errors will be sent as warnings to STDERR (i.e. to the screen or to a file if STDERR has been redirected). This is set to true by default which means that unless you specifically turn it off, all errors will be reported. * If RaiseError is true, then SQL syntax errors will cause the script to die, (i.e. the script will terminate unless wrapped in an eval). This is set to false by default which means that unless you specifically turn it on, scripts will continue to operate even if there are SQL syntax errors. Basically, you should leave PrintError on or else you will not be warned when an error occurs. If you are simply validating a series of strings, you will want to leave RaiseError off so that the script can check all strings regardless of whether some of them contain SQL errors. However, if you are going to try to execute the SQL or need to depend that it is correct, you should set RaiseError on so that the program will only continue to operate if all SQL strings use correct syntax. IMPORTANT NOTE #1: The parse() method only checks syntax, it does NOT verify if the objects listed actually exist. For example, given the string "SELECT model FROM cars", the parse() method will report that the string contains valid SQL but that will not tell you whether there actually is a table called "cars" or whether that table contains a column called 'model'. Those kinds of verifications are performed by the SQL::Statement module, not by SQL::Parser by itself. IMPORTANT NOTE #2: The parse() method uses rules as defined by the selected dialect configuration file and the feature() method. This means that a statement that is valid in one dialect may not be valid in another. For example the 'CSV' and 'AnyData' dialects define 'BLOB' as a valid data type but the 'ANSI' dialect does not. Therefore the statement 'CREATE TABLE foo (picture BLOB)' would be valid in the first two dialects but would produce a syntax error in the 'ANSI' dialect. B After a SQL::Parser object has been created and the parse() method used to parse a SQL string, the structure() method returns the data structure of that string. This data structure may be passed on to other modules (e.g. SQL::Statement) or it may be printed out using, for example, the Data::Dumper module. The data structure contains all of the information in the SQL string as parsed into its various components. To take a simple example: $parser->parse('SELECT make,model FROM cars'); use Data::Dumper; print Dumper $parser->structure; Would produce: $VAR1 = { 'column_defs' => [ { 'type' => 'column', 'value' => 'make', }, { 'type' => 'column', 'value' => 'model', }, ], 'command' => 'SELECT', 'table_names' => [ 'cars' ] }; 'SELECT make,model, FROM cars' command => 'SELECT', table_names => [ 'cars' ], column_names => [ 'make', 'model' ], 'CREATE TABLE cars ( id INTEGER, model VARCHAR(40) )' column_defs => { id => { data_type => INTEGER }, model => { data_type => VARCHAR(40) }, }, 'SELECT DISTINCT make FROM cars' set_quantifier => 'DISTINCT', 'SELECT MAX (model) FROM cars' set_function => { name => 'MAX', arg => 'models', }, 'SELECT * FROM cars LIMIT 5,10' limit_clause => { offset => 5, limit => 10, }, 'SELECT * FROM vars ORDER BY make, model DESC' sort_spec_list => [ { make => 'ASC' }, { model => 'DESC' }, ], "INSERT INTO cars VALUES ( 7, 'Chevy', 'Impala' )" values => [ 7, 'Chevy', 'Impala' ], =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc SQL::Parser perldoc SQL::Statement You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head2 Where can I go for help? For questions about installation or usage, please ask on the dbi-users@perl.org mailing list or post a question on PerlMonks (L, where Jeff is known as jZed). Jens does not visit PerlMonks on a regular basis. If you have a bug report, a patch or a suggestion, please open a new report ticket at CPAN (but please check previous reports first in case your issue has already been addressed). You can mail any of the module maintainers, but you are more assured of an answer by posting to the dbi-users list or reporting the issue in RT. Report tickets should contain a detailed description of the bug or enhancement request and at least an easily verifiable way of reproducing the issue or fix. Patches are always welcome, too. =head2 Where can I go for help with a concrete version? Bugs and feature requests are accepted against the latest version only. To get patches for earlier versions, you need to get an agreement with a developer of your choice - who may or not report the the issue and a suggested fix upstream (depends on the license you have chosen). =head2 Business support and maintenance For business support you can contact Jens via his CPAN email address rehsackATcpan.org. Please keep in mind that business support is neither available for free nor are you eligible to receive any support based on the license distributed with this package. =head1 AUTHOR & COPYRIGHT This module is copyright (c) 2001,2005 by Jeff Zucker and copyright (c) 2008,2010 by Jens Rehsack. All rights reserved. The module may be freely distributed under the same terms as Perl itself using either the "GPL License" or the "Artistic License" as specified in the Perl README file. Jeff can be reached at: jzuckerATcpan.org Jens can be reached at: rehsackATcpan.org or via dbi-devATperl.org =cut SQL-Statement-1.407/lib/SQL/Statement/000755 000765 000024 00000000000 12531016333 017236 5ustar00snostaff000000 000000 SQL-Statement-1.407/lib/SQL/Statement.pm000755 000765 000024 00000236100 12531013463 017602 0ustar00snostaff000000 000000 package SQL::Statement; ######################################################################### # # This module is copyright (c), 2001,2005 by Jeff Zucker. # This module is copyright (c), 2007-2010 by Jeff Zucker, Jens Rehsack. # All rights reserved. # # It may be freely distributed under the same terms as Perl itself. # # See below for help (search for SYNOPSIS) ######################################################################### use strict; use warnings FATAL => "all"; use 5.008; use vars qw($VERSION $DEBUG); use SQL::Parser (); use SQL::Eval (); use SQL::Statement::RAM (); use SQL::Statement::TermFactory (); use SQL::Statement::Util (); use Carp qw(carp croak); use Clone qw(clone); use Errno; use Scalar::Util qw(blessed looks_like_number); use List::Util qw(first); use Params::Util qw(_INSTANCE _STRING _ARRAY _ARRAY0 _HASH0 _HASH); #use locale; $VERSION = '1.407'; sub new { my ( $class, $sql, $flags ) = @_; # IF USER DEFINED extend_csv IN SCRIPT # USE THE ANYDATA DIALECT RATHER THAN THE CSV DIALECT # WITH DBD::CSV if ( ( defined($main::extend_csv) && $main::extend_csv ) || ( defined($main::extend_sql) && $main::extend_sql ) ) { $flags = SQL::Parser->new('AnyData'); } my $parser = $flags; my $self = bless( {}, $class ); $flags->{PrintError} = 1 unless defined $flags->{PrintError}; $flags->{text_numbers} = 1 unless defined $flags->{text_numbers}; $flags->{alpha_compare} = 1 unless defined $flags->{alpha_compare}; unless ( blessed($flags) ) # avoid copying stale data from earlier parsing sessions { %$self = ( %$self, %{ clone($flags) } ); } else { $self->{$_} = $flags->{$_} for qw(RaiseError PrintError opts); } $self->{dlm} = '~'; # Dean Arnold improvement to allow better subclassing # if (!ref($parser) or (ref($parser) and ref($parser) !~ /^SQL::Parser/)) { unless ( _INSTANCE( $parser, 'SQL::Parser' ) ) { my $parser_dialect = $flags->{dialect} || 'AnyData'; $parser_dialect = 'AnyData' if ( $parser_dialect =~ m/^(?:CSV|Excel)$/ ); $parser = SQL::Parser->new( $parser_dialect, $flags ); } $self->{termFactory} = SQL::Statement::TermFactory->new($self); $self->{capabilities} = {}; $self->prepare( $sql, $parser ); return $self; } sub prepare { my ( $self, $sql, $parser ) = @_; $self->{already_prepared}->{$sql} and return; # delete earlier preparations, they're overwritten after this prepare run $self->{already_prepared} = {}; my $rv = $parser->parse($sql); if ($rv) { undef $self->{errstr}; my $parser_struct = clone( $parser->{struct} ); while ( my ( $k, $v ) = each( %{$parser_struct} ) ) { $self->{$k} = $v; } undef $self->{where_terms}; # force rebuild when needed undef $self->{columns}; undef $self->{splitted_all_cols}; $self->{argnum} = 0; my $values = $self->{values}; my $param_num = -1; if ( $self->{limit_clause} ) { $self->{limit_clause} = SQL::Statement::Limit->new( $self->{limit_clause} ); } if ( defined( $self->{num_placeholders} ) ) { for my $i ( 0 .. $self->{num_placeholders} - 1 ) { $self->{params}->[$i] = SQL::Statement::Param->new($i); } } $self->{tables} = [ map { SQL::Statement::Table->new($_) } @{ $self->{table_names} } ]; if ( $self->{where_clause} && !defined( $self->{where_terms} ) ) { $self->{where_terms} = $self->{termFactory}->buildCondition( $self->{where_clause} ); #if ( $self->{where_clause}->{combiners} ) #{ # $self->{has_OR} = 1 # if ( first { -1 != index( $_, 'OR' ) } @{ $self->{where_clause}->{combiners} } ); #} } ++$self->{already_prepared}->{$sql}; return $self; } else { $self->{errstr} = $parser->errstr; ++$self->{already_prepared}->{$sql}; return; } } sub execute { my ( $self, $data, $params ) = @_; ( $self->{NUM_OF_ROWS}, $self->{NUM_OF_FIELDS}, $self->{data} ) = ( 0, 0, [] ) and return 'OEO' if ( $self->{no_execute} ); $self->{procedure}->{data} = $data if ( $self->{procedure} ); $self->{params} = $params; my ($command) = $self->command(); return $self->do_err('No command found!') unless ($command); $self->{where_clause} and !defined( $self->{where_terms} ) and $self->{where_terms} = $self->{termFactory}->buildCondition( $self->{where_clause} ); ( $self->{NUM_OF_ROWS}, $self->{NUM_OF_FIELDS}, $self->{data} ) = $self->$command( $data, $params ); $self->{NAME} = _ARRAY0( $self->{columns} ) ? [ map { delete $_->{term}->{fastpath}; $_->display_name() } @{ $self->{columns} } ] : []; # Force closing the tables $self->{tables} = [ map { SQL::Statement::Table->new($_->{name}) } @{ delete $self->{tables} } ]; # create keen defs undef $self->{where_terms}; # force rebuild when needed return unless ( defined( $self->{NUM_OF_ROWS} ) ); return $self->{NUM_OF_ROWS} || '0E0'; } sub CREATE ($$$) { my ( $self, $data, $params ) = @_; my $names; # CREATE TABLE AS ... my $subquery = $self->{subquery}; if ($subquery) { my $sth; # AS IMPORT if ( $subquery =~ m/^IMPORT/i ) { $sth = $data->{Database}->prepare("SELECT * FROM $subquery") or return $self->do_err( $data->{Database}->errstr() ); $sth->execute(@$params) or return $self->do_err( $sth->errstr() ); $names = $sth->{NAME}; } # AS SELECT else { $sth = $data->{Database}->prepare($subquery) or return $self->do_err( $data->{Database}->errstr() ); $sth->execute() or return $self->do_err( $sth->errstr() ); $names = $sth->{NAME}; } $names = $sth->{NAME} unless defined $names; my $tbl_data = $sth->{sql_stmt}->{data}; my $tbl_name = $self->{org_table_names}->[0] || $self->tables(0)->name; # my @tbl_cols = map {$_->name} $sth->{sql_stmt}->columns; #my @tbl_cols=map{$_->name} $sth->{sql_stmt}->columns if $sth->{sql_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} ); my @coldefs = map { "'$_' TEXT" } @tbl_cols; $create_sql .= '(' . join( ',', @coldefs ) . ')'; $data->{Database}->do($create_sql) or die "Can't do <$create_sql>: " . $data->{Database}->errstr; my $colstr = ('?,') x @tbl_cols; my $insert_sql = "INSERT INTO $tbl_name VALUES($colstr)"; my $local_sth = $data->{Database}->prepare($insert_sql); $local_sth->execute(@$_) for @$tbl_data; return ( 0, 0 ); } my ( $eval, $foo ) = $self->open_tables( $data, 1, 1 ); return unless ($eval); $eval->params($params); my ( $row, $table, $col ) = ( [], $eval->table( $self->tables(0)->name() ) ); if ( _ARRAY( $table->col_names() ) ) { return $self->do_err( "Table '" . $self->tables(0)->name() . "' already exists." ); } foreach $col ( $self->columns() ) { push( @{$row}, $col->name() ); } $table->push_names( $data, $row ); return ( 0, 0 ); } sub CALL { my ( $self, $data, $params ) = @_; # my $dbh = $data->{Database}; # $self->{procedure}->{data} = $data; my $procTerm = $self->{termFactory}->buildCondition( $self->{procedure} ); ( $self->{NUM_OF_ROWS}, $self->{NUM_OF_FIELDS}, $self->{data} ) = $procTerm->value($data); } my $enoentstr = "Cannot open .*\(" . Errno::ENOENT . "\)"; my $eabstrstr = "Abstract method .*::open_table called"; my $notblrx = qr/(?:$enoentstr|$eabstrstr)/; sub DROP ($$$) { my ( $self, $data, $params ) = @_; my $eval; my @err; eval { local $SIG{__WARN__} = sub { push @err, @_ }; ($eval) = $self->open_tables( $data, 0, 1 ); }; if ( $self->{ignore_missing_table} and ( $@ or @err or $self->{errstr} ) and grep { $_ =~ $notblrx } ( @err, $@, $self->{errstr} ) ) { return ( -1, 0 ); } return if $self->{errstr}; return $self->do_err( $@ || $err[0] ) if ( $@ || @err ); # return undef unless $eval; return ( -1, 0 ) unless $eval; # $eval->params($params); my ($table) = $eval->table( $self->tables(0)->name() ); $table->drop($data); #use mylibs; zwarn $self->{sql_stmt}; return ( -1, 0 ); } sub INSERT ($$$) { my ( $self, $data, $params ) = @_; my ( $eval, $all_cols ) = $self->open_tables( $data, 0, 1 ); return unless ($eval); $params and $eval->params($params); $self->verify_columns( $data, $eval, $all_cols ) if ( scalar( $self->columns() ) ); return if ( $self->{errstr} ); my ($table) = $eval->table( $self->tables(0)->name() ); $table->seek( $data, 0, 2 ) unless ( $table->capability('insert_new_row') ); my ( $val, $col, $i, $k ); my ($cNum) = scalar( $self->columns() ); my $param_num = 0; $cNum or return $self->do_err("Bad col names in INSERT"); my $maxCol = $#$all_cols; # INSERT INTO $table (row, ...) VALUES (value, ...), (...) for ( $k = 0; $k < scalar( @{ $self->{values} } ); ++$k ) { my ($array) = []; for ( $i = 0; $i < $cNum; $i++ ) { $col = $self->columns($i); $val = $self->row_values( $k, $i ); if ( defined( _INSTANCE( $val, 'SQL::Statement::Param' ) ) ) { $val = $eval->param( $val->idx() ); } elsif ( defined( _INSTANCE( $val, 'SQL::Statement::Term' ) ) ) { $val = $val->value($eval); } elsif ( $val and $val->{type} eq 'placeholder' ) { $val = $eval->param( $param_num++ ); } elsif ( defined( _HASH($val) ) ) { $val = $self->{termFactory}->buildCondition($val); $val = $val->value($eval); } else { return $self->do_err('Internal error: Unexpected column type'); } $array->[ $table->column_num( $col->name() ) ] = $val; } # Extend row to put values in ALL fields $#$array < $maxCol and $array->[$maxCol] = undef; $table->capability('insert_new_row') ? $table->insert_new_row( $data, $array ) : $table->push_row( $data, $array ); } return ( $k, 0 ); } sub DELETE ($$$) { my ( $self, $data, $params ) = @_; my ( $eval, $all_cols ) = $self->open_tables( $data, 0, 1 ); return unless $eval; $eval->params($params); $self->verify_columns( $data, $eval, $all_cols ); return if ( $self->{errstr} ); my $tname = $self->tables(0)->name(); my ($table) = $eval->table($tname); my $affected = 0; my ( @rows, $array ); while ( $array = $table->fetch_row($data) ) { if ( $self->eval_where( $eval, $tname, $array ) ) { ++$affected; if ( $table->capability('rowwise_delete') and $table->capability('inplace_delete') ) { if ( $table->capability('delete_one_row') ) { $table->delete_one_row( $data, $array ); } elsif ( $table->capability('delete_current_row') ) { $table->delete_current_row( $data, $array ); } } elsif ( $table->capability('rowwise_delete') ) { push( @rows, $array ); } next; } push( @rows, $array ) unless ( $table->capability('rowwise_delete') ); } if ($affected) { if ( $table->capability('rowwise_delete') ) { # @rows is empty in case of inplace_delete capability foreach my $array (@rows) { $table->delete_one_row( $data, $array ); } } else { # rewrite table without deleted elements $table->seek( $data, 0, 0 ); foreach my $array (@rows) { $table->push_row( $data, $array ); } $table->truncate($data); } } return ( $affected, 0 ); } sub UPDATE ($$$) { my ( $self, $data, $params ) = @_; my ( $eval, $all_cols ) = $self->open_tables( $data, 0, 1 ); return unless $eval; my $valnum = $self->{num_val_placeholders}; my @val_params = splice( @{$params}, 0, $valnum ) if ($valnum); $self->{params} ||= $params; $eval->params($params); $self->verify_columns( $data, $eval, $all_cols ); return if ( $self->{errstr} ); my $tname = $self->tables(0)->name(); my ($table) = $eval->table($tname); my $affected = 0; my @rows; while ( my $array = $table->fetch_row($data) ) { my $originalValues; if ( $self->eval_where( $eval, $tname, $array ) ) { my $valpos = 0; if ( $table->capability('update_specific_row') ) { $originalValues = clone($array); } for ( my $i = 0; $i < $self->columns(); $i++ ) { my $val = $self->row_values( 0, $i ); if ( defined( _INSTANCE( $val, 'SQL::Statement::Param' ) ) ) { $val = $val_params[ $valpos++ ]; } elsif ( defined( _INSTANCE( $val, 'SQL::Statement::Term' ) ) ) { $val = $val->value($eval); } elsif ( $val and $val->{type} eq 'placeholder' ) { $val = $val_params[ $valpos++ ]; } elsif ( defined( _HASH($val) ) ) { $val = $self->{termFactory}->buildCondition($val); $val = $val->value($eval); } else { return $self->do_err('Internal error: Unexpected column type'); } my $col = $self->columns($i); $array->[ $table->column_num( $col->name() ) ] = $val; } ++$affected; if ( $table->capability('rowwise_update') and $table->capability('inplace_update') ) { # Martin Fabiani : # the following block is the most important enhancement to SQL::Statement::UPDATE if ( $table->capability('update_specific_row') ) { $table->update_specific_row( $data, $array, $originalValues ); } elsif ( $table->capability('update_one_row') ) { # NOTE: this prevents from updating index keys $table->update_one_row( $data, $array ); } elsif ( $table->capability('update_current_row') ) { $table->update_current_row( $data, $array ); } } elsif ( $table->capability('rowwise_update') ) { push( @rows, $array ) unless ( $table->capability('update_specific_row') ); push( @rows, [ $array, $originalValues ] ) if ( $table->capability('update_specific_row') ); } } push( @rows, $array ) unless ( $table->capability('rowwise_update') ); } if ($affected) { if ( $table->capability('rowwise_update') ) { # @rows is empty in case of inplace_update capability foreach my $array (@rows) { if ( $table->capability('update_specific_row') ) { $table->update_specific_row( $data, $array->[0], $array->[1] ); } elsif ( $table->capability('update_one_row') ) { $table->update_one_row( $data, $array ); } } } else { # rewrite table with updated elements $table->seek( $data, 0, 0 ); foreach my $array (@rows) { $table->push_row( $data, $array ); } $table->truncate($data); } } return ( $affected, 0 ); } sub find_join_columns { my ( $self, @all_cols ) = @_; my $display_combine = 'NAMED'; $display_combine = 'NATURAL' if ( -1 != index( $self->{join}->{type}, 'NATURAL' ) ); $display_combine = 'USING' if ( -1 != index( $self->{join}->{clause}, 'USING' ) ); my @display_cols; my @keycols = (); @keycols = @{ $self->{join}->{keycols} } if $self->{join}->{keycols}; foreach (@keycols) { $_ =~ s/\./$self->{dlm}/ } my %is_key_col; %is_key_col = map { $_ => 1 } @keycols; # IF NAMED COLUMNS, USE NAMED COLUMNS # if ( $display_combine eq 'NAMED' ) { @display_cols = $self->columns(); # # DAA # need to get to $self's table objects to get the name # # @display_cols = map {$_->table . $self->{dlm} . $_->name} @display_cols; # @display_cols = map {$_->table->{NAME} . $self->{dlm} . $_->name} @display_cols; my @tbls = $self->tables(); my %tables = (); $tables{ $_->name() } = $_ foreach (@tbls); foreach ( 0 .. $#display_cols ) { $display_cols[$_] = ( $display_cols[$_]->table() ? $tables{ $display_cols[$_]->table() }->name() : '' ) . $self->{dlm} . $display_cols[$_]->name(); } } # IF ASTERISKED COLUMNS AND NOT NATURAL OR USING # USE ALL COLUMNS, IN ORDER OF NAMING OF TABLES # elsif ( $display_combine eq 'NONE' ) { @display_cols = @all_cols; } # IF NATURAL, COMBINE ALL SHARED COLUMNS # IF USING, COMBINE ALL KEY COLUMNS # else { my %is_natural; for my $full_col (@all_cols) { my ( $table, $col ) = $full_col =~ m/^([^$self->{dlm}]+)$self->{dlm}(.+)$/; next if ( ( $display_combine eq 'NATURAL' ) and $is_natural{$col} ); next if ( ( $display_combine eq 'USING' ) && $is_natural{$col} && $is_key_col{$col} ); push( @display_cols, $full_col ); $is_natural{$col}++; } } my @shared = (); my %is_shared; if ( $self->{join}->{type} =~ m/NATURAL/ ) { for my $full_col (@all_cols) { my ( $table, $col ) = $full_col =~ m/^([^$self->{dlm}]+)$self->{dlm}(.+)$/; push( @shared, $col ) if ( $is_shared{$col}++ ); # using side-effect of post-inc } } else { @shared = @keycols; } $self->{join}->{shared_cols} = \@shared; $self->{join}->{display_cols} = \@display_cols; } sub JOIN { my ( $self, $data, $params ) = @_; my ( $eval, $all_cols ) = $self->open_tables( $data, 0, 0 ); return undef unless $eval; $eval->params($params); $self->verify_columns( $data, $eval, $all_cols ); return if ( $self->{errstr} ); if ( $self->{join}->{keycols} and $self->{join}->{table_order} and ( scalar( @{ $self->{join}->{table_order} } ) == 0 ) ) { $self->{join}->{table_order} = $self->order_joins( $self->{join}->{keycols} ); $self->{join}->{table_order} = $self->{table_names} unless ( defined( $self->{join}->{table_order} ) ); } my @tables = $self->tables; # GET THE LIST OF QUALIFIED COLUMN NAMES FOR DISPLAY # *IN ORDER BY NAMING OF TABLES* # my @all_cols; for my $table (@tables) { my @cols = @{ $eval->table( $table->{name} )->col_names }; for my $col (@cols) { push( @all_cols, $table->{name} . $self->{dlm} . $col ); } } $self->find_join_columns(@all_cols); # JOIN THE TABLES # *IN ORDER *BY JOINS* # @tables = @{ $self->{join}->{table_order} } if ( $self->{join}->{table_order} ); my ( $tableA, $tableB ) = splice( @tables, 0, 2 ); $tableA = $tableA->{name} if ( ref($tableA) ); $tableB = $tableB->{name} if ( ref($tableB) ); my ( $tableAobj, $tableBobj ) = ( $eval->table($tableA), $eval->table($tableB) ); $tableAobj->{NAME} ||= $tableA; $tableBobj->{NAME} ||= $tableB; $self->join_2_tables( $data, $params, $tableAobj, $tableBobj ); for my $next_table (@tables) { $tableAobj = $self->{join}->{table}; $tableBobj = $eval->table($next_table); $tableBobj->{NAME} ||= $next_table; $self->join_2_tables( $data, $params, $tableAobj, $tableBobj ); $self->{cur_table} = $next_table; } return $self->SELECT( $data, $params ); } sub join_2_tables { my ( $self, $data, $params, $tableAobj, $tableBobj ) = @_; my $share_type = 'IMPLICIT'; $share_type = 'NATURAL' if ( -1 != index( $self->{join}->{type}, 'NATURAL' ) ); $share_type = 'USING' if ( -1 != index( $self->{join}->{clause}, 'USING' ) ); $share_type = 'ON' if ( -1 != index( $self->{join}->{clause}, 'ON' ) ); $share_type = 'USING' if ( ( $share_type eq 'ON' ) && ( scalar( @{ $self->{join}->{keycols} } ) == 1 ) ); my $join_type = 'INNER'; $join_type = 'LEFT' if ( -1 != index( $self->{join}->{type}, 'LEFT' ) ); $join_type = 'RIGHT' if ( -1 != index( $self->{join}->{type}, 'RIGHT' ) ); $join_type = 'FULL' if ( -1 != index( $self->{join}->{type}, 'FULL' ) ); my $right_join = $join_type eq 'RIGHT'; if ($right_join) { my $tmpTbl = $tableAobj; $tableAobj = $tableBobj; $tableBobj = $tmpTbl; } my $tableA = $tableAobj->{NAME}; ( 0 != index( $tableA, '"' ) ) and $tableA = lc $tableA; my $tableB = $tableBobj->{NAME}; ( 0 != index( $tableB, '"' ) ) and $tableB = lc $tableB; my @colsA = @{ $tableAobj->col_names() }; my @colsB = @{ $tableBobj->col_names() }; my ( %isunqualA, %isunqualB, @shared_cols ); $isunqualB{ $colsB[$_] } = 1 for ( 0 .. $#colsB ); my @tmpshared = @{ $self->{join}->{shared_cols} }; if ( $share_type eq 'ON' ) { $right_join and @tmpshared = reverse @tmpshared; } elsif ( $share_type eq 'USING' ) { foreach my $c (@tmpshared) { substr( $c, 0, index( $c, $self->{dlm} ) + 1 ) = ''; push( @shared_cols, $tableA . $self->{dlm} . $c ); push( @shared_cols, $tableB . $self->{dlm} . $c ); } } elsif ( $share_type eq 'NATURAL' ) { for my $c (@colsA) { if ( $tableA eq $self->{dlm} . 'tmp' ) { substr( $c, 0, index( $c, $self->{dlm} ) + 1 ) = ''; } if ( $isunqualB{$c} ) { push( @shared_cols, $tableA . $self->{dlm} . $c ); push( @shared_cols, $tableB . $self->{dlm} . $c ); } } } my %whichqual; if ( $share_type eq 'ON' || $share_type eq 'IMPLICIT' ) { foreach my $colb (@colsB) { $colb = $whichqual{$colb} = $tableB . $self->{dlm} . $colb; } } else { @colsB = map { $tableB . $self->{dlm} . $_ } @colsB; } my @all_cols = map { $tableA . $self->{dlm} . $_ } @colsA; @all_cols = $right_join ? ( @colsB, @all_cols ) : ( @all_cols, @colsB ); { my $str = $self->{dlm} . "tmp" . $self->{dlm}; foreach (@all_cols) { my $pos = index( $_, $str ); $pos >= 0 and substr( $_, $pos, length($str) ) = ''; } } if ( $tableA eq $self->{dlm} . 'tmp' ) { foreach my $colA (@colsA) { my $c = substr( $colA, index( $colA, $self->{dlm} ) + 1 ); $isunqualA{$c} = $colA; } #%isunqualA = # map { my ($c) = $_ =~ m/^(?:[^$self->{dlm}]+)$self->{dlm}(.+)$/; $c => $_ } @colsA; } else { foreach my $cola (@colsA) { $cola = $isunqualA{$cola} = $tableA . $self->{dlm} . $cola; } } my ( %col_numsA, %col_numsB ); $col_numsA{ $colsA[$_] } = $_ for ( 0 .. $#colsA ); $col_numsB{ $colsB[$_] } = $_ for ( 0 .. $#colsB ); if ( $share_type eq 'ON' || $share_type eq 'IMPLICIT' ) { %whichqual = ( %whichqual, %isunqualA ); while (@tmpshared) { my ( $k1, $k2 ) = splice( @tmpshared, 0, 2 ); # if both keys are in one table, bail out - FIXME: errmsg? next if ( $isunqualA{$k1} && $isunqualA{$k2} ); next if ( $isunqualB{$k1} && $isunqualB{$k2} ); defined( $whichqual{$k1} ) and $k1 = $whichqual{$k1}; defined( $whichqual{$k2} ) and $k2 = $whichqual{$k2}; if ( defined( $col_numsA{$k1} ) && defined( $col_numsB{$k2} ) ) { push( @shared_cols, $k1, $k2 ); } elsif ( defined( $col_numsA{$k2} ) && defined( $col_numsB{$k1} ) ) { push( @shared_cols, $k2, $k1 ); } } } my %is_shared; for my $c (@shared_cols) { $is_shared{$c} = 1; defined( $col_numsA{$c} ) or defined( $col_numsB{$c} ) or return $self->do_err("Can't find shared columns!"); } my ( $posA, $posB ) = ( [], [] ); for my $f (@shared_cols) { defined( $col_numsA{$f} ) and push( @{$posA}, $col_numsA{$f} ); defined( $col_numsB{$f} ) and push( @{$posB}, $col_numsB{$f} ); } my $is_inner_join = $join_type eq "INNER"; #use mylibs; zwarn $self->{join}; # CYCLE THROUGH TABLE B, CREATING A HASH OF ITS VALUES # my $hashB = {}; TBLBFETCH: while ( my $array = $tableBobj->fetch_row($data) ) { my @key_vals = @$array[@$posB]; if ($is_inner_join) { defined($_) or next TBLBFETCH for (@key_vals); } my $hashkey = join( ' ', @key_vals ); push( @{ $hashB->{$hashkey} }, $array ); } # CYCLE THROUGH TABLE A # my $blankRow; my $joined_table = []; my %visited; TBLAFETCH: while ( my $arrayA = $tableAobj->fetch_row($data) ) # use tbl1st & tbl2nd { my @key_vals = @$arrayA[@$posA]; if ($is_inner_join) { defined($_) or next TBLAFETCH for (@key_vals); } my $hashkey = join( ' ', @key_vals ); my $rowsB = $hashB->{$hashkey}; if ( !defined($rowsB) && ( $join_type ne 'INNER' ) ) { defined($blankRow) or $blankRow = [ (undef) x scalar(@colsB) ]; $rowsB = [$blankRow]; } if ( $join_type ne 'UNION' ) { for my $arrayB ( @{$rowsB} ) { my $newRow = $right_join ? [ @{$arrayB}, @{$arrayA} ] : [ @{$arrayA}, @{$arrayB} ]; push( @$joined_table, $newRow ); } } ++$visited{$hashkey}; } # ADD THE LEFTOVER B ROWS IF NEEDED # if ( $join_type eq 'FULL' || $join_type eq 'UNION' ) { my $st_is_NaturalOrUsing = ( -1 != index( $self->{join}->{type}, 'NATURAL' ) ) || ( -1 != index( $self->{join}->{clause}, 'USING' ) ); while ( my ( $k, $v ) = each %{$hashB} ) { next if ( $visited{$k} ); for my $rowB (@$v) { my ( @arrayA, @tmpB, $rowhash ); @{$rowhash}{@colsB} = @{$rowB}; for my $c (@all_cols) { my ( $table, $col ) = split( $self->{dlm}, $c, 2 ); push( @arrayA, undef ) if ( $table eq $tableA ); push( @tmpB, $rowhash->{$c} ) if ( $table eq $tableB ); } @arrayA[@$posA] = @tmpB[@$posB] if ($st_is_NaturalOrUsing); my $newRow = [ @arrayA, @tmpB ]; push( @{$joined_table}, $newRow ); } } } undef $hashB; undef $tableAobj; undef $tableBobj; $self->{join}->{table} = SQL::Statement::TempTable->new( $self->{dlm} . 'tmp', \@all_cols, $self->{join}->{display_cols}, $joined_table ); return; } sub run_functions { my ( $self, $data, $params ) = @_; my ( $eval, $all_cols ) = $self->open_tables( $data, 0, 0 ); my @row = (); for my $col ( $self->columns() ) { my $val = $col->value($eval); # FIXME approve push( @row, $val ); } return ( 1, scalar @row, [ \@row ] ); } sub SELECT($$) { my ( $self, $data, $params ) = @_; $self->{params} ||= $params; defined( _ARRAY( $self->{table_names} ) ) or return $self->run_functions( $data, $params ); my ( $eval, $all_cols, $tableName, $table ); if ( defined( $self->{join} ) ) { defined $self->{join}->{table} or return $self->JOIN( $data, $params ); $tableName = $self->{dlm} . 'tmp'; $table = $self->{join}->{table}; } else { ( $eval, $all_cols ) = $self->open_tables( $data, 0, 0 ); return unless $eval; $eval->params($params); $self->verify_columns( $data, $eval, $all_cols ); return if ( $self->{errstr} ); $tableName = $self->tables(0)->name(); $table = $eval->table($tableName); } my $rows = []; # In a loop, build the list of columns to retrieve; this will be # used both for fetching data and ordering. my ( $cList, $col, $tbl, $ar, $i, $c ); my $numFields = 0; my %columns; my @names; my %funcs = (); # # DAA # # lets just disable this and see where it leads... # # if ($self->{join}) { # @names = @{ $table->col_names }; # for my $col(@names) { # $columns{$tableName}->{"$col"} = $numFields++; # push(@$cList, $table->column_num($col)); # } # } # else { foreach my $column ( $self->columns() ) { if ( _INSTANCE( $column, 'SQL::Statement::Param' ) ) { my $val = $eval->param( $column->idx() ); if ( -1 != ( my $idx = index( $val, '.' ) ) ) { $col = substr( $val, 0, $idx ); $tbl = substr( $val, $idx + 1 ); } else { $col = $val; $tbl = $tableName; } $tbl ||= ''; $columns{$tbl}->{$col} = $numFields++; } else { ( $col, $tbl ) = ( $column->name(), $column->table() ); $tbl ||= ''; $columns{$tbl}->{ $column->display_name() } = $columns{$tbl}->{$col} = $numFields++; } # # handle functions in select list # # DAA # # check for a join temp table; if so, check if we can locate # the column in its delimited set # my $cnum = ( ( $tableName eq ( $self->{dlm} . 'tmp' ) ) && ( $tbl ne '' ) ) ? $table->column_num( $tbl . $self->{dlm} . $col ) : $table->column_num($col); if ( !defined $cnum || $column->{function} ) { $funcs{$col} = $column->{function}; $cnum = $col; } push( @$cList, $cnum ); # push(@$cList, $table->column_num($col)); push( @names, $col ); } # } $cList = [] unless ( defined($cList) ); if ( $self->{join} ) { foreach (@names) { $_ =~ s/^[^$self->{dlm}]+$self->{dlm}//; } } $self->{NAME} = \@names; # $self->verify_order_cols($table); my @order_by = $self->order(); my @extraSortCols = (); if (@order_by) { my $nFields = $numFields; # It is possible that the user gave an ORDER BY clause with columns # that are not part of $cList yet. These columns will need to be # present in the array of arrays for sorting, but will be stripped # off later. my $i = -1; foreach my $column (@order_by) { ++$i; ( $col, $tbl ) = ( $column->column(), $column->table() ); my $pos; $tbl ||= $self->colname2table($col); $tbl ||= ''; if ( $self->{join} ) { $pos = $table->column_num( $tbl . $self->{dlm} . $col ); defined($pos) or $pos = $table->column_num( $tbl . '_' . $col ); } next if ( exists( $columns{$tbl}->{$col} ) ); $pos = $table->column_num($col) unless ( defined($pos) ); push( @extraSortCols, $pos ); $columns{$tbl}->{$col} = $nFields++; } } my $e = $self->{join} ? $table : $eval; # begin count for limiting if there's a limit clause and no order clause # my $limit_count = 0 if ( $self->limit() and !$self->order() ); my $limit = $self->limit(); my $row_count = 0; my $offset = $self->offset() || 0; while ( my $array = $table->fetch_row($data) ) { if ( $self->eval_where( $e, $tableName, $array, \%funcs ) ) { next if ( defined($limit_count) and ( $row_count++ < $offset ) ); my @row = map { $_->value($e) } $self->columns(); push( @{$rows}, \@row ); # We quit here if there's a limit clause without order clause # and the limit has been reached defined($limit_count) and ( ++$limit_count >= $limit ) and return ( $limit, $numFields, $rows ); } } if ( $self->distinct() ) { my %seen; @{$rows} = map { $seen{ join( "\0", ( map { defined($_) ? $_ : '' } @{$_} ) ) }++ ? () : $_ } @{$rows}; } if ( $self->{has_set_functions} ) { my $aggreg; if ( $self->{group_by} ) { my @keycols = @{ $self->{colpos} }{ @{ $self->{group_by} } }; $aggreg = SQL::Statement::Group->new( $self, $rows, \@keycols ); } else { $aggreg = SQL::Statement::Aggregate->new( $self, $rows ); } $rows = $aggreg->calc(); # FIXME re-order if order_by } if (@order_by) { use sort 'stable'; my @sortCols = map { my ( $col, $tbl ) = ( $_->column(), $_->table() ); $self->{join} and $table->is_shared($col) and $tbl = 'shared'; $tbl ||= $self->colname2table($col) || ''; ( $columns{$tbl}->{$col}, $_->desc() ) } @order_by; $i = scalar(@sortCols); do { my $desc = $sortCols[ --$i ]; my $colNum = $sortCols[ --$i ]; @{$rows} = sort { my $result; $result = _anycmp( $a->[$colNum], $b->[$colNum] ); $desc and $result = -$result; $result; } @{$rows}; } while ( $i > 0 ); use sort 'defaults'; # for perl < 5.10.0 } if ( defined( $self->limit() ) ) { my $offset = $self->offset() || 0; my $limit = $self->limit() || 0; @{$rows} = splice( @{$rows}, $offset, $limit ); } # Rip off columns that have been added for @extraSortCols only if (@extraSortCols) { foreach my $row ( @{$rows} ) { splice( @{$row}, $numFields, scalar(@extraSortCols) ); } } ( scalar( @{$rows} ), $numFields, $rows ); } sub _anycmp($$;$) { my ( $a, $b, $case_fold ) = @_; if ( !defined($a) || !defined($b) ) { return defined($a) - defined($b); } elsif ( looks_like_number($a) && looks_like_number($b) ) { return $a <=> $b; } else { return $case_fold ? lc($a) cmp lc($b) || $a cmp $b : $a cmp $b; } } sub eval_where { my ( $self, $eval, $tname, $rowary ) = @_; return 1 unless ( defined( $self->{where_terms} ) ); $self->{argnum} = 0; return $self->{where_terms}->value($eval); } sub fetch_row { my ($self) = @_; $self->{data} ||= []; my $row = shift @{ $self->{data} }; return unless $row and scalar @$row; return $row; } no warnings 'once'; *fetch = \&fetch_row; use warnings; sub fetch_rows { my $self = $_[0]; my $rows = $self->{data} || []; $self->{data} = []; return $rows; } sub open_table ($$$$$) { croak "Abstract method " . ref( $_[0] ) . "::open_table called" } sub open_tables { my ( $self, $data, $createMode, $lockMode ) = @_; my @c; my $t = {}; my @tables = $self->tables(); my $count = -1; for my $tbl (@tables) { ++$count; my $name = $tbl->name(); if ( $name =~ m/^(.+)\.([^\.]+)$/ ) { my $schema = $1; # ignored $name = $tbl->{name} = $2; } if ( defined( $self->{table_func} ) && defined( $self->{table_func}->{ uc $name } ) ) { my $u_func = $self->{table_func}->{ uc $name }; $t->{$name} = $self->get_user_func_table( $name, $u_func ); } elsif (defined( $data->{Database}->{sql_ram_tables} ) && defined( $data->{Database}->{sql_ram_tables}->{$name} ) && $data->{Database}->{sql_ram_tables}->{$name} ) { $t->{$name} = $data->{Database}->{sql_ram_tables}->{$name}; $t->{$name}->seek( $data, 0, 0 ); $t->{$name}->init_table( $data, $name, $createMode, $lockMode ) if ( $t->{$name}->can('init_table') ); } elsif ( $self->{is_ram_table} ) { $t->{$name} = $data->{Database}->{sql_ram_tables}->{$name} = SQL::Statement::RAM::Table->new( $name, [], [] ); } else { undef $@; eval { my $open_name = $self->{org_table_names}->[$count]; $t->{$name} = $self->open_table( $data, $open_name, $createMode, $lockMode ); }; my $err = $t->{$name}->{errstr}; return $self->do_err($err) if ($err); return $self->do_err($@) if ($@); } my @cnames; my $table_cols = $t->{$name}->{org_col_names}; $table_cols = $t->{$name}->{col_names} unless $table_cols; for my $c (@$table_cols) { my $newc = $c =~ m/^"/ ? $c : lc($c); push( @cnames, $newc ); $self->{ORG_NAME}->{$newc} = $c; } # # set the col_num => col_obj hash for the table # my $col_nums; my $i = 0; for (@cnames) { $col_nums->{$_} = $i++; } $t->{$name}->{col_nums} = $col_nums; $t->{$name}->{col_names} = \@cnames; my $tcols = $t->{$name}->col_names(); my @newcols; for (@$tcols) { next unless ( defined($_) ); my $ncol = $_; $ncol = $name . '.' . $ncol unless ( $ncol =~ m/\./ ); push( @newcols, $ncol ); } @c = ( @c, @newcols ); } $self->buildColumnObjects( $t, \@tables ); return $self->do_err( $self->{errstr} ) if ( $self->{errstr} ); ################################################## # Patch from Cosimo Streppone # my $all_cols = $self->{all_cols} # || [ map {$_->{name} }@{$self->{columns}} ] # || []; # @$all_cols = (@$all_cols,@c); # $self->{all_cols} = $all_cols; if ( !$self->{all_cols} ) { my $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 getColumnObject($) { my ( $self, $newcol, $t, $tables ) = @_; my @columns; if ( ( $newcol->{type} eq 'column' ) && ( -1 != index( $newcol->{value}, '*' ) ) ) { my $tbl; my @tables; if ( $newcol->{value} =~ m/^(.+)\.\*$/ ) { $tbl = $1; return $self->do_err("No table name given in '$newcol->{value}'") unless ( defined( _STRING($tbl) ) ); @tables = ($tbl); } else { @tables = map { $_->name() } @{$tables}; } my $join = defined( _HASH( $self->{join} ) ) && ( ( -1 != index( $self->{join}->{type}, 'NATURAL' ) ) || ( -1 != index( $self->{join}->{clause}, 'USING' ) ) ); my %shared_cols; foreach my $table (@tables) { return $self->do_err("Can't find table '$table'") unless ( defined( $t->{$table} ) ); my $tcols = $t->{$table}->{col_names}; return $self->do_err("Couldn't find column names for table '$table'!") unless ( _ARRAY($tcols) ); foreach my $colName ( @{$tcols} ) { next if ( $join && $shared_cols{$colName}++ ); my $expcol = [ $colName, # column name $table, # table name SQL::Statement::ColumnValue->new( $self, $table . '.' . $colName ), # term $colName, # display name $colName, $newcol, ]; push( @columns, $expcol ); } } } elsif ( ( 'CREATE' eq $self->command() ) || ( 'DROP' eq $self->command() ) ) { return $self->do_err("Invalid column type '$newcol->{type}'") unless ( 'column' eq $newcol->{type} ); my $expcol = [ $newcol->{value}, # column name undef, # table name undef, # term $newcol->{value}, # display name $newcol->{value}, # original name $newcol, # coldef ]; push( @columns, $expcol ); } else { my $col; if ( $newcol->{type} eq 'setfunc' ) { my @cols = $self->getColumnObject( $newcol->{arg}, $t ); if ( 1 == scalar(@cols) ) { $col = $cols[0]->[2]; } else { # FIXME add '\0' constants between items? my $colSep = $self->{termFactory}->buildCondition( { type => 'string', value => "\0", } ); @cols = map { $_->[2], $colSep } @cols; pop(@cols); $col = $self->{termFactory}->buildCondition( { type => 'function', name => 'str_concat', value => \@cols, } ); } } else { $col = $self->{termFactory}->buildCondition($newcol); } my $expcol = [ $newcol->{name} || $newcol->{value}, # column name undef, # table name $col, # term $newcol->{alias} || $newcol->{fullorg}, # display name $newcol->{fullorg}, # original name $newcol, # coldef ]; push( @columns, $expcol ); } return @columns; } sub buildColumnObjects($) { my ( $self, $t, $tables ) = @_; defined( _ARRAY0( $self->{column_defs} ) ) or return; defined( _ARRAY0( $self->{columns} ) ) and return; $self->{columns} = []; my $coldefs = $self->{column_defs}; for ( my $i = 0; $i < scalar( @{$coldefs} ); ++$i ) { my $colentry = $coldefs->[$i]; my @columns = $self->getColumnObject( $colentry, $t, $tables ); return if ( $self->{errstr} ); foreach my $col (@columns) { my $expcol = SQL::Statement::Util::Column->new( @{$col} ); push( @{ $self->{columns} }, $expcol ); $self->{column_aliases}->{ $col->[4] } ||= $col->[3]; $self->{colpos}->{ $col->[3] } = scalar( @{ $self->{columns} } ) - 1; } } return; } sub verify_expand_column { my ( $self, $c, $i, $usr_cols, $is_duplicate, $col_exists ) = @_; # XXX defined $self->{ALIASES}->{$c} and $c = $self->{ALIASES}->{$c}; my ( $table, $col, $col_obj ); if ( $c =~ m/(\S+)\.(\S+)/ ) { $table = $1; $col = $2; } elsif ( ++${$i} >= 0 ) { $col_obj = $usr_cols->[ ${$i} ]; ( $table, $col ) = ( $col_obj->{table}, $col_obj->{name} ); } else { ( $table, $col ) = $self->full_qualified_column_name($c); } return unless ($col); my $is_column = ( defined( _INSTANCE( $col_obj, 'SQL::Statement::Util::Column' ) ) and ( $col_obj->{coldef}->{type} eq 'column' ) ) ? 1 : 0; unless ( $is_column and defined($table) ) { ( $table, undef ) = $self->full_qualified_column_name($col); } if ( defined( _INSTANCE( $table, 'SQL::Statement::Table' ) ) ) { $table = $table->name(); } if ( $is_column and !$table ) { return $self->do_err("Ambiguous column name '$c'") if ( $is_duplicate->{$c} ); return $self->do_err("No such column '$col'"); $col = $c; } elsif ($is_column) { my $is_user_def = 1 if ( $self->{opts}->{function_defs}->{$col} ); return $self->do_err("No such column '$table.$col'") unless ( $col_exists->{"$table.$col"} or $col_exists->{ "\L$table." . $col } or $is_user_def ); } return ( $table, $col ) if ( $is_column or ${$i} < 0 ); return; } sub verify_columns { 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 = $self->columns(); return $self->do_err('No fetchable columns') if ( 0 == scalar(@usr_cols) ); my ( $cnum, $fully_qualified_cols ) = ( 0, [] ); my @tmpcols = map { $_->{name} } @usr_cols; my %col_exists = map { $_ => 1 } @tmp_cols; my ( %is_member, @duplicates, %is_duplicate ); # $_ =~ s/[^.]*\.(.*)/$1/; foreach (@$all_cols) { substr( $_, 0, index( $_, '.' ) + 1 ) = ''; } # XXX we're modifying $all_cols from caller! @duplicates = grep( $is_member{$_}++, @$all_cols ); %is_duplicate = map { $_ => 1 } @duplicates; if ( exists( $self->{join} ) && defined( _HASH( $self->{join} ) ) ) { my $join = $self->{join}; if ( -1 != index( uc $join->{type}, 'NATURAL' ) ) { %is_duplicate = (); } # the following should be probably conditioned on an option, # but I don't know which --BW elsif ( 'USING' eq $join->{clause} ) { my @keys = @{ $join->{keycols} }; delete @is_duplicate{@keys}; } } my %set_func_nofunc; if ( defined( $self->{has_set_functions} ) ) { my @set_func_nofunc = grep { ( $_->{type} ne 'setfunc' ) } @{ $self->{column_defs} }; %set_func_nofunc = map { ( $_->{alias} || $_->{fullorg} ) => 1 } @set_func_nofunc; } my ( $is_fully, $set_fully ) = ( {}, {} ); my $i = -1; my $num_tables = $self->tables(); for my $c (@tmpcols) { my ( $table, $col ) = $self->verify_expand_column( $c, \$i, \@usr_cols, \%is_duplicate, \%col_exists ); return if ( $self->{errstr} ); next unless ( $table && $col ); my $ftc = "$table.$col"; next if ( $table and $col and $is_fully->{$ftc} ); $self->{columns}->[$i]->{name} = $col; $self->{columns}->[$i]->{table} = $table; if ( $table and $col ) { push( @$fully_qualified_cols, $ftc ); ++$is_fully->{$ftc}; ++$set_fully->{$ftc} if ( $set_func_nofunc{$c} ); } } if ( defined( $self->{has_set_functions} ) ) { if ( defined( _ARRAY( $self->{group_by} ) ) ) { foreach my $grpby ( @{ $self->{group_by} } ) { $i = -2; my ( $table, $col ) = $self->verify_expand_column( $grpby, \$i, \@usr_cols, \%is_duplicate, \%col_exists ); return if ( $self->{errstr} ); $col ||= $grpby; ( $table, $col ) = $self->full_qualified_column_name($col) if ( defined($col) && !defined($table) ); next unless ( defined($table) && defined($col) ); delete $set_fully->{"$table.$col"}; } } if ( defined( _HASH($set_fully) ) ) { return $self->do_err( sprintf( "Column%s '%s' must appear in the GROUP BY clause or be used in an aggregate function", scalar( keys( %{$set_fully} ) ) > 1 ? 's' : '', join( "', '", keys( %{$set_fully} ) ) ) ); } } if ( $self->{sort_spec_list} ) { for my $n ( 0 .. scalar @{ $self->{sort_spec_list} } - 1 ) { defined( _INSTANCE( $self->{sort_spec_list}->[$n], 'SQL::Statement::Order' ) ) and next; my ( $newcol, $direction ) = each %{ $self->{sort_spec_list}->[$n] }; my $desc = $direction && ( $direction eq "DESC" ); # ($direction || "ASC") eq "DESC"; # XXX parse order by like group by and select list $i = -2; my ( $table, $col ) = $self->verify_expand_column( $newcol, \$i, \@usr_cols, \%is_duplicate, \%col_exists ); $self->{errstr} and return; ( $table, $col ) = $self->full_qualified_column_name($newcol) if ( defined($col) && !defined($table) ); defined($table) and $col = $table . "." . $col; $self->{sort_spec_list}->[$n] = SQL::Statement::Order->new( col => SQL::Statement::Util::Column->new( $col, # column name $table, # table name SQL::Statement::ColumnValue->new( $self, $col ), # term $newcol # display name ), direction => $direction, desc => $desc, ); } } return $fully_qualified_cols; } sub distinct() { my $q = _STRING( $_[0]->{set_quantifier} ); return defined($q) && ( 'DISTINCT' eq $q ); } sub column_names() { my @cols = map { $_->name() } $_[0]->columns(); return @cols; } sub command() { return $_[0]->{command} } sub params(;$) { if ( !$_[0]->{params} ) { return wantarray ? () : 0; } return $_[0]->{params}->[ $_[1] ] if ( defined $_[1] ); return wantarray ? @{ $_[0]->{params} } : scalar @{ $_[0]->{params} }; } sub row_values(;$$) { unless ( defined( _ARRAY( $_[0]->{values} ) ) ) { return wantarray ? () : 0; } if ( defined( $_[1] ) ) { return 0 unless ( defined( $_[0]->{values}->[ $_[1] ] ) ); return $_[0]->{values}->[ $_[1] ]->[ $_[2] ] if ( defined $_[2] ); return wantarray ? map { $_->{value} } @{ $_[0]->{values}->[ $_[1] ] } : scalar @{ $_[0]->{values}->[ $_[1] ] }; } else { return wantarray ? map { [ map { $_->{value} } @{$_} ] } @{ $_[0]->{values} } : scalar( @{ $_[0]->{values} } ); } } # # $num_of_cols = $stmt->columns() # number of columns # @cols = $stmt->columns() # array of S::S::Column objects # $col = $stmt->columns($cnum) # S::S::Column obj for col number $cnum # $col = $stmt->columns($cname) # S::S::Column obj for col named $cname # sub columns { my ( $self, $col ) = @_; if ( !$self->{columns} ) { return wantarray ? () : 0; } if ( defined $col and $col =~ m/^\d+$/ ) { # arg1 = a number return $self->{columns}->[$col]; } elsif ( defined $col ) { # arg1 = string for my $c ( @{ $self->{columns} } ) { return $c if ( $c->name() eq $col ); } } return wantarray ? @{ $self->{columns} } : scalar @{ $self->{columns} }; } sub colname2colnum { if ( !$_[0]->{columns} ) { return undef; } for my $i ( 0 .. $#{ $_[0]->{columns} } ) { return $i if ( $_[0]->{columns}->[$i]->name() eq $_[1] ); } return undef; } sub colname2table($) { my ( $self, $col_name ) = @_; return undef unless defined $col_name; my ( $tbl, $col ); if ( $col_name =~ /^(.+)\.(.+)$/ ) { ( $tbl, $col ) = ( $1, $2 ); } else { $col = $col_name; } my $found_table; for my $full_col ( @{ $self->{all_cols} } ) { my ( $stbl, $scol ) = $full_col =~ /^(.+)\.(.+)$/; next unless ( $scol || '' ) eq $col; next if ( defined($tbl) && ( $tbl ne $stbl ) ); $found_table = $stbl; last; } return $found_table; } sub full_qualified_column_name($) { my ( $self, $col_name ) = @_; return unless ( defined($col_name) ); # XXX defined $self->{ALIASES}->{$col_name} and $col_name = $self->{ALIASES}->{$col_name}; my ( $tbl, $col ); unless ( ( $tbl, $col ) = $col_name =~ m/^((?:"[^"]+")|(?:[^.]+))\.(.*)$/ ) { $col = $col_name; } unless ( defined( $self->{splitted_all_cols} ) ) { my @rc; for my $full_col ( @{ $self->{all_cols} } ) { if ( my ( $stbl, $scol ) = $full_col =~ m/^((?:"[^"]+")|(?:[^.]+))\.(.*)$/ ) { push( @{ $self->{splitted_all_cols} }, [ $stbl, $scol ] ); defined($tbl) and ( $tbl ne $stbl ) and next; ( $scol eq $col ) and @rc = ( $stbl, $scol ); } } @rc and return @rc; } else { for my $splitted_col ( @{ $self->{splitted_all_cols} } ) { defined($tbl) and ( $tbl ne $splitted_col->[0] ) and next; ( $splitted_col->[1] eq $col ) and return @$splitted_col; } } return ( $tbl, $col ); } #sub verify_order_cols #{ # my ( $self, $table ) = @_; # return unless $self->{sort_spec_list}; # my @ocols = $self->order(); # my @tcols = @{ $table->col_names() }; # my @n_ocols; # # for my $colnum ( 0 .. $#ocols ) # { # my $col = $self->order($colnum); # # if ( !defined( $col->table() ) ) # { # my $cname = $ocols[$colnum]->{col}->name(); # my $tname = $self->colname2table($cname); # return $self->do_err("No such column '$cname'.") unless ($tname); # $self->{sort_spec_list}->[$colnum]->{col}->{table} = $tname; # push( @n_ocols, $tname ); # } # } # # return 1; #} sub limit ($) { $_[0]->{limit_clause}->{limit}; } sub offset ($) { $_[0]->{limit_clause}->{offset}; } sub order { return unless ( defined $_[0]->{sort_spec_list} ); return defined( $_[1] ) && looks_like_number( $_[1] ) ? $_[0]->{sort_spec_list}->[ $_[1] ] : wantarray ? @{ $_[0]->{sort_spec_list} } : scalar @{ $_[0]->{sort_spec_list} }; } sub tables { return defined( $_[1] ) && looks_like_number( $_[1] ) ? $_[0]->{tables}->[ $_[1] ] : wantarray ? @{ $_[0]->{tables} } : scalar @{ $_[0]->{tables} }; } sub order_joins { my ( $self, $links ) = @_; my ( @new_keycols, @new_links ); for (@$links) { my ( $tbl, $col ) = $self->full_qualified_column_name($_); push( @new_keycols, $tbl . $self->{dlm} . $col ); push( @new_links, $tbl ); } $self->{join}->{keycols} = $links = \@new_keycols; # my @tmp = @new_keycols; # foreach (@tmp) { $_ =~ s/\./$self->{dlm}/g; } # $self->{join}->{keycols} = \@tmp; # @$links = \@new_keycols; my @all_tables; my %relations; my %is_table; while (@new_links) { my $t1 = shift(@new_links); my $t2 = shift(@new_links); return undef unless ( defined($t1) and defined($t2) ); push @all_tables, $t1 unless ( $is_table{$t1}++ ); push @all_tables, $t2 unless ( $is_table{$t2}++ ); $relations{$t1}{$t2}++; $relations{$t2}{$t1}++; } my @tables = @all_tables; my @order = shift @tables; my %is_ordered = ( $order[0] => 1 ); my %visited; while (@tables) { my $t = shift @tables; my @rels = keys %{ $relations{$t} }; for my $t2 (@rels) { next unless $is_ordered{$t2}; push @order, $t; $is_ordered{$t}++; last; } if ( !$is_ordered{$t} ) { push( @tables, $t ) if ( $visited{$t}++ < @all_tables ); } } if ( @order < @all_tables ) { my @missing; my %in_order = map { $_ => 1 } @order; foreach my $tbl (@all_tables) { next if ( $in_order{$tbl} ); push( @missing, $tbl ); } return $self->do_err( sprintf( 'Unconnected tables (%s) in equijoin statement!', join( ', ', @missing ) ) ); } $self->{join}->{table_order} = \@order; return \@order; } sub do_err { my $self = shift; my $err = shift; my $errtype = shift; my @c = caller 6; #$err = "[" . $self->{original_string} . "]\n$err\n\n"; # $err = "$err\n\n"; my $prog = $c[1]; my $line = $c[2]; $prog = defined($prog) ? " called from $prog" : ''; $prog .= defined($line) ? " at $line" : ''; $err = "\nExecution ERROR: $err$prog.\n\n"; $self->{errstr} = $err; carp $err if $self->{PrintError}; croak "$err" if $self->{RaiseError}; return; } sub errstr() { return $_[0]->{errstr}; } sub where_hash() { return $_[0]->{where_clause}; } sub column_defs() { return $_[0]->{column_defs}; } sub where() { return undef unless $_[0]->{where_terms}; return $_[0]->{where_terms}; } sub get_user_func_table { my ( $self, $name, $u_func ) = @_; my $term = $self->{termFactory}->buildCondition($u_func); my @data_aryref = @{ $term->value(undef) }; my $col_names = shift @data_aryref; # my $tempTable = SQL::Statement::TempTable->new( # $name, $col_names, $col_names, $data_aryref # ); my $tempTable = SQL::Statement::RAM::Table->new( $name, $col_names, \@data_aryref ); $tempTable->{all_cols} ||= $col_names; return $tempTable; } sub capability($) { my ( $self, $capname ) = @_; return $self->{capabilities}->{$capname} if ( defined( $self->{capabilities}->{$capname} ) ); return; } sub DESTROY { my $self = $_[0]; undef $self->{NAME}; undef $self->{ORG_NAME}; undef $self->{all_cols}; undef $self->{already_prepared}; undef $self->{argnum}; undef $self->{col_obj}; undef $self->{column_names}; undef $self->{columns}; undef $self->{cur_table}; undef $self->{data}; undef $self->{group_by}; #undef $self->{has_OR}; undef $self->{join}; undef $self->{limit_clause}; undef $self->{num_placeholders}; undef $self->{num_val_placeholders}; undef $self->{org_table_names}; undef $self->{params}; undef $self->{opts}; undef $self->{procedure}; undef $self->{set_function}; undef $self->{sort_spec_list}; undef $self->{subquery}; undef $self->{tables}; undef $self->{table_names}; undef $self->{table_func}; undef $self->{where_clause}; undef $self->{where_terms}; undef $self->{values}; } package SQL::Statement::Aggregate; use Scalar::Util qw(looks_like_number); use Params::Util qw(_HASH); use Clone qw(clone); sub new { my ( $class, $owner, $rows ) = @_; my $self = { owner => $owner, records => $rows, }; return bless( $self, $class ); } my $empty_agg = { uniq => [], count => 0, sum => undef, min => undef, max => undef, }; sub do_calc() { my $self = $_[0]; foreach my $line ( 0 .. ( scalar( @{ $self->{records} } ) - 1 ) ) { my $row = $self->{records}->[$line]; my $result = $self->getAffectedResult($row); foreach my $colidx ( 0 .. ( scalar( @{ $self->{owner}->{columns} } ) - 1 ) ) { my $coldef = $self->{owner}->{columns}->[$colidx]->{coldef}; my $colval = $row->[$colidx]; if ( $coldef->{type} eq 'setfunc' ) { if ( $coldef->{distinct} eq 'DISTINCT' ) { next if defined( $result->{uniq}->[$colidx]->{$colval} ); $result->{uniq}->[$colidx]->{$colval} = 1; } $result->{agg}->[$colidx] = clone($empty_agg) unless ( defined( _HASH( $result->{agg}->[$colidx] ) ) ); my $agg = $result->{agg}->[$colidx]; ++$agg->{count}; unless ( defined( $agg->{max} ) && ( SQL::Statement::_anycmp( $colval, $agg->{max} ) < 0 ) ) { $agg->{max} = $colval; } unless ( defined( $agg->{min} ) && ( SQL::Statement::_anycmp( $colval, $agg->{min} ) > 0 ) ) { $agg->{min} = $colval; } $agg->{sum} += $colval if ( looks_like_number($colval) ); } else { $result->{pure}->[$colidx] = $colval unless ( defined( $result->{pure}->[$colidx] ) ); } } } } sub build_row # (\%) { my ( $self, $result ) = @_; my @row; foreach my $colidx ( 0 .. ( scalar( @{ $self->{owner}->{columns} } ) - 1 ) ) { my $coldef = $self->{owner}->{columns}->[$colidx]->{coldef}; if ( $coldef->{type} eq 'setfunc' ) { if ( $coldef->{name} eq 'COUNT' ) { push( @row, $result->{agg}->[$colidx]->{count} || 0 ); } elsif ( $coldef->{name} eq 'MAX' ) { push( @row, $result->{agg}->[$colidx]->{max} ); } elsif ( $coldef->{name} eq 'MIN' ) { push( @row, $result->{agg}->[$colidx]->{min} ); } elsif ( $coldef->{name} eq 'SUM' ) { push( @row, $result->{agg}->[$colidx]->{sum} ); } elsif ( $coldef->{name} eq 'AVG' ) { my $count = $result->{agg}->[$colidx]->{count}; my $sum = $result->{agg}->[$colidx]->{sum}; my $avg = $sum / $count if ( $count && $sum ); push( @row, $avg ); } else { return $self->{owner}->do_err("Invalid SET FUNCTION '$coldef->{name}'"); } } else { push( @row, $result->{pure}->[$colidx] ); } } return \@row; } sub calc() { my $self = $_[0]; $self->{final_row} = {}; $self->do_calc(); my $final_row = $self->build_row( $self->{final_row} ); return [$final_row]; } sub getAffectedResult # (\@) { return $_[0]->{final_row}; } package SQL::Statement::Group; use vars qw(@ISA); use Params::Util qw(_HASH); @ISA = qw(SQL::Statement::Aggregate); sub new { my ( $class, $owner, $rows, $keycols ) = @_; my $self = $class->SUPER::new( $owner, $rows ); $self->{keycols} = $keycols; return $self; } sub calc() { my $self = $_[0]; my @final_table; $self->do_calc(); if ( scalar( keys( %{ $self->{final_rows} } ) ) ) { foreach my $key ( keys( %{ $self->{final_rows} } ) ) { my $final_row = $self->build_row( $self->{final_rows}->{$key} ); push( @final_table, $final_row ); } } else { my $final_row = $self->build_row( {} ); push( @final_table, $final_row ); } return \@final_table; } sub getAffectedResult # (\@) { my ( $self, $row ) = @_; my $rowkey = join( "\0", @$row[ @{ $self->{keycols} } ] ); $self->{final_rows}->{$rowkey} = {} unless ( defined( _HASH( $self->{final_rows}->{$rowkey} ) ) ); return $self->{final_rows}->{$rowkey}; } package SQL::Statement::TempTable; use vars qw(@ISA); BEGIN { require SQL::Eval; @SQL::Statement::TempTable::ISA = qw(SQL::Eval::Table); } sub new { my ( $class, $name, $col_names, $table_cols, $table ) = @_; my %col_nums; $col_nums{ $col_names->[$_] } = $_ for ( 0 .. scalar @$col_names - 1 ); my @display_order = @col_nums{@$table_cols}; my $self = { col_names => $col_names, table_cols => \@display_order, col_nums => \%col_nums, table => $table, NAME => $name, rowpos => 0, maxrow => scalar @$table }; return $class->SUPER::new($self); } sub is_shared($) { $_[0]->{is_shared}->{ $_[1] }; } sub get_pos() { $_[0]->{rowpos} } sub column_num($) { my ( $s, $col ) = @_; my $new_col = $s->{col_nums}->{$col}; unless ( defined($new_col) ) { my @tmp = split( '~', $col ); return unless ( 2 == scalar(@tmp) ); $new_col = lc( $tmp[0] ) . '~' . $tmp[1]; $new_col = $s->{col_nums}->{$new_col}; } return $new_col; } sub fetch_row() { return $_[0]->{row} = ( $_[0]->{rowpos} >= $_[0]->{maxrow} ) ? undef : $_[0]->{table}->[ $_[0]->{rowpos}++ ]; } sub column($) { return $_[0]->{row}->[ $_[0]->{col_nums}->{ $_[1] } ]; } package SQL::Statement::Order; sub new ($$) { my $proto = shift; my $self = {@_}; bless( $self, ( ref($proto) || $proto ) ); } sub table ($) { $_[0]->{col}->table(); } sub column ($) { $_[0]->{col}->display_name(); } sub desc ($) { $_[0]->{desc}; } sub direction ($) { $_[0]->{direction}; } package SQL::Statement::Limit; sub new ($$) { my ( $proto, $self ) = @_; bless( $self, ( ref($proto) || $proto ) ); } #sub limit ($) { shift->{limit}; } #sub offset ($) { shift->{offset}; } package SQL::Statement::Param; sub new { my ( $class, $idx ) = @_; my $self = { 'idx' => $idx }; return bless( $self, $class ); } sub idx ($) { $_[0]->{idx}; } package SQL::Statement::Table; sub new { my ( $class, $table_name ) = @_; if ( $table_name !~ m/"/ ) { $table_name = lc $table_name; } my $self = { name => $table_name, }; return bless( $self, $class ); } sub name { $_[0]->{name} } 1; __END__ =pod =head1 NAME SQL::Statement - SQL parsing and processing engine =head1 SYNOPSIS # ... depends on what you want to do, see below =head1 DESCRIPTION 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, complex nested search conditions, and other features. 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 persistent 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. 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. =head1 INSTALLATION There are no prerequisites for using this as a standalone parser. If you want to access persistent 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 from CPAN and use the standard perl mantra: perl Makefile.PL make make test make install It works fine on all platforms it has been tested on. On Windows, you can use ppm or with the mantra use nmake, dmake, or make depending on which is available. =head1 USAGE =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, L, L, L, L, and others. 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. If you are interested in accessing and manipulating persistent data, you may not really want to use SQL::Statement directly, but use L along with one of the DBDs mentioned above instead. You will be using SQL::Statement, but under the hood of the DBD. See L for help with DBI and see L 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. =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 and without DBI) to parse and examine the structure of SQL statements. See L for details. =head2 How can I use it to embed a SQL engine in a DBD or other module? SQL::Statement is designed to be easily embedded in other modules and is especially suited for developing new DBI drivers (DBDs). See L. =head2 What SQL Syntax is supported? SQL::Statement supports a small but powerful subset of SQL commands. See L. =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. =head1 How can I participate in ongoing development? 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. If you want to join the development team, or just hear more about the development, write Jeff () or Jens () a note. =head1 METHODS The following methods can or must be overridden by derived classes. =head2 capability $has_capability = $h->capability('capability_name'); Returns a true value if the specified capability is available. Currently no capabilities are defined and this is a placeholder for future use. It is envisioned it will be used like C<< SQL::Eval::Table::capability >>. =head2 open_table The C<< open_table >> method must be overridden by derived classes to provide the capability of opening data tables. This is a necessity. Arguments given to open_table call: =over 4 =item C<< $data >> The database memo parameter. See L. =item C<< $table >> The name of the table to open as parsed from SQL statement. =item C<< $createMode >> A flag indicating the mode (C<< CREATE TABLE ... >>) the table should be opened with. Set to a true value in create mode. =item C<< $lockMode >> A flag indicating whether the table should be opened for writing (any other than C<< SELECT ... >>). Set to a true value if the table is to be opened for write access. =back The following methods are required to use SQL::Statement in a DBD (for example). =head2 new Instantiates a new SQL::Statement object. Arguments: =over 4 =item C<< $sql >> The SQL statement for later actions. =item C<< $parser >> An instance of a L object or flags for it's instantiation. If omitted, default flags are used. =back When the basic initialization is completed, C<< $self->prepare($sql, $parser) >> is invoked. =head2 prepare Prepares SQL::Statement to execute a SQL statement. Arguments: =over 4 =item C<< $sql >> The SQL statement to parse and prepare. =item C<< $parser >> Instance of a L object to parse the provided SQL statement. =back =head2 execute Executes a prepared statement. Arguments: =over 4 =item C<< $data >> Memo field passed through to calls of the instantiated C<< $table >> objects or C<< open_table >> calls. In C<< CREATE >> with subquery, C<< $data->{Database} >> must be a DBI database handle object. =item C<< $params >> Bound params via DBI ... =back =head2 errstr Gives the error string of the last error, if any. =head2 fetch_row Fetches the next row from the result data set (implies removing the fetched row from the result data set). =head2 fetch_rows Fetches all (remaining) rows from the result data set. =begin undocumented =head2 _anycmp =head2 buildColumnObjects =head2 colname2colnum =head2 colname2table =head2 column_names =head2 columns =head2 command =head2 distinct =head2 do_err =head2 eval_where =head2 fetch =head2 find_join_columns =head2 full_qualified_column_name =head2 getColumnObject =head2 get_user_func_table =head2 join_2_tables =head2 limit =head2 offset =head2 open_tables =head2 order =head2 order_joins =head2 params =head2 row_values =head2 run_functions =head2 tables =head2 verify_columns =head2 verify_expand_column =head2 verify_order_cols =head2 where =head2 where_hash =head2 column_defs =end undocumented =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc SQL::Statement You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * CPAN Search L =back =head2 Where can I go for help? For questions about installation or usage, please ask on the dbi-users@perl.org mailing list (see http://dbi.perl.org) or post a question on PerlMonks (L, where Jeff is known as jZed). Jens does not visit PerlMonks on a regular basis. If you have a bug report, a patch or a suggestion, please open a new report ticket at CPAN (but please check previous reports first in case your issue has already been addressed). You can mail any of the module maintainers, but you are more assured of an answer by posting to the dbi-users list or reporting the issue in RT. Report tickets should contain a detailed description of the bug or enhancement request and at least an easily verifiable way of reproducing the issue or fix. Patches are always welcome, too. =head2 Where can I go for help with a concrete version? Bugs and feature requests are accepted against the latest version only. To get patches for earlier versions, you need to get an agreement with a developer of your choice - who may or not report the issue and a suggested fix upstream (depends on the license you have chosen). =head2 Business support and maintenance For business support you can contact Jens via his CPAN email address rehsackATcpan.org. Please keep in mind that business support is neither available for free nor are you eligible to receive any support based on the license distributed with this package. =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. In 2008 Jens Rehsack took over the maintenance of the extended module from Jeff. Together with H.Merijn Brand (who has taken DBD::CSV), Detlef Wartke and Volker Schubbert (especially between 1.16 developer versions until 1.22) and all submitters of bug reports via RT a lot of issues have been fixed. Thanks to all! If you're interested in helping develop SQL::Statement or want to use it with your own modules, feel free to contact Jeff or Jens. =head1 BUGS AND LIMITATIONS =over 4 =item * Currently we treat NULL and '' as the same in AnyData/CSV mode - eventually fix. =item * No nested C-style comments allowed as SQL99 says. =item * There are some issues regarding combining outer joins with where clauses. =item * Aggregate functions cannot be used in where clause. =item * Some SQL commands/features are not supported (most of them cannot by design), as C, using indices, sub-selects etc. Currently the statement for missing features is: I plan to create a SQL::Statement v2.00 based on a pure Backus-Naur-Form parser and a fully object oriented command pattern based engine implementation. When the time is available, I will do it. Until then bugs will be fixed or other Perl modules under my maintainership will receive my time. Features which can be added without deep design changes might be applied earlier - especially when their addition allows studying effective ways to implement the feature in upcoming 2.00. =item * Some people report that SQL::Statement is slower since the XS parts were implemented in pure Perl. This might be true, but on the other hand a large number of features have been added including support for ANSI SQL 99. For SQL::Statement 1.xx it's not planned to add new XS parts. =item * Wildcards are expanded to lower cased identifiers. This might confuse some people, but it was easier to implement. The warning in L to never trust the case of returned column names should be read more often. If you need to rely on identifiers, always use C{NAME_lc}> or C{NAME_uc}> - never rely on C{NAME}>: $dbh->{FetchHashKeyName} = 'NAME_lc'; $sth = $dbh->prepare("SELECT FOO, BAR, ID, NAME, BAZ FROM TABLE"); $sth->execute; $hash_ref = $sth->fetchall_hashref('id'); print "Name for id 42 is $hash_ref->{42}->{name}\n"; See L for more information. =item * Unable to use the same table twice with different aliases. B: Temporary tables: C<< CREATE TEMP TABLE t_foo AS SELECT * FROM foo >>. Than both tables can be used independently. =back Patches to fix bugs/limitations (or a grant to do it) would be very welcome. Please note, that any patches B successfully pass all the C, L and L tests and must be a general improvement. =head1 AUTHOR AND COPYRIGHT 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. Since 2008, Jens Rehsack is the maintainer. Copyright (c) 2001,2005 by Jeff Zucker: jzuckerATcpan.org Copyright (c) 2007-2010 by Jens Rehsack: rehsackATcpan.org Portions Copyright (C) 1998 by Jochen Wiedmann: jwiedATcpan.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. =cut SQL-Statement-1.407/lib/SQL/Statement/Embed.pod000644 000765 000024 00000027165 12437274537 021012 0ustar00snostaff000000 000000 =pod =head1 NAME SQL::Statement::Embed - embed a SQL engine in a DBD or module =head1 SYNOPSIS =head1 DESCRIPTION SQL::Statement is designed to be easy to embed in other modules and to be especially easy to embed in DBI drivers. It provides a SQL Engine and the other module needs to then provide a data source and a storage mechanism. For example, the L module uses SQL::Statement as an embedded SQL engine by implementing a file-based data source and by using DBI as the user interface. Similarly L uses SQL::Statement as its SQL engine, provides its own extensions to the supported SQL syntax, and uses on-the-fly searches of Amazon.com as its data source. SQL::Statement is the basis for at least eight existing DBDs (DBI database drivers). If you have a new data source, you too can create a DBD without having to reinvent the SQL wheel. It is fun and easy so become a DBD author today! SQL::Statement can be also be embedded without DBI. We will explore that first since developing a DBD uses most of the same methods and techniques. =head1 The role of SQL::Statement subclasses SQL::Statement provides a SQL parsing and execution engine. It neither provides a data source nor storage mechanism other than in-memory tables. The L contains a subclass of SQL::Statement to abstract from embedding SQL::Statement into a DBD and lets you concentrate on the extensions you need to make. L extends DBI::DBD::SqlEngine by providing access to file-based storage mechanisms. It is quite possible to use things other than files as data sources, in which case you would not use L, instead you would replace L's methods with your own. In the examples below, we use DBD::File, replacing only a few methods. SQL::Statement provides SQL parsing and evaluation and DBI::DBD::SqlEngine provides DBI integration. The only thing missing is a data source - what we actually want to store and query. As an example suppose we are going to create a subclass called 'Foo' that will provide as a data source the in-memory storage which is used in L to provide the C tables in SQL::Statement, but the rows are stored as a string using a serializer (Storable). Consider what needs to happen to perform a SELECT query on our 'Foo' data: * receive a SQL string * parse the SQL string into a request structure * open the table(s) specified in the request * define column names and positions for the table * read rows from the table * convert the rows from colon-separated format into perl arrays * match the columns and rows against the requested selection criteria * return requested rows and columns to the user To perform operations like INSERT and DELETE, we also need to: * convert rows from perl arrays into colon-separated format * write rows * delete rows SQL::Statement takes care of all of the SQL parsing and evaluation. DBD::File takes care of file opening, reading, writing, and deleting. So the only things 'Foo' is really responsible for are: * define column names and positions for the table * convert rows from colon-separated format into perl arrays * convert rows from perl arrays into colon-separated format In SQL::Statement subclasses these responsibilities are assigned to two objects. A ::Statement object is responsible for opening the table by creating new ::Table objects. A ::Table object is responsible for defining the column names and positions, opening data sources, reading, converting, writing and deleting data. The real work is therefore done in the ::Table object, the ::Statement subclass is required to deliver the right ::Table object. =head1 Creating a ::Statement object A subclass of SQL::Statement must provide at least one method called open_table(). The method should open a new Table object and define the table's columns. For our 'Foo' module, here is the complete object definition: package Foo; package Foo::Statement; use DBD::File; use base qw(DBI::DBD::SqlEngine::Statement); sub open_table { my ($self, $sth, $table, $createMode, $lockMode) = @_; my $class = ref $self; $class =~ s/::Statement/::Table/; return $class->new ($sth, $table, $createMode, $lockMode); } Since 'Foo' is an in-memory data source, we subclass SQL::Statement indirectly through DBD::File::Statement. The open_table() method lets DBD::File do the actual table opening. All we do is define the files directory (f_dir), the names of the columns (col_names) and the positions of the columns (col_nums). DBD::File creates and returns a $tbl object. It names that object according to the module that calls it, so in our case the object will be a Foo::Table object. =head1 Creating a ::Table object Table objects are responsible for reading, converting, writing, and deleting data. Since DBD::File provides most of those services, our 'Foo' subclass only needs to define three methods - fetch_row() to read data, push_row() to write data, and push_names() to store column names. We will leave deleting to DBD::File, since deleting a record in the 'Foo' format is the same process as deleting a record in any other simple file-based format. Here is the complete object definition: package Foo::Table; use base qw(DBD::File::Table); sub fetch_row { my($self, $data) = @_; my $fieldstr = $self->{fh}->getline; return undef unless $fieldstr; chomp $fieldstr; my @fields = split /:/,$fieldstr; $self->{row} = (@fields ? \@fields : undef); } sub push_row { my($self, $data, $fields) = @_; my $str = join ':', map { defined $_ ? $_ : '' } @$fields; $self->{fh}->print( $str."\n"); 1; } sub push_names {} 1; The fetch_row() method uses DBD::File's getline() method to physically read a row of data, then we convert it from native colon-separated format into a perl arrayref. The push_row() method converts from a perl arrayref back to colon-separated format then uses DBD::File's print() method to print it to file. The push_names method does nothing because it's purpose is to store column names in a file and in our 'Foo' subclass, we are defining the column names ourselves, not storing them in a file. =head1 Trying out our new subclass Here is a script which should create and query a file in our 'Foo' format. It assumes you have saved the Foo, Foo::Statement, and Foo::Table classes shown above into a file called Foo.pm. #!perl -w use strict; use Foo; my $parser = SQL::Parser->new(); $parser->{RaiseError}=1; $parser->{PrintError}=0; for my $sql(split /\n/, " DROP TABLE IF EXISTS group_id CREATE TABLE group_id (username CHAR,uid INT, gid INT) INSERT INTO group_id VALUES('joe',1,1) INSERT INTO group_id VALUES('sue',2,1) INSERT INTO group_id VALUES('bob',3,2) SELECT * FROM group_id " ){ my $stmt = Foo::Statement->new($sql,$parser); $stmt->execute; next unless $stmt->command eq 'SELECT'; while (my $row=$stmt->fetch) { print "@$row\n"; } } This is the same script as shown in the section on executing and fetching in L except that instead of SQL::Statement->new(), we are using Foo::Statement->new(). The other difference is that the execute/fetch example was using in-memory storage while this script is using file-based storage and the 'Foo' format we defined. When you run this script, you will be creating a file called "group_id" and it will contain the specified data in colon-separated format. =head1 Developing a new DBD =head2 Moving from a subclass to a DBD A DBD based on SQL::Statement uses the same two subclasses that are shown above. They should be called DBD::Foo::Statement and DBD::Foo::Table, but would otherwise be identical to the non-DBD subclass illustrated above. To turn it into a full DBD, you have to subclass DBD::File, DBD::File::dr, DBD::File::db, and DBD::File::st. In many cases a simple subclass with few or no methods overridden is sufficient. Here is a working DBD::Foo: package DBD::Foo; use base qw(DBD::File); package DBD::Foo::dr; $DBD::Foo::dr::imp_data_size = 0; use base qw(DBD::File::dr); package DBD::Foo::db; $DBD::Foo::db::imp_data_size = 0; use base qw(DBD::File::db); package DBD::Foo::st; $DBD::Foo::st::imp_data_size = 0; use base qw(DBD::File::st); package DBD::Foo::Statement; use base qw(DBD::File::Statement); sub open_table { my $self = shift @_; my $data = shift @_; $data->{Database}->{f_dir} = './'; my $tbl = $self->SUPER::open_table($data,@_); $tbl->{col_names} = [qw(username uid gid)]; $tbl->{col_nums} = {username=>0,uid=>1,gid=>2}; return $tbl; } package DBD::Foo::Table; use base qw(DBD::File::Table); sub fetch_row { my($self, $data) = @_; my $fieldstr = $self->{fh}->getline; return undef unless $fieldstr; chomp $fieldstr; my @fields = split /:/,$fieldstr; $self->{row} = (@fields ? \@fields : undef); } sub push_row { my($self, $data, $fields) = @_; my $str = join ':', map { defined $_ ? $_ : '' } @$fields; $self->{fh}->print( $str."\n"); 1; } sub push_names {} 1; =head2 A sample script to test our new DBD Assuming you saved the DBD::Foo shown above as a file called "Foo.pm" in a directory called "DBD", this script will work, so will most other DBI methods such as selectall_arrayref, fetchrow_hashref, etc. #!perl -w use strict; use lib qw(/home/jeff/data/module/lib); # or wherever you stored DBD::Foo use DBI; my $dbh=DBI->connect('dbi:Foo:'); $dbh->{RaiseError}=1; $dbh->{PrintError}=0; for my $sql(split /\n/, " DROP TABLE IF EXISTS group_id CREATE TABLE group_id (username CHAR,uid INT, gid INT) INSERT INTO group_id VALUES('joe',1,1) INSERT INTO group_id VALUES('sue',2,1) INSERT INTO group_id VALUES('bob',3,2) SELECT * FROM group_id " ){ my $stmt = $dbh->prepare($sql); $stmt->execute; next unless $stmt->{NUM_OF_FIELDS}; while (my $row=$stmt->fetch) { print "@$row\n"; } } =head1 Expanding the DBD Now that we have a basic DBD operational, there are several directions for expansion. In the first place, we might want to override some or all of DBD::File::Table to provide alternate means of reading, writing, and deleting from our data source. We might want to override the open_table() method to provide a different means of identifying column names (e.g. reading them from the file itself) or to provide other kinds of metadata. See L for documentation of the API for ::Table objects and see L for an example subclass. We might want to create extensions to the SQL syntax specific to our DBD. See the section on extending SQL syntax in L. We might want to provide a completely different kind of data source. See L (whose source code includes documentation on subclassing SQL::Statement and DBD::File), and other DBD::File subclasses such as L. We might also want to provide a completely different storage mechanism, something not based on files at all. See L and L. And we will almost certainly want to fine-tune the DBI interface, see L. =head1 Getting help with a new DBD The dbi-devATperl.org mailing list should be your first stop in creating a new DBD. Tim Bunce, the author of DBI and many DBD authors hang out there. Tell us what you are planning and we will offer suggestions about similar modules or other people working on similar issues, or on how to proceed. =head1 AUTHOR & COPYRIGHT Copyright (c) 2005, Jeff Zucker , all rights reserved. Copyright (c) 2010, Jens Rehsack , all rights reserved. This document may be freely modified and distributed under the same terms as Perl itself. =cut SQL-Statement-1.407/lib/SQL/Statement/Function.pm000644 000765 000024 00000024255 12531013464 021373 0ustar00snostaff000000 000000 package SQL::Statement::Function; use strict; use warnings FATAL => "all"; use vars qw(@ISA $VERSION); use SQL::Statement::Term (); @ISA = qw(SQL::Statement::Term); $VERSION = '1.407'; =pod =head1 NAME SQL::Statement::Function - abstract base class for all function executing terms =head1 SYNOPSIS # this class doesn't have a common constructor, because all derived classes # have their special requirements =head1 DESCRIPTION SQL::Statement::Function is an abstract base class providing the interface for all function executing terms. =head1 INHERITANCE SQL::Statement::Function ISA SQL::Statement::Term =head1 METHODS =head2 DESTROY Destroys the term and undefines the weak reference to the owner as well as the reference to the parameter list. =cut sub DESTROY { my $self = $_[0]; undef $self->{PARAMS}; $self->SUPER::DESTROY(); } package SQL::Statement::Function::UserFunc; use vars qw(@ISA); use Carp (); use Params::Util qw(_INSTANCE); use SQL::Statement::Functions; @ISA = qw(SQL::Statement::Function); =pod =head1 NAME SQL::Statement::Function::UserFunc - implements executing a perl subroutine =head1 SYNOPSIS # create an user function term with an SQL::Statement object as owner, # specifying the function name, the subroutine name (full qualified) # and the parameters to the subroutine my $term = SQL::Statement::Function::UserFunc->new( $owner, $name, $sub, \@params ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Function::UserFunc implements a term which returns the result of the specified subroutine. =head1 INHERITANCE SQL::Statement::Function ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates a new C instance. =head2 value Invokes the given subroutine with the values of the params and return it's result: my @params = map { $_->value($eval); } @{ $self->{PARAMS} }; return $subpkg->$subname( $self->{OWNER}, @params ); =cut sub new { my ( $class, $owner, $name, $subnm, $params ) = @_; my $self = $class->SUPER::new($owner); my ( $pkg, $sub ) = $subnm =~ m/^(.*::)([^:]+$)/; if ( !$sub ) { $sub = $subnm; $pkg = 'main'; } $pkg =~ s/::$//g; $pkg = 'main' unless ($pkg); $self->{SUB} = $sub; $self->{PKG} = $pkg; $self->{NAME} = $name; $self->{PARAMS} = $params; unless ( UNIVERSAL::can( $pkg, $sub ) ) { unless ( 'main' eq $pkg ) { my $mod = $pkg; $mod =~ s|::|/|g; $mod .= '.pm'; eval { require $mod; } unless ( defined( $INC{$mod} ) ); return $owner->do_err($@) if ($@); } $pkg->can($sub) or return $owner->do_err( "Can't find subroutine $pkg" . "::$sub" ); } return $self; } sub value($) { my $self = $_[0]; my $eval = $_[1]; my $pkg = $self->{PKG}; my $sub = $self->{SUB}; my @params = map { $_->value($eval); } @{ $self->{PARAMS} }; return $pkg->$sub( $self->{OWNER}, @params ); # FIXME is $pkg just a string? } package SQL::Statement::Function::NumericEval; use vars qw(@ISA); use Params::Util qw(_NUMBER _INSTANCE); @ISA = qw(SQL::Statement::Function); =pod =head1 NAME SQL::Statement::Function::NumericEval - implements numeric evaluation of a term =head1 SYNOPSIS # create an user function term with an SQL::Statement object as owner, # specifying the expression to evaluate and the parameters to the subroutine my $term = SQL::Statement::NumericEval->new( $owner, $expr, \@params ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Function::NumericEval implements the numeric evaluation of a term. All parameters are expected to be numeric. =head1 INHERITANCE SQL::Statement::Function::NumericEval ISA SQL::Statement::Function ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates a new C instance. Takes I<$owner>, I<$expr> and I<\@params> as arguments (in specified order). =head2 value Returns the result of the evaluated expression. =cut sub new { my ( $class, $owner, $expr, $params ) = @_; my $self = $class->SUPER::new($owner); $self->{EXPR} = $expr; $self->{PARAMS} = $params; return $self; } sub value($) { my ( $self, $eval ) = @_; my $expr = $self->{EXPR}; my @vals = map { _INSTANCE( $_, 'SQL::Statement::Term' ) ? $_->value($eval) : $_ } @{ $self->{PARAMS} }; foreach my $val (@vals) { return $self->do_err(qq~Bad numeric expression '$val'!~) unless ( defined( _NUMBER($val) ) ); } $expr =~ s/\?(\d+)\?/$vals[$1]/g; $expr =~ s/\s//g; $expr =~ s/^([\)\(+\-\*\/\%0-9]+)$/$1/; # untaint return eval $expr; } package SQL::Statement::Function::Trim; use vars qw(@ISA); BEGIN { @ISA = qw(SQL::Statement::Function); } =pod =head1 NAME SQL::Statement::Function::Trim - implements the built-in trim function support =head1 SYNOPSIS # create an trim function term with an SQL::Statement object as owner, # specifying the spec, char and the parameters to the subroutine my $term = SQL::Statement::Trim->new( $owner, $spec, $char, \@params ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Function::Trim implements string trimming. =head1 INHERITANCE SQL::Statement::Function::Trim ISA SQL::Statement::Function ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates a new C instance. Takes I<$owner>, I<$spec>, I<$char> and I<\@params> as arguments (in specified order). Meaning of the parameters: =over 4 =item I<$spec> Can be on of 'LEADING', 'TRAILING' 'BOTH'. Trims the leading chars, trailing chars or at both ends, respectively. Defaults to 'BOTH'. =item I<$char> The character to trim - defaults to C<' '> =item I<\@params> Expected to be an array with exact 1 element (more aren't evaluated). =back =head2 value Returns the trimmed value of first parameter argument. =cut sub new { my ( $class, $owner, $spec, $char, $params ) = @_; $spec ||= 'BOTH'; $char ||= ' '; my $self = $class->SUPER::new($owner); $self->{PARAMS} = $params; $self->{TRIMFN} = sub { my $s = $_[0]; $s =~ s/^$char*//g; return $s; } if ( $spec =~ m/LEADING/ ); $self->{TRIMFN} = sub { my $s = $_[0]; $s =~ s/$char*$//g; return $s; } if ( $spec =~ m/TRAILING/ ); $self->{TRIMFN} = sub { my $s = $_[0]; $s =~ s/^$char*//g; $s =~ s/$char*$//g; return $s; } if ( $spec =~ m/BOTH/ ); return $self; } sub value($) { my $val = $_[0]->{PARAMS}->[0]->value( $_[1] ); $val = &{ $_[0]->{TRIMFN} }($val); return $val; } package SQL::Statement::Function::SubString; use vars qw(@ISA); @ISA = qw(SQL::Statement::Function); =pod =head1 NAME SQL::Statement::Function::SubString - implements the built-in sub-string function support =head1 SYNOPSIS # create an substr function term with an SQL::Statement object as owner, # specifying the start and length of the sub string to extract from the # first element of \@params my $term = SQL::Statement::SubString->new( $owner, $start, $length, \@params ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Function::SubString implements a sub-string extraction term. =head1 INHERITANCE SQL::Statement::Function::SubString ISA SQL::Statement::Function ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates a new C instance. Takes I<$owner>, I<$start>, I<$length> and I<\@params> as arguments (in specified order). Meaning of the parameters: =over 4 =item I<$start> Specifies the start position to extract the sub-string. This is expected to be a L instance. The first character in a string has the position 1. =item I<$length> Specifies the length of the extracted sub-string. This is expected to be a L instance. If omitted, everything to the end of the string is returned. =item I<\@params> Expected to be an array with exact 1 element (more aren't evaluated). =back =head2 value Returns the extracted sub-string value from first parameter argument. =cut sub new { my ( $class, $owner, $start, $length, $params ) = @_; my $self = $class->SUPER::new($owner); $self->{START} = $start; $self->{LENGTH} = $length; $self->{PARAMS} = $params; return $self; } sub value($) { my $val = $_[0]->{PARAMS}->[0]->value( $_[1] ); my $start = $_[0]->{START}->value( $_[1] ) - 1; my $length = defined( $_[0]->{LENGTH} ) ? $_[0]->{LENGTH}->value( $_[1] ) : length($val) - $start; return substr( $val, $start, $length ); } package SQL::Statement::Function::StrConcat; use vars qw(@ISA); @ISA = qw(SQL::Statement::Function); =pod =head1 NAME SQL::Statement::Function::StrConcat - implements the built-in string concatenation =head1 SYNOPSIS # create an substr function term with an SQL::Statement object as owner # and \@params to concatenate my $term = SQL::Statement::StrConcat->new( $owner, \@params ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Function::StrConcat implements a string concatenation term. =head1 INHERITANCE SQL::Statement::Function::StrConcat ISA SQL::Statement::Function ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates a new C instance. =head2 value Returns the concatenated string composed of the parameter values. =cut sub new { my ( $class, $owner, $params ) = @_; my $self = $class->SUPER::new($owner); $self->{PARAMS} = $params; return $self; } sub value($) { my $rc = ''; foreach my $val ( @{ $_[0]->{PARAMS} } ) { my $catval = $val->value( $_[1] ); $rc .= defined($catval) ? $catval : ''; } return $rc; } =head1 AUTHOR AND COPYRIGHT Copyright (c) 2009,2010 by Jens Rehsack: rehsackATcpan.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. =cut 1; SQL-Statement-1.407/lib/SQL/Statement/Functions.pm000644 000765 000024 00000103374 12531013464 021556 0ustar00snostaff000000 000000 ################################## package SQL::Statement::Functions; ################################## use strict; use warnings FATAL => "all"; # no warnings 'uninitialized'; # please don't bother me with these useless warnings... use Carp qw(croak); use Params::Util qw(_ARRAY0 _HASH0 _INSTANCE); use Scalar::Util qw(looks_like_number); use List::Util qw(max); # core module since Perl 5.8.0 use Time::HiRes qw(time); # core module since Perl 5.7.2 use Encode; # core module since Perl 5.7.1 use Math::Trig; # core module since Perl 5.004 use Module::Runtime qw(require_module use_module); =pod =head1 NAME SQL::Statement::Functions - built-in & user-defined SQL functions =head1 SYNOPSIS SELECT Func(args); SELECT * FROM Func(args); SELECT * FROM x WHERE Funcs(args); SELECT * FROM x WHERE y < Funcs(args); =head1 DESCRIPTION This module contains the built-in functions for L and L. All of the functions are also available in any DBDs that subclass those modules (e.g. DBD::CSV, DBD::DBM, DBD::File, DBD::AnyData, DBD::Excel, etc.). This documentation covers built-in functions and also explains how to create your own functions to supplement the built-in ones. It's easy. If you create one that is generally useful, see below for how to submit it to become a built-in function. =head1 Function syntax When using L/L directly to parse SQL, functions (either built-in or user-defined) may occur anywhere in a SQL statement that values, column names, table names, or predicates may occur. When using the modules through a DBD or in any other context in which the SQL is both parsed and executed, functions can occur in the same places except that they can not occur in the column selection clause of a SELECT statement that contains a FROM clause. # valid for both parsing and executing SELECT MyFunc(args); SELECT * FROM MyFunc(args); SELECT * FROM x WHERE MyFuncs(args); SELECT * FROM x WHERE y < MyFuncs(args); # valid only for parsing (won't work from a DBD) SELECT MyFunc(args) FROM x WHERE y; =head1 User-Defined Functions =head2 Loading User-Defined Functions In addition to the built-in functions, you can create any number of your own user-defined functions (UDFs). In order to use a UDF in a script, you first have to create a perl subroutine (see below), then you need to make the function available to your database handle with the CREATE FUNCTION or LOAD commands: # load a single function "foo" from a subroutine # named "foo" in the current package $dbh->do(" CREATE FUNCTION foo EXTERNAL "); # load a single function "foo" from a subroutine # named "bar" in the current package $dbh->do(" CREATE FUNCTION foo EXTERNAL NAME bar"); # load a single function "foo" from a subroutine named "foo" # in another package $dbh->do(' CREATE FUNCTION foo EXTERNAL NAME "Bar::Baz::foo" '); # load all the functions in another package $dbh->do(' LOAD "Bar::Baz" '); Functions themselves should follow SQL identifier naming rules. Subroutines loaded with CREATE FUNCTION can have any valid perl subroutine name. Subroutines loaded with LOAD must start with SQL_FUNCTION_ and then the actual function name. For example: package Qux::Quimble; sub SQL_FUNCTION_FOO { ... } sub SQL_FUNCTION_BAR { ... } sub some_other_perl_subroutine_not_a_function { ... } 1; # in another package $dbh->do("LOAD Qux::Quimble"); # This loads FOO and BAR as SQL functions. =head2 Creating User-Defined Functions User-defined functions (UDFs) are perl subroutines that return values appropriate to the context of the function in a SQL statement. For example the built-in CURRENT_TIME returns a string value and therefore may be used anywhere in a SQL statement that a string value can. Here' the entire perl code for the function: # CURRENT_TIME # # arguments : none # returns : string containing current time as hh::mm::ss # sub SQL_FUNCTION_CURRENT_TIME { sprintf "%02s::%02s::%02s",(localtime)[2,1,0] } More complex functions can make use of a number of arguments always passed to functions automatically. Functions always receive these values in @_: sub FOO { my($self,$sth,@params); } The first argument, $self, is whatever class the function is defined in, not generally useful unless you have an entire module to support the function. The second argument, $sth is the active statement handle of the current statement. Like all active statement handles it contains the current database handle in the {Database} attribute so you can have access to the database handle in any function: sub FOO { my($self,$sth,@params); my $dbh = $sth->{Database}; # $dbh->do( ...), etc. } In actual practice you probably want to use $sth->{Database} directly rather than making a local copy, so $sth->{Database}->do(...). The remaining arguments, @params, are arguments passed by users to the function, either directly or with placeholders; another silly example which just returns the results of multiplying the arguments passed to it: sub MULTIPLY { my($self,$sth,@params); return $params[0] * $params[1]; } # first make the function available # $dbh->do("CREATE FUNCTION MULTIPLY"); # then multiply col3 in each row times seven # my $sth=$dbh->prepare("SELECT col1 FROM tbl1 WHERE col2 = MULTIPLY(col3,7)"); $sth->execute; # # or # my $sth=$dbh->prepare("SELECT col1 FROM tbl1 WHERE col2 = MULTIPLY(col3,?)"); $sth->execute(7); =head2 Creating In-Memory Tables with functions A function can return almost anything, as long is it is an appropriate return for the context the function will be used in. In the special case of table-returning functions, the function should return a reference to an array of array references with the first row being the column names and the remaining rows the data. For example: B<1. create a function that returns an AoA>, sub Japh {[ [qw( id word )], [qw( 1 Hacker )], [qw( 2 Perl )], [qw( 3 Another )], [qw( 4 Just )], ]} B<2. make your database handle aware of the function> $dbh->do("CREATE FUNCTION 'Japh'); B<3. Access the data in the AoA from SQL> $sth = $dbh->prepare("SELECT word FROM Japh ORDER BY id DESC"); Or here's an example that does a join on two in-memory tables: sub Prof {[ [qw(pid pname)],[qw(1 Sue )],[qw(2 Bob)],[qw(3 Tom )] ]} sub Class {[ [qw(pid cname)],[qw(1 Chem)],[qw(2 Bio)],[qw(2 Math)] ]} $dbh->do("CREATE FUNCTION $_) for qw(Prof Class); $sth = $dbh->prepare("SELECT * FROM Prof NATURAL JOIN Class"); The "Prof" and "Class" functions return tables which can be used like any SQL table. More complex functions might do something like scrape an RSS feed, or search a file system and put the results in AoA. For example, to search a directory with SQL: sub Dir { my($self,$sth,$dir)=@_; opendir D, $dir or die "'$dir':$!"; my @files = readdir D; my $data = [[qw(fileName fileExt)]]; for (@files) { my($fn,$ext) = /^(.*)(\.[^\.]+)$/; push @$data, [$fn,$ext]; } return $data; } $dbh->do("CREATE FUNCTION Dir"); printf "%s\n", join' ',@{ $dbh->selectcol_arrayref(" SELECT fileName FROM Dir('./') WHERE fileExt = '.pl' ")}; Obviously, that function could be expanded with File::Find and/or stat to provide more information and it could be made to accept a list of directories rather than a single directory. Table-Returning functions are a way to turn *anything* that can be modeled as an AoA into a DBI data source. =head1 Built-in Functions =head2 SQL-92/ODBC Compatibility All ODBC 3.0 functions are available except for the following: ### SQL-92 / ODBC Functions # CONVERT / CAST - Complex to implement, but a draft is in the works. # DIFFERENCE - Function is not clearly defined in spec and has very limited applications # EXTRACT - Contains a FROM keyword and requires rather freeform datetime/interval expression ### ODBC 3.0 Time/Date Functions only # DAYOFMONTH, DAYOFWEEK, DAYOFYEAR, HOUR, MINUTE, MONTH, MONTHNAME, QUARTER, SECOND, TIMESTAMPDIFF, # WEEK, YEAR - Requires freeform datetime/interval expressions. In a later release, these could # be implemented with the help of Date::Parse. ODBC 3.0 functions that are implemented with differences include: # SOUNDEX - Returns true/false, instead of a SOUNDEX code # RAND - Seed value is a second parameter with a new first parameter for max limit # LOG - Returns base X (or 10) log of number, not natural log. LN is used for natural log, and # LOG10 is still available for standards compatibility. # POSITION - Does not use 'IN' keyword; cannot be fixed as previous versions of SQL::Statement defined # the function as such. # REPLACE / SUBSTITUTE - Uses a regular expression string for the second parameter, replacing the last two # parameters of the typical ODBC function =cut use vars qw($VERSION); $VERSION = '1.407'; =pod =head2 Aggregate Functions =head3 MIN, MAX, AVG, SUM, COUNT Aggregate functions are handled elsewhere, see L for documentation. =pod =head2 Date and Time Functions These functions can be used without parentheses. =head3 CURRENT_DATE aka CURDATE # purpose : find current date # arguments : none # returns : string containing current date as yyyy-mm-dd =cut sub SQL_FUNCTION_CURRENT_DATE { my ( $sec, $min, $hour, $day, $mon, $year ) = localtime; return sprintf( '%4s-%02s-%02s', $year + 1900, $mon + 1, $day ); } no warnings 'once'; *SQL_FUNCTION_CURDATE = \&SQL_FUNCTION_CURRENT_DATE; use warnings 'all'; =pod =head3 CURRENT_TIME aka CURTIME # purpose : find current time # arguments : optional seconds precision # returns : string containing current time as hh:mm:ss (or ss.sss...) =cut sub SQL_FUNCTION_CURRENT_TIME { return substr( SQL_FUNCTION_CURRENT_TIMESTAMP( @_[ 0 .. 2 ] ), 11 ); } no warnings 'once'; *SQL_FUNCTION_CURTIME = \&SQL_FUNCTION_CURRENT_TIME; use warnings 'all'; =pod =head3 CURRENT_TIMESTAMP aka NOW # purpose : find current date and time # arguments : optional seconds precision # returns : string containing current timestamp as yyyy-mm-dd hh:mm:ss (or ss.sss...) =cut sub SQL_FUNCTION_CURRENT_TIMESTAMP { my $prec; my $curtime = time; my ( $sec, $min, $hour, $day, $mon, $year ) = localtime($curtime); my $sec_frac; if ( $_[2] ) { $prec = int( $_[2] ); $sec_frac = sprintf( '%.*f', $prec, $curtime - int($curtime) ); $sec_frac = substr( $sec_frac, 2 ); # truncate 0. from decimal } return sprintf( '%4s-%02s-%02s %02s:%02s:%02s' . ( $prec ? '.%s' : '' ), $year + 1900, $mon + 1, $day, $hour, $min, $sec, ( $prec ? $sec_frac : ()) ); } no warnings 'once'; *SQL_FUNCTION_NOW = \&SQL_FUNCTION_CURRENT_TIMESTAMP; use warnings 'all'; =pod =head3 UNIX_TIMESTAMP # purpose : find the current time in UNIX epoch format # arguments : optional seconds precision (unlike the MySQL version) # returns : a (64-bit) number, possibly with decimals =cut sub SQL_FUNCTION_UNIX_TIMESTAMP { return sprintf( "%.*f", $_[2] ? int( $_[2] ) : 0, time ); } =pod =head2 String Functions =head3 ASCII & CHAR # purpose : same as ord and chr, respectively (NULL for any NULL args) # arguments : string or character (or number for CHAR); CHAR can have any amount of numbers for a string =cut sub SQL_FUNCTION_ASCII { return defined $_[2] ? ord( $_[2] ) : undef; } sub SQL_FUNCTION_CHAR { my ( $self, $owner, @params ) = @_; ( defined || return undef ) for (@params); return join '', map { chr } @params; } =pod =head3 BIT_LENGTH # purpose : length of the string in bits # arguments : string =cut sub SQL_FUNCTION_BIT_LENGTH { my @v = @_[ 0 .. 1 ]; my $str = $_[2]; # Number of bits on first character = INT(LOG2(ord($str)) + 1) + rest of string = OCTET_LENGTH(substr($str, 1)) * 8 return int( SQL_FUNCTION_LOG( @v, 2, ord($str) ) + 1 ) + SQL_FUNCTION_OCTET_LENGTH( @v, substr( $str, 1 ) ) * 8; } =pod =head3 CHARACTER_LENGTH aka CHAR_LENGTH # purpose : find length in characters of a string # arguments : a string # returns : a number - the length of the string in characters =cut sub SQL_FUNCTION_CHAR_LENGTH { my ( $self, $owner, $str ) = @_; return length($str); } no warnings 'once'; *SQL_FUNCTION_CHARACTER_LENGTH = \&SQL_FUNCTION_CHAR_LENGTH; use warnings 'all'; =pod =head3 COALESCE aka NVL aka IFNULL # purpose : return the first non-NULL value from a list # arguments : 1 or more expressions # returns : the first expression (reading left to right) # which is not NULL; returns NULL if all are NULL # =cut sub SQL_FUNCTION_COALESCE { my ( $self, $owner, @params ) = @_; # # eval each expr in list until a non-null # is encountered, then return it # foreach (@params) { return $_ if defined($_); } return undef; } no warnings 'once'; *SQL_FUNCTION_NVL = \&SQL_FUNCTION_COALESCE; *SQL_FUNCTION_IFNULL = \&SQL_FUNCTION_COALESCE; use warnings 'all'; =pod =head3 CONCAT # purpose : concatenate 1 or more strings into a single string; # an alternative to the '||' operator # arguments : 1 or more strings # returns : the concatenated string # # example : SELECT CONCAT(first_string, 'this string', ' that string') # returns "this string that string" # note : if any argument evaluates to NULL, the returned value is NULL =cut sub SQL_FUNCTION_CONCAT { my ( $self, $owner, @params ) = @_; ( defined || return undef ) for (@params); return join '', @params; } =pod =head3 CONV # purpose : convert a number X from base Y to base Z (from base 2 to 64) # arguments : X (can by a number or string depending on the base), Y, Z (Z defaults to 10) Valid bases for Y and Z are: 2, 8, 10, 16 and 64 # returns : either a string or number, in base Z # notes : Behavioral table # # base | valuation # ------+----------- # 2 | binary, base 2 - (0,1) # 8 | octal, base 8 - (0..7) # 10 | decimal, base 10 - (0..9) # 16 | hexadecimal, base 16 - (0..9,a..f) # 64 | 0-63 from MIME::Base64 # =cut sub SQL_FUNCTION_CONV { my ( $self, $owner, $num, $sbase, $ebase ) = @_; $ebase ||= 10; $_ and $_ != 2 and $_ != 8 and $_ != 10 and $_ != 16 and $_ != 64 and croak("Invalid base: $_") for ($sbase, $ebase); scalar use_module("Math::Base::Convert")->new($sbase, $ebase)->cnv($num); } =pod =head3 DECODE # purpose : compare the first argument against # succeding arguments at position 1 + 2N # (N = 0 to (# of arguments - 2)/2), and if equal, # return the value of the argument at 1 + 2N + 1; if no # arguments are equal, the last argument value is returned # arguments : 4 or more expressions, must be even # of arguments # returns : the value of the argument at 1 + 2N + 1 if argument 1 + 2N # is equal to argument1; else the last argument value # # example : SELECT DECODE(some_column, # 'first value', 'first value matched' # '2nd value', '2nd value matched' # 'no value matched' # ) =cut # # emulate Oracle DECODE; behaves same as # CASE expr WHEN THEN expr3 # WHEN expr4 THEN expr5 # ... # ELSE exprN END # sub SQL_FUNCTION_DECODE { my ( $self, $owner, @params ) = @_; # # check param list size, must be at least 4, # and even in length # no warnings 'precedence'; die 'Invalid DECODE argument list!' unless ( ( scalar @params > 3 ) && ( $#params & 1 == 1 ) ); # # eval first argument, and last argument, # then eval and compare each succeeding pair of args # be careful about NULLs! # my $lhs = shift @params; my $default = pop @params; return $default unless defined($lhs); my $lhs_isnum = looks_like_number($lhs); while (@params) { my $rhs = shift @params; shift @params, next unless defined($rhs); return shift @params if ( ( looks_like_number($rhs) && $lhs_isnum && ( $lhs == $rhs ) ) || ( $lhs eq $rhs ) ); shift @params; } return $default; } =pod =head3 INSERT # purpose : string where L characters have been deleted from STR1, beginning at S, # and where STR2 has been inserted into STR1, beginning at S. NULL for any NULL args. # arguments : STR1, S, L, STR2 =cut sub SQL_FUNCTION_INSERT { # just like a 4-parameter substr in Perl ( defined || return undef ) for ( @_[ 2 .. 5 ] ); my $str = $_[2]; no warnings 'void'; substr( $str, $_[3] - 1, $_[4], $_[5] ); return $str; } =pod =head3 HEX & OCT & BIN # purpose : convert number X from decimal to hex/octal/binary; equiv. to CONV(X, 10, 16/8/2) # arguments : X =cut sub SQL_FUNCTION_HEX { return shift->SQL_FUNCTION_CONV( @_[ 0 .. 1 ], 10, 16 ); } sub SQL_FUNCTION_OCT { return shift->SQL_FUNCTION_CONV( @_[ 0 .. 1 ], 10, 8 ); } sub SQL_FUNCTION_BIN { return shift->SQL_FUNCTION_CONV( @_[ 0 .. 1 ], 10, 2 ); } =pod =head3 LEFT & RIGHT # purpose : leftmost or rightmost L characters in STR, or NULL for any NULL args # arguments : STR1, L =cut sub SQL_FUNCTION_LEFT { ( defined || return undef ) for ( @_[ 2 .. 3 ] ); return substr( $_[2], 0, $_[3] ); } sub SQL_FUNCTION_RIGHT { ( defined || return undef ) for ( @_[ 2 .. 3 ] ); return substr( $_[2], -$_[3] ); } =pod =head3 LOCATE aka POSITION # purpose : starting position (one-based) of the first occurrence of STR1 within STR2; 0 if it doesn't occur and NULL for any NULL args # arguments : STR1, STR2, and an optional S (starting position to search) =cut sub SQL_FUNCTION_LOCATE { ( defined || return undef ) for ( @_[ 2 .. 3 ] ); my ( $self, $owner, $substr, $str, $s ) = @_; $s = int( $s || 0 ); my $pos = index( substr( $str, $s ), $substr ) + 1; return $pos && $pos + $s; } no warnings 'once'; *SQL_FUNCTION_POSITION = \&SQL_FUNCTION_LOCATE; use warnings 'all'; =pod =head3 LOWER & UPPER aka LCASE & UCASE # purpose : lower-case or upper-case a string # arguments : a string # returns : the sting lower or upper cased =cut sub SQL_FUNCTION_LOWER { my ( $self, $owner, $str ) = @_; return lc($str); } sub SQL_FUNCTION_UPPER { my ( $self, $owner, $str ) = @_; return uc($str); } no warnings 'once'; *SQL_FUNCTION_UCASE = \&SQL_FUNCTION_UPPER; *SQL_FUNCTION_LCASE = \&SQL_FUNCTION_LOWER; use warnings 'all'; =pod =head3 LTRIM & RTRIM # purpose : left/right counterparts for TRIM # arguments : string =cut sub SQL_FUNCTION_LTRIM { my $str = $_[2]; $str =~ s/^\s+//; return $str; } sub SQL_FUNCTION_RTRIM { my $str = $_[2]; $str =~ s/\s+$//; return $str; } =pod =head3 OCTET_LENGTH # purpose : length of the string in bytes (not characters) # arguments : string =cut sub SQL_FUNCTION_OCTET_LENGTH { return length( Encode::encode_utf8( $_[2] ) ); } # per Perldoc =pod =head3 REGEX # purpose : test if a string matches a perl regular expression # arguments : a string and a regex to match the string against # returns : boolean value of the regex match # # example : ... WHERE REGEX(col3,'/^fun/i') ... matches rows # in which col3 starts with "fun", ignoring case =cut sub SQL_FUNCTION_REGEX { my ( $self, $owner, @params ) = @_; ( defined || return 0 ) for ( @params[ 0 .. 1 ] ); my ( $pattern, $modifier ) = $params[1] =~ m~^/(.+)/([a-z]*)$~; $pattern = "(?$modifier:$pattern)" if ($modifier); return ( $params[0] =~ qr($pattern) ) ? 1 : 0; } =pod =head3 REPEAT # purpose : string composed of STR1 repeated C times, or NULL for any NULL args # arguments : STR1, C =cut sub SQL_FUNCTION_REPEAT { ( defined || return undef ) for ( @_[ 2 .. 3 ] ); return $_[2] x int( $_[3] ); } =pod =head3 REPLACE aka SUBSTITUTE # purpose : perform perl subsitution on input string # arguments : a string and a substitute pattern string # returns : the result of the substitute operation # # example : ... WHERE REPLACE(col3,'s/fun(\w+)nier/$1/ig') ... replaces # all instances of /fun(\w+)nier/ in col3 with the string # between 'fun' and 'nier' =cut sub SQL_FUNCTION_REPLACE { my ( $self, $owner, @params ) = @_; return undef unless defined $params[0] and defined $params[1]; eval "\$params[0]=~$params[1]"; return $@ ? undef : $params[0]; } no warnings 'once'; *SQL_FUNCTION_SUBSTITUTE = \&SQL_FUNCTION_REPLACE; use warnings 'all'; =pod =head3 SOUNDEX # purpose : test if two strings have matching soundex codes # arguments : two strings # returns : true if the strings share the same soundex code # # example : ... WHERE SOUNDEX(col3,'fun') ... matches rows # in which col3 is a soundex match for "fun" =cut sub SQL_FUNCTION_SOUNDEX { my ( $self, $owner, @params ) = @_; require_module("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 ) ? 1 : 0; } =pod =head3 SPACE # purpose : a string of spaces # arguments : number of spaces =cut sub SQL_FUNCTION_SPACE { return ' ' x int( $_[2] ); } =pod =head3 SUBSTRING SUBSTRING( string FROM start_pos [FOR length] ) Returns the substring starting at start_pos and extending for "length" character or until the end of the string, if no "length" is supplied. Examples: SUBSTRING( 'foobar' FROM 4 ) # returns "bar" SUBSTRING( 'foobar' FROM 4 FOR 2) # returns "ba" Note: The SUBSTRING function is implemented in L and L and, at the current time, can not be over-ridden. =head3 SUBSTR # purpose : same as SUBSTRING, except with comma-delimited params, instead of words (NULL for any NULL args) # arguments : string, start_pos, [length] =cut sub SQL_FUNCTION_SUBSTR { my ( $self, $owner, @params ) = @_; ( defined || return undef ) for ( @params[ 0 .. 2 ] ); 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; return $value; } =pod =head3 TRANSLATE # purpose : transliteration; replace a set of characters in a string with another set of characters (a la tr///), or NULL for any NULL args # arguments : string, string to replace, replacement string =cut sub SQL_FUNCTION_TRANSLATE { my ( $self, $owner, $str, $oldlist, $newlist ) = @_; $oldlist =~ s{(/\-)}{\\$1}g; $newlist =~ s{(/\-)}{\\$1}g; eval "\$str =~ tr/$oldlist/$newlist/"; return $str; } =pod =head3 TRIM TRIM ( [ [LEADING|TRAILING|BOTH] ['trim_char'] FROM ] string ) Removes all occurrences of from the front, back, or both sides of a string. BOTH is the default if neither LEADING nor TRAILING is specified. Space is the default if no trim_char is specified. Examples: TRIM( string ) trims leading and trailing spaces from string TRIM( LEADING FROM str ) trims leading spaces from string TRIM( 'x' FROM str ) trims leading and trailing x's from string Note: The TRIM function is implemented in L and L and, at the current time, can not be over-ridden. =pod =head3 UNHEX # purpose : convert each pair of hexadecimal digits to a byte (or a Unicode character) # arguments : string of hex digits, with an optional encoding name of the data string =cut sub SQL_FUNCTION_UNHEX { my ( $self, $owner, $hex, $encoding ) = @_; return undef unless ( defined $hex ); $hex =~ s/\s+//g; $hex =~ s/[^0-9a-fA-F]+//g; my $str = ''; foreach my $i ( 0 .. int( ( length($hex) - 1 ) / 2 ) ) { $str .= pack( 'C', SQL_FUNCTION_CONV( $self, $owner, substr( $hex, $i * 2, 2 ), 16, 10 ) ); } return $encoding ? Encode::decode( $encoding, $str, Encode::FB_WARN ) : $str; } =head2 Numeric Functions =head3 ABS # purpose : find the absolute value of a given numeric expression # arguments : numeric expression =cut sub SQL_FUNCTION_ABS { return abs( $_[2] ); } =pod =head3 CEILING (aka CEIL) & FLOOR # purpose : rounds up/down to the nearest integer # arguments : numeric expression =cut sub SQL_FUNCTION_CEILING { my $i = int( $_[2] ); return $i == $_[2] ? $i : SQL_FUNCTION_ROUND( @_[ 0 .. 1 ], $_[2] + 0.5, 0 ); } sub SQL_FUNCTION_FLOOR { my $i = int( $_[2] ); return $i == $_[2] ? $i : SQL_FUNCTION_ROUND( @_[ 0 .. 1 ], $_[2] - 0.5, 0 ); } no warnings 'once'; *SQL_FUNCTION_CEIL = \&SQL_FUNCTION_CEILING; use warnings 'all'; =pod =head3 EXP # purpose : raise e to the power of a number # arguments : numeric expression =cut sub SQL_FUNCTION_EXP { return ( sinh(1) + cosh(1) )**$_[2]; } # e = sinh(X)+cosh(X) =pod =head3 LOG # purpose : base B logarithm of X # arguments : B, X or just one argument of X for base 10 =cut sub SQL_FUNCTION_LOG { return $_[3] ? log( $_[3] ) / log( $_[2] ) : log( $_[2] ) / log(10); } =pod =head3 LN & LOG10 # purpose : natural logarithm (base e) or base 10 of X # arguments : numeric expression =cut sub SQL_FUNCTION_LN { return log( $_[2] ); } sub SQL_FUNCTION_LOG10 { return SQL_FUNCTION_LOG( @_[ 0 .. 2 ] ); } =pod =head3 MOD # purpose : modulus, or remainder, left over from dividing X / Y # arguments : X, Y =cut sub SQL_FUNCTION_MOD { return $_[2] % $_[3]; } =pod =head3 POWER aka POW # purpose : X to the power of Y # arguments : X, Y =cut sub SQL_FUNCTION_POWER { return $_[2]**$_[3]; } no warnings 'once'; *SQL_FUNCTION_POW = \&SQL_FUNCTION_POWER; use warnings 'all'; =pod =head3 RAND # purpose : random fractional number greater than or equal to 0 and less than the value of X # arguments : X (with optional seed value of Y) =cut sub SQL_FUNCTION_RAND { $_[3] && srand( $_[3] ); return rand( $_[2] ); } =pod =head3 ROUND # purpose : round X with Y number of decimal digits (precision) # arguments : X, optional Y defaults to 0 =cut sub SQL_FUNCTION_ROUND { return sprintf( "%.*f", $_[3] ? int( $_[3] ) : 0, $_[2] ); } =pod =head3 SIGN # purpose : returns -1, 0, 1, NULL for negative, 0, positive, NULL values, respectively # arguments : numeric expression =cut sub SQL_FUNCTION_SIGN { return defined( $_[2] ) ? ( $_[2] <=> 0 ) : undef; } =pod =head3 SQRT # purpose : square root of X # arguments : X =cut sub SQL_FUNCTION_SQRT { return sqrt( $_[2] ); } =pod =head3 TRUNCATE aka TRUNC # purpose : similar to ROUND, but removes the decimal # arguments : X, optional Y defaults to 0 =cut sub SQL_FUNCTION_TRUNCATE { my $c = int( $_[3] || 0 ); my $d = 10**$c; return sprintf( "%.*f", $c, int( $_[2] * $d ) / $d ); } no warnings 'once'; *SQL_FUNCTION_TRUNC = \&SQL_FUNCTION_TRUNCATE; use warnings 'all'; =pod =head2 Trigonometric Functions All of these functions work exactly like their counterparts in L; go there for documentation. =cut =over =item ACOS =item ACOSEC =item ACOSECH =item ACOSH =item ACOT =item ACOTAN =item ACOTANH =item ACOTH =item ACSC =item ACSCH =item ASEC =item ASECH =item ASIN =item ASINH =item ATAN =item ATANH =item COS =item COSEC =item COSECH =item COSH =item COT =item COTAN =item COTANH =item COTH =item CSC =item CSCH =item SEC =item SECH =item SIN =item SINH =item TAN =item TANH Takes a single parameter. All of L's aliases are included. =item ATAN2 The y,x version of arc tangent. =item DEG2DEG =item DEG2GRAD =item DEG2RAD Converts out-of-bounds values into its correct range. =item GRAD2DEG =item GRAD2GRAD =item GRAD2RAD =item RAD2DEG =item RAD2GRAD =item RAD2RAD Like their L's counterparts, accepts an optional 2nd boolean parameter (like B) to keep prevent range wrapping. =item DEGREES =item RADIANS B and B are included for SQL-92 compatibility, and map to B and B, respectively. =item PI B can be used without parentheses. =back =cut sub SQL_FUNCTION_ACOS { return acos( $_[2] || 0 ); } sub SQL_FUNCTION_ACOSEC { return acosec( $_[2] || 0 ); } sub SQL_FUNCTION_ACOSECH { return acosech( $_[2] || 0 ); } sub SQL_FUNCTION_ACOSH { return acosh( $_[2] || 0 ); } sub SQL_FUNCTION_ACOT { return acot( $_[2] || 0 ); } sub SQL_FUNCTION_ACOTAN { return acotan( $_[2] || 0 ); } sub SQL_FUNCTION_ACOTANH { return acotanh( $_[2] || 0 ); } sub SQL_FUNCTION_ACOTH { return acoth( $_[2] || 0 ); } sub SQL_FUNCTION_ACSC { return acsc( $_[2] || 0 ); } sub SQL_FUNCTION_ACSCH { return acsch( $_[2] || 0 ); } sub SQL_FUNCTION_ASEC { return asec( $_[2] || 0 ); } sub SQL_FUNCTION_ASECH { return asech( $_[2] || 0 ); } sub SQL_FUNCTION_ASIN { return asin( $_[2] || 0 ); } sub SQL_FUNCTION_ASINH { return asinh( $_[2] || 0 ); } sub SQL_FUNCTION_ATAN { return atan( $_[2] || 0 ); } sub SQL_FUNCTION_ATAN2 { return atan2( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_ATANH { return atanh( $_[2] || 0 ); } sub SQL_FUNCTION_COS { return cos( $_[2] || 0 ); } sub SQL_FUNCTION_COSEC { return cosec( $_[2] || 0 ); } sub SQL_FUNCTION_COSECH { return cosech( $_[2] || 0 ); } sub SQL_FUNCTION_COSH { return cosh( $_[2] || 0 ); } sub SQL_FUNCTION_COT { return cot( $_[2] || 0 ); } sub SQL_FUNCTION_COTAN { return cotan( $_[2] || 0 ); } sub SQL_FUNCTION_COTANH { return cotanh( $_[2] || 0 ); } sub SQL_FUNCTION_COTH { return coth( $_[2] || 0 ); } sub SQL_FUNCTION_CSC { return csc( $_[2] || 0 ); } sub SQL_FUNCTION_CSCH { return csch( $_[2] || 0 ); } sub SQL_FUNCTION_DEG2DEG { return deg2deg( $_[2] || 0 ); } sub SQL_FUNCTION_RAD2RAD { return rad2rad( $_[2] || 0 ); } sub SQL_FUNCTION_GRAD2GRAD { return grad2grad( $_[2] || 0 ); } sub SQL_FUNCTION_DEG2GRAD { return deg2grad( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_DEG2RAD { return deg2rad( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_DEGREES { return rad2deg( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_GRAD2DEG { return grad2deg( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_GRAD2RAD { return grad2rad( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_PI { return pi; } sub SQL_FUNCTION_RAD2DEG { return rad2deg( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_RAD2GRAD { return rad2grad( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_RADIANS { return deg2rad( $_[2] || 0, $_[3] || 0 ); } sub SQL_FUNCTION_SEC { return sec( $_[2] || 0 ); } sub SQL_FUNCTION_SECH { return sech( $_[2] || 0 ); } sub SQL_FUNCTION_SIN { return sin( $_[2] || 0 ); } sub SQL_FUNCTION_SINH { return sinh( $_[2] || 0 ); } sub SQL_FUNCTION_TAN { return tan( $_[2] || 0 ); } sub SQL_FUNCTION_TANH { return tanh( $_[2] || 0 ); } =head2 System Functions =head3 DBNAME & USERNAME (aka USER) # purpose : name of the database / username # arguments : none =cut sub SQL_FUNCTION_DBNAME { return $_[1]->{Database}{Name}; } sub SQL_FUNCTION_USERNAME { return $_[1]->{Database}{CURRENT_USER}; } no warnings 'once'; *SQL_FUNCTION_USER = \&SQL_FUNCTION_USERNAME; use warnings 'all'; =head2 Special Utility Functions =head3 IMPORT CREATE TABLE foo AS IMPORT(?) ,{},$external_executed_sth CREATE TABLE foo AS IMPORT(?) ,{},$AoA =cut sub SQL_FUNCTION_IMPORT { my ( $self, $owner, @params ) = @_; if ( _ARRAY0( $params[0] ) ) { return $params[0] unless ( _HASH0( $params[0]->[0] ) ); my @tbl = (); for my $row ( @{ $params[0] } ) { my @cols = sort keys %{$row}; push @tbl, \@cols unless @tbl; push @tbl, [ @$row{@cols} ]; } return \@tbl; } elsif ( _INSTANCE( $params[0], 'DBI::st' ) ) { my @cols; @cols = @{ $params[0]->{NAME} } unless @cols; # push @{$sth->{org_names}},$_ for @cols; my $tbl = [ \@cols ]; while ( my @row = $params[0]->fetchrow_array() ) { push @$tbl, \@row; } return $tbl; } } =head3 RUN Takes the name of a file containing SQL statements and runs the statements; see L for documentation. =cut sub SQL_FUNCTION_RUN { my ( $self, $owner, $file ) = @_; my @params = $owner->{sql_stmt}->params(); @params = () unless @params; local *IN; open( IN, '<', $file ) or die "Couldn't open SQL File '$file': $!\n"; my @stmts = split /;\s*\n+/, join '', ; $stmts[-1] =~ s/;\s*$//; close IN; my @results = (); for my $sql (@stmts) { my $tmp_sth = $owner->{Database}->prepare($sql); $tmp_sth->execute(@params); next unless $tmp_sth->{NUM_OF_FIELDS}; push @results, $tmp_sth->{NAME} unless @results; while ( my @r = $tmp_sth->fetchrow_array() ) { push @results, \@r } } #use Data::Dumper; print Dumper \@results and exit if @results; return \@results; } =pod =head1 Submitting built-in functions If you make a generally useful UDF, why not submit it to me and have it (and your name) included with the built-in functions? Please follow the format shown in the module including a description of the arguments and return values for the function as well as an example. Send them to the dbi-dev@perl.org mailing list (see L). Thanks in advance :-). =head1 ACKNOWLEDGEMENTS Dean Arnold supplied DECODE, COALESCE, REPLACE, many thanks! Brendan Byrd added in the Numeric/Trig/System functions and filled in the SQL92/ODBC gaps for the date/string functions. =head1 AUTHOR & COPYRIGHT Copyright (c) 2005 by Jeff Zucker: jzuckerATcpan.org Copyright (c) 2009,2010 by Jens Rehsack: rehsackATcpan.org All rights reserved. The module may be freely distributed under the same terms as Perl itself using either the "GPL License" or the "Artistic License" as specified in the Perl README file. =cut 1; SQL-Statement-1.407/lib/SQL/Statement/GetInfo.pm000755 000765 000024 00000064243 12531013464 021145 0ustar00snostaff000000 000000 package SQL::Statement::GetInfo; use strict; use warnings FATAL => "all"; use vars qw($VERSION %info); $VERSION = '1.407'; use SQL::Statement(); my @Keywords = qw( INTEGERVAL STRING REALVAL IDENT NULLVAL PARAM OPERATOR IS AND OR ERROR INSERT UPDATE SELECT DELETE DROP CREATE ALL DISTINCT WHERE ORDER ASC DESC FROM INTO BY VALUES SET NOT TABLE CHAR VARCHAR REAL INTEGER PRIMARY KEY BLOB TEXT ); # FIXME: This should really use the SQL::Dialect keywords, a la: # return join(',', keys %{ SQL::Dialects::Foobar::get_config_as_hash()->{reserved_words} }); sub sql_keywords { return join ',', @Keywords; } %info = ( 20 => "N" # SQL_ACCESSIBLE_PROCEDURES , 19 => "Y" # SQL_ACCESSIBLE_TABLES # 0 => undef # SQL_ACTIVE_CONNECTIONS # 116 => undef # SQL_ACTIVE_ENVIRONMENTS # 1 => undef # SQL_ACTIVE_STATEMENTS , 169 => 0x0000007F # SQL_AGGREGATE_FUNCTIONS # SQL_AF_AVG + 1 # SQL_AF_COUNT + 2 # SQL_AF_MAX + 4 # SQL_AF_MIN + 8 # SQL_AF_SUM + 10 # SQL_AF_DISTINCT + 20 # SQL_AF_ALL + 40 , 117 => 0 # SQL_ALTER_DOMAIN - , 86 => 0 # SQL_ALTER_TABLE - # 10021 => undef # SQL_ASYNC_MODE # 120 => undef # SQL_BATCH_ROW_COUNT # 121 => undef # SQL_BATCH_SUPPORT # 82 => undef # SQL_BOOKMARK_PERSISTENCE , 114 => 1 # SQL_CATALOG_LOCATION , 10003 => "N" # SQL_CATALOG_NAME , 41 => '.' # SQL_CATALOG_NAME_SEPARATOR , 42 => "" # SQL_CATALOG_TERM , 92 => 0 # SQL_CATALOG_USAGE # # 10004 => undef # SQL_COLLATING_SEQUENCE , 10004 => "ISO-8859-1" # SQL_COLLATION_SEQ , 87 => "Y" # SQL_COLUMN_ALIAS , 22 => 0 # SQL_CONCAT_NULL_BEHAVIOR # # CONVERT FUNCTION NOT CURRENTLY SUPPORTED # , 53 => 0 # SQL_CONVERT_BIGINT , 54 => 0 # SQL_CONVERT_BINARY , 55 => 0 # SQL_CONVERT_BIT , 56 => 0 # SQL_CONVERT_CHAR , 57 => 0 # SQL_CONVERT_DATE , 58 => 0 # SQL_CONVERT_DECIMAL , 59 => 0 # SQL_CONVERT_DOUBLE , 60 => 0 # SQL_CONVERT_FLOAT , 48 => 0 # SQL_CONVERT_FUNCTIONS , 173 => 0 # SQL_CONVERT_GUID , 61 => 0 # SQL_CONVERT_INTEGER , 123 => 0 # SQL_CONVERT_INTERVAL_DAY_TIME , 124 => 0 # SQL_CONVERT_INTERVAL_YEAR_MONTH , 71 => 0 # SQL_CONVERT_LONGVARBINARY , 62 => 0 # SQL_CONVERT_LONGVARCHAR , 63 => 0 # SQL_CONVERT_NUMERIC , 64 => 0 # SQL_CONVERT_REAL , 65 => 0 # SQL_CONVERT_SMALLINT , 66 => 0 # SQL_CONVERT_TIME , 67 => 0 # SQL_CONVERT_TIMESTAMP , 68 => 0 # SQL_CONVERT_TINYINT , 69 => 0 # SQL_CONVERT_VARBINARY , 70 => 0 # SQL_CONVERT_VARCHAR , 122 => 0 # SQL_CONVERT_WCHAR , 125 => 0 # SQL_CONVERT_WLONGVARCHAR , 126 => 0 # SQL_CONVERT_WVARCHAR , 74 => 2 # SQL_CORRELATION_NAME , 127 => 0 # SQL_CREATE_ASSERTION , 128 => 0 # SQL_CREATE_CHARACTER_SET , 129 => 0 # SQL_CREATE_COLLATION , 130 => 0 # SQL_CREATE_DOMAIN , 131 => 0 # SQL_CREATE_SCHEMA , 132 => 0x00000015 # SQL_CREATE_TABLE # SQL_CT_CREATE_TABLE => 0x00000001 + # SQL_CT_COMMIT_PRESERVE => 0x00000002 # SQL_CT_COMMIT_DELETE => 0x00000004 + # SQL_CT_GLOBAL_TEMPORARY => 0x00000008 # SQL_CT_LOCAL_TEMPORARY => 0x00000010 + # SQL_CT_CONSTRAINT_INITIALLY_DEFERRED => 0x00000020 # SQL_CT_CONSTRAINT_INITIALLY_IMMEDIATE => 0x00000040 # SQL_CT_CONSTRAINT_DEFERRABLE => 0x00000080 # SQL_CT_CONSTRAINT_NON_DEFERRABLE => 0x00000100 # SQL_CT_COLUMN_CONSTRAINT => 0x00000200 # SQL_CT_COLUMN_DEFAULT => 0x00000400 # SQL_CT_COLUMN_COLLATION => 0x00000800 # SQL_CT_TABLE_CONSTRAINT => 0x00001000 # SQL_CT_CONSTRAINT_NAME_DEFINITION => 0x00002000 , 133 => 0 # SQL_CREATE_TRANSLATION , 134 => 0 # SQL_CREATE_VIEW # # CURSORS NOT CURRENTLY SUPPORTED # # 23 => undef, # SQL_CURSOR_COMMIT_BEHAVIOR # 24 => undef, # SQL_CURSOR_ROLLBACK_BEHAVIOR # 10001 => undef, # SQL_CURSOR_SENSITIVITY # #, 2 => \&sql_data_source_name # SQL_DATA_SOURCE_NAME , 25 => "N" # SQL_DATA_SOURCE_READ_ONLY , 119 => 0 # SQL_DATETIME_LITERALS #, 17 => \&sql_driver_name # SQL_DBMS_NAME #, 18 => \&sql_driver_ver # SQL_DBMS_VER # 18 => undef # SQL_DBMS_VERSION # 170 => undef, # SQL_DDL_INDEX # 26 => undef, # SQL_DEFAULT_TRANSACTION_ISOLATION # 26 => undef # SQL_DEFAULT_TXN_ISOLATION , 10002 => "N" # SQL_DESCRIBE_PARAMETER # 171 => undef # SQL_DM_VER # 3 => undef # SQL_DRIVER_HDBC # 135 => undef # SQL_DRIVER_HDESC # 4 => undef # SQL_DRIVER_HENV # 76 => undef # SQL_DRIVER_HLIB # 5 => undef # SQL_DRIVER_HSTMT #, 6 => \&sql_driver_name # SQL_DRIVER_NAME # 77 => undef # SQL_DRIVER_ODBC_VER #, 7 => \&sql_driver_ver # SQL_DRIVER_VER , 136 => 0 # SQL_DROP_ASSERTION , 137 => 0 # SQL_DROP_CHARACTER_SET , 138 => 0 # SQL_DROP_COLLATION , 139 => 0 # SQL_DROP_DOMAIN , 140 => 0 # SQL_DROP_SCHEMA , 141 => 1 # SQL_DROP_TABLE , 142 => 0 # SQL_DROP_TRANSLATION , 143 => 0 # SQL_DROP_VIEW # 144 => undef # SQL_DYNAMIC_CURSOR_ATTRIBUTES1 # 145 => undef # SQL_DYNAMIC_CURSOR_ATTRIBUTES2 # 27 => undef # SQL_EXPRESSIONS_IN_ORDERBY # 8 => undef # SQL_FETCH_DIRECTION , 84 => 1 # SQL_FILE_USAGE # 146 => undef # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES1 # 147 => undef # SQL_FORWARD_ONLY_CURSOR_ATTRIBUTES2 # 81 => undef # SQL_GETDATA_EXTENSIONS # 88 => undef # SQL_GROUP_BY , 28 => 4 # SQL_IDENTIFIER_CASE , 29 => q(") # SQL_IDENTIFIER_QUOTE_CHAR # 148 => undef # SQL_INDEX_KEYWORDS # 149 => undef # SQL_INFO_SCHEMA_VIEWS , 172 => 1 # SQL_INSERT_STATEMENT # 73 => undef # SQL_INTEGRITY # 150 => undef # SQL_KEYSET_CURSOR_ATTRIBUTES1 # 151 => undef # SQL_KEYSET_CURSOR_ATTRIBUTES2 , 89 => \&sql_keywords # SQL_KEYWORDS , 113 => "N" # SQL_LIKE_ESCAPE_CLAUSE # 78 => undef # SQL_LOCK_TYPES # 34 => undef # SQL_MAXIMUM_CATALOG_NAME_LENGTH # 97 => undef # SQL_MAXIMUM_COLUMNS_IN_GROUP_BY # 98 => undef # SQL_MAXIMUM_COLUMNS_IN_INDEX # 99 => undef # SQL_MAXIMUM_COLUMNS_IN_ORDER_BY # 100 => undef # SQL_MAXIMUM_COLUMNS_IN_SELECT # 101 => undef # SQL_MAXIMUM_COLUMNS_IN_TABLE # 30 => undef # SQL_MAXIMUM_COLUMN_NAME_LENGTH # 1 => undef # SQL_MAXIMUM_CONCURRENT_ACTIVITIES # 31 => undef # SQL_MAXIMUM_CURSOR_NAME_LENGTH # 0 => undef # SQL_MAXIMUM_DRIVER_CONNECTIONS # 10005 => undef # SQL_MAXIMUM_IDENTIFIER_LENGTH # 102 => undef # SQL_MAXIMUM_INDEX_SIZE # 104 => undef # SQL_MAXIMUM_ROW_SIZE # 32 => undef # SQL_MAXIMUM_SCHEMA_NAME_LENGTH # 105 => undef # SQL_MAXIMUM_STATEMENT_LENGTH # 20000 => undef # SQL_MAXIMUM_STMT_OCTETS # 20001 => undef # SQL_MAXIMUM_STMT_OCTETS_DATA # 20002 => undef # SQL_MAXIMUM_STMT_OCTETS_SCHEMA # 106 => undef # SQL_MAXIMUM_TABLES_IN_SELECT # 35 => undef # SQL_MAXIMUM_TABLE_NAME_LENGTH # 107 => undef # SQL_MAXIMUM_USER_NAME_LENGTH # 10022 => undef # SQL_MAX_ASYNC_CONCURRENT_STATEMENTS # 112 => undef # SQL_MAX_BINARY_LITERAL_LEN # 34 => undef # SQL_MAX_CATALOG_NAME_LEN # 108 => undef # SQL_MAX_CHAR_LITERAL_LEN # 97 => undef # SQL_MAX_COLUMNS_IN_GROUP_BY # 98 => undef # SQL_MAX_COLUMNS_IN_INDEX # 99 => undef # SQL_MAX_COLUMNS_IN_ORDER_BY # 100 => undef # SQL_MAX_COLUMNS_IN_SELECT # 101 => undef # SQL_MAX_COLUMNS_IN_TABLE # 30 => undef # SQL_MAX_COLUMN_NAME_LEN # 1 => undef # SQL_MAX_CONCURRENT_ACTIVITIES # 31 => undef # SQL_MAX_CURSOR_NAME_LEN # 0 => undef # SQL_MAX_DRIVER_CONNECTIONS # 10005 => undef # SQL_MAX_IDENTIFIER_LEN # 102 => undef # SQL_MAX_INDEX_SIZE # 32 => undef # SQL_MAX_OWNER_NAME_LEN # 33 => undef # SQL_MAX_PROCEDURE_NAME_LEN # 34 => undef # SQL_MAX_QUALIFIER_NAME_LEN # 104 => undef # SQL_MAX_ROW_SIZE # 103 => undef # SQL_MAX_ROW_SIZE_INCLUDES_LONG # 32 => undef # SQL_MAX_SCHEMA_NAME_LEN # 105 => undef # SQL_MAX_STATEMENT_LEN # 106 => undef # SQL_MAX_TABLES_IN_SELECT # 35 => undef # SQL_MAX_TABLE_NAME_LEN # 107 => undef # SQL_MAX_USER_NAME_LEN # 37 => undef # SQL_MULTIPLE_ACTIVE_TXN # 36 => undef # SQL_MULT_RESULT_SETS , 111 => "N" # SQL_NEED_LONG_DATA_LEN , 75 => 1 # SQL_NON_NULLABLE_COLUMNS , 85 => 1 # SQL_NULL_COLLATION , 49 => 0 # SQL_NUMERIC_FUNCTIONS # 9 => undef # SQL_ODBC_API_CONFORMANCE # 152 => undef # SQL_ODBC_INTERFACE_CONFORMANCE # 12 => undef # SQL_ODBC_SAG_CLI_CONFORMANCE # 15 => undef # SQL_ODBC_SQL_CONFORMANCE # 73 => undef # SQL_ODBC_SQL_OPT_IEF # 10 => undef # SQL_ODBC_VER , 115 => 0x00000037 # SQL_OJ_CAPABILITIES # 1 SQL_OJ_LEFT + left joins SUPPORTED # 2 SQL_OJ_RIGHT + right joins SUPPORTED # 4 SQL_OJ_FULL + full joins SUPPORTED # SQL_OJ_NESTED - nested joins not supported # 10 SQL_OJ_NOT_ORDERED + on clause col order not required # 20 SQL_OJ_INNER + inner joins SUPPORTED # SQL_OJ_ALL_COMPARISON_OPS - on clause comp op must be = , 90 => "N" # SQL_ORDER_BY_COLUMNS_IN_SELECT # 38 => undef # SQL_OUTER_JOINS # 115 => undef # SQL_OUTER_JOIN_CAPABILITIES # 39 => undef # SQL_OWNER_TERM # 91 => undef # SQL_OWNER_USAGE # 153 => undef # SQL_PARAM_ARRAY_ROW_COUNTS # 154 => undef # SQL_PARAM_ARRAY_SELECTS # 80 => undef # SQL_POSITIONED_STATEMENTS # 79 => undef # SQL_POS_OPERATIONS , 21 => "N" # SQL_PROCEDURES # 40 => undef # SQL_PROCEDURE_TERM # 114 => undef # SQL_QUALIFIER_LOCATION # 41 => undef # SQL_QUALIFIER_NAME_SEPARATOR # 42 => undef # SQL_QUALIFIER_TERM # 92 => undef # SQL_QUALIFIER_USAGE , 93 => 3 # SQL_QUOTED_IDENTIFIER_CASE , 11 => "N" # SQL_ROW_UPDATES , 39 => "schema" # SQL_SCHEMA_TERM # 91 => undef # SQL_SCHEMA_USAGE # 43 => undef # SQL_SCROLL_CONCURRENCY # 44 => undef # SQL_SCROLL_OPTIONS # 14 => undef # SQL_SEARCH_PATTERN_ESCAPE # 13 => undef # SQL_SERVER_NAME # 94 => undef # SQL_SPECIAL_CHARACTERS , 155 => 8 # SQL_SQL92_DATETIME_FUNCTIONS # SQL_SDF_CURRENT_DATE => 0x00000001 + # SQL_SDF_CURRENT_TIME => 0x00000002 + # SQL_SDF_CURRENT_TIMESTAMP => 0x00000004 + # 156 => undef # SQL_SQL92_FOREIGN_KEY_DELETE_RULE # 157 => undef # SQL_SQL92_FOREIGN_KEY_UPDATE_RULE # 158 => undef # SQL_SQL92_GRANT , 159 => 0x00FFFFFF # SQL_SQL92_NUMERIC_VALUE_FUNCTIONS # All of them! # SQL_FN_NUM_ABS => 0x00000001 + # SQL_FN_NUM_ACOS => 0x00000002 + # SQL_FN_NUM_ASIN => 0x00000004 + # SQL_FN_NUM_ATAN => 0x00000008 + # SQL_FN_NUM_ATAN2 => 0x00000010 + # SQL_FN_NUM_CEILING => 0x00000020 + # SQL_FN_NUM_COS => 0x00000040 + # SQL_FN_NUM_COT => 0x00000080 + # SQL_FN_NUM_EXP => 0x00000100 + # SQL_FN_NUM_FLOOR => 0x00000200 + # SQL_FN_NUM_LOG => 0x00000400 + # SQL_FN_NUM_MOD => 0x00000800 + # SQL_FN_NUM_SIGN => 0x00001000 + # SQL_FN_NUM_SIN => 0x00002000 + # SQL_FN_NUM_SQRT => 0x00004000 + # SQL_FN_NUM_TAN => 0x00008000 + # SQL_FN_NUM_PI => 0x00010000 + # SQL_FN_NUM_RAND => 0x00020000 + # SQL_FN_NUM_DEGREES => 0x00040000 + # SQL_FN_NUM_LOG10 => 0x00080000 + # SQL_FN_NUM_POWER => 0x00100000 + # SQL_FN_NUM_RADIANS => 0x00200000 + # SQL_FN_NUM_ROUND => 0x00400000 + # SQL_FN_NUM_TRUNCATE => 0x00800000 + , 160 => 0x00003E06 # SQL_SQL92_PREDICATES # SQL_SP_EXISTS - - # SQL_SP_ISNOTNULL + + 2 # SQL_SP_ISNULL + + 4 # SQL_SP_MATCH_FULL - - # SQL_SP_MATCH_PARTIAL - - # SQL_SP_MATCH_UNIQUE_FULL - - # SQL_SP_MATCH_UNIQUE_PARTIAL - - # SQL_SP_OVERLAPS - - # SQL_SP_UNIQUE - - # SQL_SP_LIKE + + 200 # SQL_SP_IN - + 400 # SQL_SP_BETWEEN - + 800 # SQL_SP_COMPARISON + + 1000 # SQL_SP_QUANTIFIED_COMPARISON + + 2000 , 161 => 0x000001D8 # SQL_SQL92_RELATIONAL_JOIN_OPERATORS # SQL_SRJO_CORRESPONDING_CLAUSE - corresponding clause not supported # SQL_SRJO_CROSS_JOIN - cross join not supported # SQL_SRJO_EXCEPT_JOIN - except join not supported # 8 SQL_SRJO_FULL_OUTER_JOIN + full join SUPPORTED # 10 SQL_SRJO_INNER_JOIN + inner join SUPPORTED # SQL_SRJO_INTERSECT_JOIN - intersect join not supported # 40 SQL_SRJO_LEFT_OUTER_JOIN + left join SUPPORTED # 80 SQL_SRJO_NATURAL_JOIN + natural join SUPPORTED # 100 SQL_SRJO_RIGHT_OUTER_JOIN + right join SUPPORTED # SQL_SRJO_UNION_JOIN - union join not supported # 162 => undef # SQL_SQL92_REVOKE , 163 => 3 # SQL_SQL92_ROW_VALUE_CONSTRUCTOR # SQL_SRVC_VALUE_EXPRESSION # SQL_SRVC_NULL # SQL_SRVC_DEFAULT # SQL_SRVC_ROW_SUBQUERY , 164 => 0x000000FE # SQL_SQL92_STRING_FUNCTIONS # SQL_SSF_CONVERT => 0x00000001 # SQL_SSF_LOWER => 0x00000002 + # SQL_SSF_UPPER => 0x00000004 + # SQL_SSF_SUBSTRING => 0x00000008 + # SQL_SSF_TRANSLATE => 0x00000010 + # SQL_SSF_TRIM_BOTH => 0x00000020 + # SQL_SSF_TRIM_LEADING => 0x00000040 + # SQL_SSF_TRIM_TRAILING => 0x00000080 + # 165 => undef # SQL_SQL92_VALUE_EXPRESSIONS # 118 => undef # SQL_SQL_CONFORMANCE # 166 => undef # SQL_STANDARD_CLI_CONFORMANCE # 167 => undef # SQL_STATIC_CURSOR_ATTRIBUTES1 # 168 => undef # SQL_STATIC_CURSOR_ATTRIBUTES2 # 83 => undef # SQL_STATIC_SENSITIVITY , 50 => 0x00FF7FFF # SQL_STRING_FUNCTIONS # SQL_FN_STR_CONCAT => 0x00000001 + # SQL_FN_STR_INSERT => 0x00000002 + # SQL_FN_STR_LEFT => 0x00000004 + # SQL_FN_STR_LTRIM => 0x00000008 + # SQL_FN_STR_LENGTH => 0x00000010 + # SQL_FN_STR_LOCATE => 0x00000020 + # SQL_FN_STR_LCASE => 0x00000040 + # SQL_FN_STR_REPEAT => 0x00000080 + # SQL_FN_STR_REPLACE => 0x00000100 + # SQL_FN_STR_RIGHT => 0x00000200 + # SQL_FN_STR_RTRIM => 0x00000400 + # SQL_FN_STR_SUBSTRING => 0x00000800 + # SQL_FN_STR_UCASE => 0x00001000 + # SQL_FN_STR_ASCII => 0x00002000 + # SQL_FN_STR_CHAR => 0x00004000 + # SQL_FN_STR_DIFFERENCE => 0x00008000 # SQL_FN_STR_LOCATE_2 => 0x00010000 + # SQL_FN_STR_SOUNDEX => 0x00020000 + # SQL_FN_STR_SPACE => 0x00040000 + # SQL_FN_STR_BIT_LENGTH => 0x00080000 + # SQL_FN_STR_CHAR_LENGTH => 0x00100000 + # SQL_FN_STR_CHARACTER_LENGTH => 0x00200000 + # SQL_FN_STR_OCTET_LENGTH => 0x00400000 + # SQL_FN_STR_POSITION => 0x00800000 + # 95 => undef # SQL_SUBQUERIES , 51 => 8 # SQL_SYSTEM_FUNCTIONS # SQL_FN_SYS_USERNAME => 0x00000001 + # SQL_FN_SYS_DBNAME => 0x00000002 + # SQL_FN_SYS_IFNULL => 0x00000004 + , 45 => "table" # SQL_TABLE_TERM # 109 => undef # SQL_TIMEDATE_ADD_INTERVALS # 110 => undef # SQL_TIMEDATE_DIFF_INTERVALS , 52 => 0x000E0203 # SQL_TIMEDATE_FUNCTIONS # SQL_FN_TD_NOW => 0x00000001 + # SQL_FN_TD_CURDATE => 0x00000002 + # SQL_FN_TD_DAYOFMONTH => 0x00000004 # SQL_FN_TD_DAYOFWEEK => 0x00000008 # SQL_FN_TD_DAYOFYEAR => 0x00000010 # SQL_FN_TD_MONTH => 0x00000020 # SQL_FN_TD_QUARTER => 0x00000040 # SQL_FN_TD_WEEK => 0x00000080 # SQL_FN_TD_YEAR => 0x00000100 # SQL_FN_TD_CURTIME => 0x00000200 + # SQL_FN_TD_HOUR => 0x00000400 # SQL_FN_TD_MINUTE => 0x00000800 # SQL_FN_TD_SECOND => 0x00001000 # SQL_FN_TD_TIMESTAMPADD => 0x00002000 # SQL_FN_TD_TIMESTAMPDIFF => 0x00004000 # SQL_FN_TD_DAYNAME => 0x00008000 # SQL_FN_TD_MONTHNAME => 0x00010000 # SQL_FN_TD_CURRENT_DATE => 0x00020000 + # SQL_FN_TD_CURRENT_TIME => 0x00040000 + # SQL_FN_TD_CURRENT_TIMESTAMP => 0x00080000 + # SQL_FN_TD_EXTRACT => 0x00100000 # 46 => undef # SQL_TRANSACTION_CAPABLE # 72 => undef # SQL_TRANSACTION_ISOLATION_OPTION # 46 => undef # SQL_TXN_CAPABLE # 72 => undef # SQL_TXN_ISOLATION_OPTION # 96 => undef # SQL_UNION # 96 => undef # SQL_UNION_STATEMENT # 47 => \&sql_user_name # SQL_USER_NAME # 10000 => undef # SQL_XOPEN_CLI_YEAR ); 1; __END__ NO LONGER NEEDED sub sql_driver_name { shift->{"Driver"}->{"Name"}; } sub sql_driver_ver { my $dbh = shift; my $ver = shift; my $drv = 'DBD::'.$dbh->{"Driver"}->{"Name"}; # $ver = "$drv"."::VERSION"; # $ver = ${$ver}; my $fmt = '%02d.%02d.%1d%1d%1d%1d'; # ODBC version string: ##.##.##### $ver = sprintf $fmt, split (/\./, $ver); return $ver . '; ss-'. $SQL::Statement::VERSION; } sub sql_data_source_name { my $dbh = shift; return 'dbi:'.$dbh->{"Driver"}->{"Name"}.':'.$dbh->{"Name"}; } sub sql_user_name { my $dbh = shift; return $dbh->{"CURRENT_USER"}; } =pod =head1 NAME SQL::Statement::GetInfo =head1 SYNOPSIS # see L =head1 DESCRIPTION This package contains support for C<$dbh->get_info()>. =head1 INHERITANCE SQL::Statement::GetInfo =begin undocumented =head1 METHODS =head2 sql_keywords Returns the list of keywords =end undocumented =cut SQL-Statement-1.407/lib/SQL/Statement/Operation.pm000644 000765 000024 00000054734 12531013464 021553 0ustar00snostaff000000 000000 package SQL::Statement::Operation; use strict; use warnings FATAL => "all"; use vars qw(@ISA); use Carp (); use SQL::Statement::Term (); our $VERSION = '1.407'; @ISA = qw(SQL::Statement::Term); =pod =head1 NAME SQL::Statement::Operation - base class for all operation terms =head1 SYNOPSIS # create an operation with an SQL::Statement object as owner, specifying # the operation name (for error purposes), the left and the right # operand my $term = SQL::Statement::Operation->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation is an abstract base class providing the interface for all operation terms. =head1 INHERITANCE SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates new operation term. =head2 value Return the result of the operation of the term by calling L =head2 operate I method which will do the operation of the term. Must be overridden by derived classes. =head2 op Returns the name of the executed operation. =head2 left Returns the left operand (if any). =head2 right Returns the right operand (if any). =head2 DESTROY Destroys the term and undefines the weak reference to the owner as well as the stored operation, the left and the right operand. =cut sub new { my ( $class, $owner, $operation, $leftTerm, $rightTerm ) = @_; my $self = $class->SUPER::new($owner); $self->{OP} = $operation; $self->{LEFT} = $leftTerm; $self->{RIGHT} = $rightTerm; return $self; } sub op { return $_[0]->{OP}; } sub left { return $_[0]->{LEFT}; } sub right { return $_[0]->{RIGHT}; } sub operate($) { Carp::confess( sprintf( q{pure virtual function 'operate' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) ); } sub DESTROY { my $self = $_[0]; undef $self->{OP}; undef $self->{LEFT}; undef $self->{RIGHT}; $self->SUPER::DESTROY(); } sub value($) { return $_[0]->operate( $_[1] ); } package SQL::Statement::Operation::Neg; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); =pod =head1 NAME SQL::Statement::Operation::Neg - negate operation =head1 SYNOPSIS # create an operation with an SQL::Statement object as owner, # specifying the operation name, the left and B right operand my $term = SQL::Statement::Neg->new( $owner, $op, $left, undef ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Neg =head1 INHERITANCE SQL::Statement::Operation::Neg ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Return the logical negated value of the left operand. =cut sub operate($) { return !$_[0]->{LEFT}->value( $_[1] ); } package SQL::Statement::Operation::And; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); =pod =head1 NAME SQL::Statement::Operation::And - and operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::And->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::And implements the logical C operation between two terms. =head1 INHERITANCE SQL::Statement::Operation::And ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Return the result of the logical C operation for the Ls of the left and right operand. =cut sub operate($) { return $_[0]->{LEFT}->value( $_[1] ) && $_[0]->{RIGHT}->value( $_[1] ); } package SQL::Statement::Operation::Or; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); =pod =head1 NAME SQL::Statement::Operation::Or - or operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Or->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Or implements the logical C operation between two terms. =head1 INHERITANCE SQL::Statement::Operation::Or ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Return the result of the logical C operation for the Ls of the left and right operand. =cut sub operate($) { return $_[0]->{LEFT}->value( $_[1] ) || $_[0]->{RIGHT}->value( $_[1] ); } package SQL::Statement::Operation::Is; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); =pod =head1 NAME SQL::Statement::Operation::Is - is operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Is->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Is supports: C, C and C. The right operand is always evaluated in boolean context in case of C and C. C returns I even if the left term is an empty string (C<''>). =head1 INHERITANCE SQL::Statement::Operation::Is ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Returns true when the left term is null, true or false - based on the requested right value. =cut sub operate($) { my $self = $_[0]; my $left = $self->{LEFT}->value( $_[1] ); my $right = $self->{RIGHT}->value( $_[1] ); my $expr; if ( defined($right) ) { $expr = defined($left) ? $left && $right : 0; # is true / is false } else { $expr = !defined($left) || ( $left eq '' ); # FIXME I don't like that '' IS NULL } return $expr; } package SQL::Statement::Operation::ANSI::Is; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); =pod =head1 NAME SQL::Statement::Operation::ANSI::Is - is operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Is->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::ANSI::Is supports: C, C and C. The right operand is always evaluated in boolean context in case of C and C. C returns I if the right term is not defined, I otherwise. =head1 INHERITANCE SQL::Statement::Operation::Is ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Returns true when the left term is null, true or false - based on the requested right value. =cut sub operate($) { my $self = $_[0]; my $left = $self->{LEFT}->value( $_[1] ); my $right = $self->{RIGHT}->value( $_[1] ); my $expr; if ( defined($right) ) { $expr = defined($left) ? $left && $right : 0; # is true / is false } else { $expr = !defined($left); } return $expr; } package SQL::Statement::Operation::Contains; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); use Scalar::Util qw(looks_like_number); =pod =head1 NAME SQL::Statement::Operation::Contains - in operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Contains->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Contains expects the right operand is an array of L instances. It checks whether the left operand is in the list of the right operands or not like: $left->value($eval) ~~ map { $_->value($eval) } @{$right} =head1 INHERITANCE SQL::Statement::Operation::Contains ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Returns true when the left term is equal to any of the right terms =cut sub operate($) { my ( $self, $eval ) = @_; my $left = $self->{LEFT}->value($eval); my @right = map { $_->value($eval); } @{ $self->{RIGHT} }; my $expr = 0; foreach my $r (@right) { last if $expr |= ( looks_like_number($left) && looks_like_number($r) ) ? $left == $r : $left eq $r; } return $expr; } package SQL::Statement::Operation::Between; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); use Scalar::Util qw(looks_like_number); =pod =head1 NAME SQL::Statement::Operation::Between - between operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Between->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Between expects the right operand is an array of 2 L instances. It checks whether the left operand is between the right operands like: ( $left->value($eval) >= $right[0]->value($eval) ) && ( $left->value($eval) <= $right[1]->value($eval) ) =head1 INHERITANCE SQL::Statement::Operation::Between ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Returns true when the left term is between both right terms =cut sub operate($) { my ( $self, $eval ) = @_; my $left = $self->{LEFT}->value($eval); my @right = map { $_->value($eval); } @{ $self->{RIGHT} }; my $expr = 0; if ( looks_like_number($left) && looks_like_number( $right[0] ) && looks_like_number( $right[1] ) ) { $expr = ( $left >= $right[0] ) && ( $left <= $right[1] ); } else { $expr = ( $left ge $right[0] ) && ( $left le $right[1] ); } return $expr; } package SQL::Statement::Operation::Equality; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); use Carp (); use Scalar::Util qw(looks_like_number); =pod =head1 NAME SQL::Statement::Operation::Equality - abstract base class for comparisons =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Equality->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Equality implements compare operations between two terms - choosing either numerical comparison or string comparison, depending whether both operands are numeric or not. =head1 INHERITANCE SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Return the result of the comparison. =head2 numcmp I method which will do the numeric comparison of both terms. Must be overridden by derived classes. =head2 strcmp I method which will do the string comparison of both terms. Must be overridden by derived classes. =cut sub operate($) { my $self = $_[0]; my $left = $self->{LEFT}->value( $_[1] ); my $right = $self->{RIGHT}->value( $_[1] ); return 0 unless ( defined($left) && defined($right) ); return ( looks_like_number($left) && looks_like_number($right) ) ? $self->numcmp( $left, $right ) : $self->strcmp( $left, $right ); } sub numcmp($) { Carp::confess( sprintf( q{pure virtual function 'numcmp' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) ); } sub strcmp($) { Carp::confess( sprintf( q{pure virtual function 'strcmp' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) ); } package SQL::Statement::Operation::Equal; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Equality); =pod =head1 NAME SQL::Statement::Operation::Equal - implements equal operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Equal->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Equal implements compare operations between two numbers and two strings. =head1 INHERITANCE SQL::Statement::Operation::Equal ISA SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 numcmp Return true when C<$left == $right> =head2 strcmp Return true when C<$left eq $right> =cut sub numcmp($$) { return $_[1] == $_[2]; } sub strcmp($$) { return $_[1] eq $_[2]; } package SQL::Statement::Operation::NotEqual; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Equality); =pod =head1 NAME SQL::Statement::Operation::NotEqual - implements not equal operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::NotEqual->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::NotEqual implements negated compare operations between two numbers and two strings. =head1 INHERITANCE SQL::Statement::Operation::NotEqual ISA SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 numcmp Return true when C<$left != $right> =head2 strcmp Return true when C<$left ne $right> =cut sub numcmp($$) { return $_[1] != $_[2]; } sub strcmp($$) { return $_[1] ne $_[2]; } package SQL::Statement::Operation::Lower; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Equality); =pod =head1 NAME SQL::Statement::Operation::Lower - implements lower than operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Lower->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Lower implements lower than compare operations between two numbers and two strings. =head1 INHERITANCE SQL::Statement::Operation::Lower ISA SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 numcmp Return true when C<$left < $right> =head2 strcmp Return true when C<$left lt $right> =cut sub numcmp($$) { return $_[1] < $_[2]; } sub strcmp($$) { return $_[1] lt $_[2]; } package SQL::Statement::Operation::Greater; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Equality); =pod =head1 NAME SQL::Statement::Operation::Greater - implements greater than operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Greater->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Greater implements greater than compare operations between two numbers and two strings. =head1 INHERITANCE SQL::Statement::Operation::Greater ISA SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 numcmp Return true when C<$left > $right> =head2 strcmp Return true when C<$left gt $right> =cut sub numcmp($$) { return $_[1] > $_[2]; } sub strcmp($$) { return $_[1] gt $_[2]; } package SQL::Statement::Operation::LowerEqual; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Equality); =pod =head1 NAME SQL::Statement::Operation::LowerEqual - implements lower equal operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::LowerEqual->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::LowerEqual implements lower equal compare operations between two numbers and two strings. =head1 INHERITANCE SQL::Statement::Operation::LowerEqual ISA SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 numcmp Return true when C<$left <= $right> =head2 strcmp Return true when C<$left le $right> =cut sub numcmp($$) { return $_[1] <= $_[2]; } sub strcmp($$) { return $_[1] le $_[2]; } package SQL::Statement::Operation::GreaterEqual; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Equality); =pod =head1 NAME SQL::Statement::Operation::GreaterEqual - implements greater equal operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::GreaterEqual->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::GreaterEqual implements greater equal compare operations between two numbers and two strings. =head1 INHERITANCE SQL::Statement::Operation::GreaterEqual ISA SQL::Statement::Operation::Equality ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 numcmp Return true when C<$left >= $right> =head2 strcmp Return true when C<$left ge $right> =cut sub numcmp($$) { return $_[1] >= $_[2]; } sub strcmp($$) { return $_[1] ge $_[2]; } package SQL::Statement::Operation::Regexp; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation); =pod =head1 NAME SQL::Statement::Operation::Regexp - abstract base class for comparisons based on regular expressions =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Regexp->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Regexp implements the comparisons for the C operation family. =head1 INHERITANCE SQL::Statement::Operation::Regexp ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 operate Return the result of the comparison. =head2 right Returns the regular expression based on the right term. The right term is expected to be constant - so C in not supported. =head2 regexp I method which must return a regular expression (C) from the given string. Must be overridden by derived classes. =cut sub right($) { my $self = $_[0]; my $right = $self->{RIGHT}->value( $_[1] ); unless ( defined( $self->{PATTERNS}->{$right} ) ) { $self->{PATTERNS}->{$right} = $right; $self->{PATTERNS}->{$right} =~ s/%/.*/g; $self->{PATTERNS}->{$right} = $self->regexp( $self->{PATTERNS}->{$right} ); } return $self->{PATTERNS}->{$right}; } sub regexp($) { Carp::confess( sprintf( q{pure virtual function 'regexp' called on %s for %s}, ref( $_[0] ) || __PACKAGE__, $_[0]->{OP} ) ); } sub operate($) { my $self = $_[0]; my $left = $self->{LEFT}->value( $_[1] ); my $right = $self->right( $_[1] ); return 0 unless ( defined($left) && defined($right) ); return $left =~ m/^$right$/s; } package SQL::Statement::Operation::Like; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Regexp); =pod =head1 NAME SQL::Statement::Operation::Like - implements the like operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Like->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Like is used to the comparisons for the C operation. =head1 INHERITANCE SQL::Statement::Operation::Like ISA SQL::Statement::Operation::Regexp ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 regexp Returns C =cut sub regexp($) { my $right = $_[1]; return qr/^$right$/s; } package SQL::Statement::Operation::Clike; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Regexp); =pod =head1 NAME SQL::Statement::Operation::Clike - implements the clike operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::Clike->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::Clike is used to the comparisons for the C operation. =head1 INHERITANCE SQL::Statement::Operation::Clike ISA SQL::Statement::Operation::Regexp ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 regexp Returns C =cut sub regexp($) { my $right = $_[1]; return qr/^$right$/si; } package SQL::Statement::Operation::Rlike; use vars qw(@ISA); @ISA = qw(SQL::Statement::Operation::Regexp); =pod =head1 NAME SQL::Statement::Operation::RLike - implements the rlike operation =head1 SYNOPSIS # create an C operation with an SQL::Statement object as owner, # specifying the operation name, the left and the right operand my $term = SQL::Statement::RLike->new( $owner, $op, $left, $right ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Operation::RLike is used to the comparisons for the C operation. =head1 INHERITANCE SQL::Statement::Operation::RLike ISA SQL::Statement::Operation::Regexp ISA SQL::Statement::Operation ISA SQL::Statement::Term =head1 METHODS =head2 regexp Returns C =cut sub regexp($) { my $right = $_[1]; return qr/$right$/; } =head1 AUTHOR AND COPYRIGHT Copyright (c) 2009,2010 by Jens Rehsack: rehsackATcpan.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. =cut 1; SQL-Statement-1.407/lib/SQL/Statement/Placeholder.pm000644 000765 000024 00000003525 12531013464 022025 0ustar00snostaff000000 000000 package SQL::Statement::Placeholder; use strict; use warnings FATAL => "all"; use vars qw(@ISA); use Carp (); use SQL::Statement::Term (); our $VERSION = '1.407'; @ISA = qw(SQL::Statement::Term); =pod =head1 NAME SQL::Statement::Placeholder - implements getting the next placeholder value =head1 SYNOPSIS # create an placeholder term with an SQL::Statement object as owner # and the $argnum of the placeholder. my $term = SQL::Statement::Placeholder->new( $owner, $argnum ); # access the result of that operation $term->value( $eval ); =head1 DESCRIPTION SQL::Statement::Placeholder implements getting the next placeholder value. Accessing a specific placeholder is currently unimplemented and not tested. =head1 INHERITANCE SQL::Statement::Placeholder ISA SQL::Statement::Term =head1 METHODS =head2 new Instantiates a new C instance. =head2 value Returns the value of the next placeholder. =cut sub new { my ( $class, $owner, $argnum ) = @_; my $self = $class->SUPER::new($owner); $self->{ARGNUM} = $argnum; return $self; } sub value($) { # from S::S->get_row_value(): # my $val = ( # $self->{join} # or !$eval # or ref($eval) =~ /Statement$/ # ) ? $self->params($arg_num) : $eval->param($arg_num); # let's see where us will lead taking from params every time # XXX later: return $_[0]->{OWNER}->{params}->[$_[0]->{ARGNUM}]; return $_[0]->{OWNER}->{params}->[ $_[0]->{OWNER}->{argnum}++ ]; } =head1 AUTHOR AND COPYRIGHT Copyright (c) 2009,2010 by Jens Rehsack: rehsackATcpan.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. =cut 1; SQL-Statement-1.407/lib/SQL/Statement/RAM.pm000755 000765 000024 00000012752 12531013464 020227 0ustar00snostaff000000 000000 ############################ package SQL::Statement::RAM; ############################ use strict; use warnings FATAL => "all"; use vars qw($VERSION); $VERSION = '1.407'; #################################### package SQL::Statement::RAM::Table; #################################### use strict; use warnings FATAL => "all"; use SQL::Eval (); use vars qw(@ISA); @ISA = qw(SQL::Eval::Table); use Carp qw(croak); sub new { my ( $class, $tname, $col_names, $data_tbl ) = @_; my %table = ( NAME => $tname, index => 0, records => $data_tbl, col_names => $col_names, capabilities => { inplace_update => 1, inplace_delete => 1, }, ); my $self = $class->SUPER::new( \%table ); } ################################## # fetch_row() ################################## sub fetch_row { my ( $self, $data ) = @_; return $self->{row} = ( $self->{records} and ( $self->{index} < scalar( @{ $self->{records} } ) ) ) ? [ @{ $self->{records}->[ $self->{index}++ ] } ] : undef; } #################################### # insert_new_row() #################################### sub insert_new_row { my ( $self, $data, $fields ) = @_; push @{ $self->{records} }, [ @{$fields} ]; return 1; } ################################## # delete_current_row() ################################## sub delete_current_row { my ( $self, $data, $fields ) = @_; my $currentRow = $self->{index} - 1; croak "No current row" unless ( $currentRow >= 0 ); splice @{ $self->{records} }, $currentRow, 1; --$self->{index}; return 1; } ################################## # update_current_row() ################################## sub update_current_row { my ( $self, $data, $fields ) = @_; my $currentRow = $self->{index} - 1; croak "No current row" unless ( $currentRow >= 0 ); $self->{records}->[$currentRow] = [ @{$fields} ]; return 1; } ################################## # truncate() ################################## sub truncate { return splice @{ $_[0]->{records} }, $_[0]->{index}; } ##################################### # push_names() ##################################### sub push_names { my ( $self, $data, $names ) = @_; $self->{col_names} = $names; $self->{org_col_names} = [ @{$names} ]; $self->{col_nums} = SQL::Eval::Table::_map_colnums($names); } ##################################### # drop() ##################################### sub drop { my ( $self, $data ) = @_; my $tname = $self->{NAME}; delete $data->{Database}->{sql_ram_tables}->{$tname}; return 1; } ##################################### # seek() ##################################### sub seek { my ( $self, $data, $pos, $whence ) = @_; return unless defined $self->{records}; my ($currentRow) = $self->{index}; if ( $whence == 0 ) { $currentRow = $pos; } elsif ( $whence == 1 ) { $currentRow += $pos; } elsif ( $whence == 2 ) { $currentRow = @{ $self->{records} } + $pos; } else { croak $self . "->seek: Illegal whence argument ($whence)"; } if ( $currentRow < 0 ) { croak "Illegal row number: $currentRow"; } $self->{index} = $currentRow; } 1; =pod =head1 NAME SQL::Statement::RAM =head1 SYNOPSIS SQL::Statement::RAM =head1 DESCRIPTION This package contains support for the internally used SQL::Statement::RAM::Table. =head1 INHERITANCE SQL::Statement::RAM SQL::Statement::RAM::Table ISA SQL::Eval::Table =head1 SQL::Statement::RAM::Table =head2 METHODS =over 8 =item new Instantiates a new C object, used for temporary tables. CREATE TEMP TABLE foo .... =item fetch_row Fetches the next row =item push_row As fetch_row except for writing =item delete_current_row Deletes the last fetched/pushed row =item update_current_row Updates the last fetched/pushed row =item truncate Truncates the table at the current position =item push_names Set the column names of the table =item drop Discards the table =item seek Seek the row pointer =back =head2 CAPABILITIES This table has following capabilities: =over 8 =item update_current_row Using provided method C and capability C. =item rowwise_update By providing capability C. =item inplace_update By definition (appropriate flag set in constructor). =item delete_current_row Using provided method C and capability C. =item rowwise_delete By providing capability C. =item inplace_delete By definition (appropriate flag set in constructor). =back =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc SQL::Statement You can also look for information at: =over 4 =item * RT: CPAN's request tracker L =item * AnnoCPAN: Annotated CPAN documentation L =item * CPAN Ratings L =item * Search CPAN L =back =head1 AUTHOR AND COPYRIGHT Copyright (c) 2001,2005 by Jeff Zucker: jzuckerATcpan.org Copyright (c) 2007-2010 by Jens Rehsack: rehsackATcpan.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. =cut SQL-Statement-1.407/lib/SQL/Statement/Roadmap.pod000644 000765 000024 00000020775 12437274537 021361 0ustar00snostaff000000 000000 =head1 NAME SQL::Statement::Roadmap - Planned Enhancements for SQL::Statement and SQL::Parser Jens Rehsack - June 2010 =head1 SYNOPSIS This document gives a high level overview of the future of SQL::Statement, SQL::Parser and its impact. The planned enhancements cover testing, performance, reliability, extensibility and more. =head1 CHANGES AND ENHANCEMENTS =head2 Enhancements in SQL::Statement 1.xx SQL::Statement 1.xx will not receive big changes, but a few enhancements may help us to design SQL::Statement 2.xx much better. =head3 CREATE and DROP of FUNCTION, KEYWORD, OPERATOR, TYPE SQL::Statement is missing some functions, types, operators etc. It's supported to add missing functionality - but the implementation wasn't picked up during the modernizing of column evaluation. See RT#52397 for some more information. This should be done before SQL::Statement 1.xx reaches the end of its road. =head3 Parser improvements The SQL::Parser is implemented based on a lot of regular expressions and some manually developed logic. This creates some issues like RT#53416 or RT#55190. Further, trailing C<;> causes SQL::Parser to croak. We need to decide what can be fixed without internal design changes and what has to wait. =head3 Performance There is no intention to work on performance improvements in SQL::Statement 1.xx. The performance is good as it is and improvement requires design changes. =head3 Reliability Bugs will be fixed - where possible. SQL::Statement 1.28 is much more reliable than SQL::Statement 1.15. Even if a bug cannot be fixed all issues are gratefully received as they will be considered in the design process for SQL::Statement 2.xx better. =head3 Extensibility SQL::Statement 1.xx is highly extensible, even if a more object oriented design would improve that. The 1.xx branch will not be redesigned for greater extensibility on a coding level. =head2 Enhancements in SQL::Statement 2.xx Concerning the procedural design of SQL::Statement 1.xx a rewrite of the basic components is required. =head3 SQL::Parser rewrite The SQL::Parser needs to be modified to be able to use a L. This would allow users and developers to rely on many different SQL dialects. This will allow better extensibility from a feature point of view without losing ANSI SQL compatibility. =head3 SQL::Statement rewrite SQL::Statement should be reduced to a simple coordinating engine. The executing tasks should be organized into separated commands. This will reduce side effects and will open the door for higher level optimizations, reliability improvements or sub-selects (or other calculated tables). =head3 Features There is a large list of missing features but not all table backends will be able to support each new feature. The most popular requested features need additional discussion and everyone is welcome to do it on the L. =head4 LOCK TABLE Locking table within SQL scripts to manually control table consistence over several operations. The current locking support is restricted to one statement. =head4 Transaction support Executing statements on a temporary copy of the table data. The easiest way to implement this would be to create a L on C and write the entire table back on C or discard on C. Better performance could be achieved in cases where the implementation is enabled to memorize pending modifications and apply them at C. On the other hand there are already L to improve some operations, which might create confusion in case of transactions. This needs more discussion. =head4 ALTER TABLE Adding, removing or modifying columns is not supported for created tables. A generic C seems to rely on the implementation of the transaction support - until better ideas are provided. =head4 Indices Currently some table backends have implicit support to access specified rows quicker than fetching each row and evaluating the where clause against the row data. An interface would be required to configure fetching to return only rows matching a restricted where clause. Another (probably better) way to support indices would be to fetch index entries at first and have an interface to the table fetching lines based on an index key. =head4 Sub-Selects In most cases queries can be re-expressed without using sub-selects. But in any case, there are circumstances where sub-selects are required. The first implementation will do the sub-select before the primary statement is executed without any further optimization. Hopefully a later version will provide better L with some optimization. =head4 Query based variables Currently the only variable I can imagine is C. More suggestions are very welcome. =head4 Better SQL Script support In SQL::Statement 1.xx the function C provides SQL script execution. This function may have limitations and side effects (at least when the executed SQL touched the same tables as the primary statement). I plan to improve the SQL script support to remove the side effects on the one hand and have a more flexible and easier way to execute them. Finally it should be possible to execute a script via: $dbh->do( join( ";", @script ) ); =head4 Trigger support Most important when doing complicated things is having callback functions for several events. While real triggers will not be possible for SQL::Statement and underlying pseudo-databases, callbacks could be provided via triggers. =head3 Performance There are several performance optimizations required for SQL::Statement 2.xx. The first one should be done on a very high level (query optimization) by implementing algebraic evaluation of queries and clean implementation of typical database algorithms. With respect to the basic optimization rule I, it is primarily targeted to have an adequately fast, reliable implementation of many algorithms (e.g. early incomplete evaluation to reduce amount of rows, transpose where clause to evaluate constants first) and a clever controller choosing the right algorithm for a specific query. The second optimization goal means: implementing most expensive methods in XS. This requires a good performance test suite as well as some real world usage cases. =head3 Reliability This is one of the primary goals of SQL::Statement. I hope to reach it using test driven development and I hope I get some more todo's from the users for this. =head3 Extensibility The currently high level of extensibility should be increased on a coding level. This will be done by redesigning the entire parser and execution engine using object oriented techniques and design patterns. =head3 Testing Many tests in SQL::Statement are not well organized. The tests should be reorganized into several parts: =over 4 =item Basic API This part should test the entire basic API of SQL::Statement, SQL::Parser and probably the entire engine command classes. =item DBI / Table API This part should test if the API to DBI drivers work (maybe an empty test driver will be needed for that). =item Functionality This part should test the functionality of the SQL::Parser and the SQL::Statement engine. =item Performance This part should be used to implement full usage cases (ideally from real world projects) to allow for testing optimizations. =back =head1 PRIORITIES Our priorities are localized to our current issues and proof of concept fixes for upcoming SQL::Statement 2.xx. Any additional priorities (as missing features, the SQL::Statement rewrite) will come later and can be modified by (paying) users. =head1 RESOURCES AND CONTRIBUTIONS See L for I. If your company has benefited from the DBI or SQL::Statement, please consider if it could make a donation to The Perl Foundation "DBI Development" or "SQL::Statement Development" fund at L to secure future development. Alternatively, if your company would benefit from a specific new DBI or SQL::Statement feature, please consider sponsoring its development through the options listed in the section "Commercial Support from the Author" on L. Using such targeted financing allows you to contribute to DBI development (including SQL::Statement and PurePerl DBI drivers) and rapidly get something specific and directly valuable to you in return. Thank you. =cut SQL-Statement-1.407/lib/SQL/Statement/Structure.pod000644 000765 000024 00000031311 12437274537 021762 0ustar00snostaff000000 000000 =pod =head1 NAME SQL::Statement::Structure - parse and examine structure of SQL queries =head1 SYNOPSIS use SQL::Statement; my $sql = "SELECT a FROM b JOIN c WHERE c=? AND e=7 ORDER BY f DESC LIMIT 5,2"; my $parser = SQL::Parser->new(); $parser->{RaiseError}=1; $parser->{PrintError}=0; $parser->parse("LOAD 'MyLib::MySyntax' "); my $stmt = SQL::Statement->new($sql,$parser); printf "Command %s\n",$stmt->command; printf "Num of Placeholders %s\n",scalar $stmt->params; printf "Columns %s\n",join( ',', map {$_->name} $stmt->column_defs() ); printf "Tables %s\n",join( ',', map {$_->name} $stmt->tables() ); printf "Where operator %s\n",join( ',', $stmt->where->op() ); printf "Limit %s\n",$stmt->limit(); printf "Offset %s\n",$stmt->offset(); # these will work not before $stmt->execute() printf "Order Columns %s\n",join(',', map {$_->column} $stmt->order() ); =head1 DESCRIPTION The L module can be used by itself, without DBI and without a subclass to parse SQL statements and to allow you to examine the structure of the statement (table names, column names, where clause predicates, etc.). It will also execute statements using in-memory tables. That means that you can create and populate some tables, then query them and fetch the results of the queries as well as examine the differences between statement metadata during different phases of prepare, execute, fetch. See the remainder of this document for a description of how to create and modify a parser object and how to use it to parse and examine SQL statements. See L for other uses of the module. =head1 B The parser object only needs to be created once per script. It can then be reused to parse any number of SQL statements. The basic creation of a parser is this: my $parser = SQL::Parser->new(); You can set the error-reporting for the parser the same way you do in DBI: $parser->{RaiseError}=1; # turn on die-on-error behaviour $parser->{PrinteError}=1; # turn on warnings-on-error behaviour As with DBI, RaiseError defaults to 0 (off) and PrintError defaults to 1 (on). For many purposes, the built-in SQL syntax should be sufficient. However, if you need to, you can change the behaviour of the parser by extending the supported SQL syntax either by loading a file containing definitions; or by issuing SQL commands that modify the way the parser treats types, keywords, functions, and operators. $parser->parse("LOAD MyLib::MySyntax"); $parser->parse("CREATE TYPE myDataType"); See L for details of the supported SQL syntax and for methods of extending the syntax. =head1 B While you only need to define a new SQL::Parser object once per script, you need to define a new SQL::Statment object once for each statement you want to parse. my $stmt = SQL::Statement->new($sql, $parser); The call to new() takes two arguments - the SQL string you want to parse, and the SQL::Parser object you previously created. The call to new is the equivalent of a DBI call to prepare() - it parses the SQL into a structure but does not attempt to execute the SQL unless you explicitly call execute(). =head1 Examining the structure of SQL statements The following methods can be used to obtain information about a query: =head2 B Returns the SQL command. See L for supported command. Example: my $command = $stmt->command(); =head2 B my $numColumns = $stmt->column_defs(); # Scalar context my @columnList = $stmt->column_defs(); # Array context my($col1, $col2) = ($stmt->column_defs(0), $stmt->column_defs(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 C<$col1>, C<$col2>, ..., C<$colN>, you may alternatively use a column number as argument. Note that the column list may be empty as in INSERT INTO $table VALUES (...) and in I or I statements. But what does "returning a column" mean? It is returning an C instance, a class that implements the methods C
and C, 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' =head2 B my $tableNum = $stmt->tables(); # Scalar context my @tables = $stmt->tables(); # Array context my($table1, $table2) = ($stmt->tables(0), $stmt->tables(1)); Similar to C, this method returns instances of C. For I, I, I, I and I, a single table will always be returned. I statements you can use this for looking at the ORDER clause. Example: SELECT * FROM FOO ORDER BY id DESC, name In this case, C could return 2 instances of C. You can use the methods C<$o-Etable()>, C<$o-Ecolumn()>, C<$o-Edirection()> and C<$o-Edesc()> to examine the order object. =head2 B my $limit = $stmt->limit(); In a SELECT statement you can use a C 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 C<0..4>, C<5..9>, C<10..14> of the table FOO, respectively. If no C clause is used, then the method C<$stmt-Elimit> returns undef. Otherwise it returns the limit number (the maximum number of rows) from the statement (C<5> or C<10> for the statements above). =head2 B my $offset = $stmt->offset(); If no C clause is used, then the method C<$stmt-Elimit> returns I. Otherwise it returns the offset number (the index of the first row to be included in the limit clause). =head2 B my $where_hash = $stmt->where_hash(); To manually evaluate the I clause, fetch the topmost where clause node with the C 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. The where clause nodes have (up to) 4 attributes: =over 12 =item op contains the operator, one of C, C, C<=>, CE>, C=>, C>, C=>, C>, C, C, C, C, C or a user defined operator, if any. =item arg1 contains the left-hand side of the operator. This can be a scalar value, a hash containing column or function definition, a parameter definition (hash has attribute C defined) or another operation (hash has attribute C defined). =item arg2 contains the right-hand side of the operator. This can be a scalar value, a hash containing column or function definition, a parameter definition (hash has attribute C defined) or another operation (hash has attribute C defined). =item neg contains a TRUE value, if the operation result must be negated after evaluation. =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: The WHERE clause evaluation depends on an object being used for fetching parameter and column values. Usually this can be an SQL::Statement::RAM::Table object or SQL::Eval object, but in fact it can be any object that supplies the methods $val = $eval->param($paramNum); $val = $eval->column($table, $column); Once you have such an object, you can call eval_where; $match = $stmt->eval_where($eval); =head2 B my $where = $stmt->where(); This method is used to examine the syntax tree of the C clause. It returns I (if no C clause was used) or an instance of L. The where clause is evaluated automatically on the current selected row of the table currently worked on when it's C method is invoked. C creates the object tree for where clause evaluation directly after successfully parsing a statement from the given C, if any. =head1 Executing and fetching data from SQL statements =head2 execute When called from a DBD or other subclass of SQL::Statement, the execute() method will be executed against whatever datasource (persistent storage) is supplied by the DBD or the subclass (e.g. CSV files for L, or BerkeleyDB for L). If you are using L directly rather than as a subclass, you can call the execute() method and the statements will be executed() using temporary in-memory tables. When used directly, like that, you need to create a cache hashref and pass it as the first argument to execute: my $cache = {}; my $parser = SQL::Parser->new(); my $stmt = SQL::Statement->new('CREATE TABLE x (id INT)',$parser); $stmt->execute( $cache ); If you are using a statement with placeholders, those can be passed to execute after the C<$cache>: $stmt = SQL::Statement->new('INSERT INTO y VALUES(?,?)',$parser); $stmt->execute( $cache, 7, 'foo' ); =head2 fetch Only a single C method is provided - it returns a single row of data as an arrayref. Use a loop to fetch all rows: while (my $row = $stmt->fetch()) { # ... } =head2 an example of executing and fetching #!/usr/bin/perl -w use strict; use SQL::Statement; my $cache={}; my $parser = SQL::Parser->new(); for my $sql(split /\n/, " CREATE TABLE a (b INT) INSERT INTO a VALUES(1) INSERT INTO a VALUES(2) SELECT MAX(b) FROM a " ) { $stmt = SQL::Statement->new($sql,$parser); $stmt->execute($cache); next unless $stmt->command eq 'SELECT'; while (my $row=$stmt->fetch) { print "@$row\n"; } } __END__ =head1 AUTHOR & COPYRIGHT Copyright (c) 2005, Jeff Zucker , all rights reserved. Copyright (c) 2009, Jens Rehsack , all rights reserved. This document may be freely modified and distributed under the same terms as Perl itself. =cut SQL-Statement-1.407/lib/SQL/Statement/Syntax.pod000644 000765 000024 00000046510 12437274537 021257 0ustar00snostaff000000 000000 =pod =head1 NAME SQL::Statement::Syntax - documentation of SQL::Statement's SQL Syntax =head1 SYNOPSIS See L for usage. =head1 DESCRIPTION The SQL::Statement module can be used either from a DBI driver like DBD::CSV or directly. The syntax below applies to both situations. In the case of DBDs, each DBD can implement its own sub-dialect so be sure to check the DBD documentation also. SQL::Statement is meant primarily as a base class for DBD drivers and as such concentrates on a small but useful subset of SQL. It does *not* in any way pretend to be a complete SQL parser for all dialects of SQL. The module will continue to add new supported syntax, and users may also extend the syntax (see L<#Extending the SQL syntax>). =head1 USAGE =head2 Default Supported SQL syntax - Summary B CALL CREATE [TEMP] TABLE
CREATE [TEMP] TABLE
AS
AS IMPORT() CREATE FUNCTION [ NAME ] CREATE KEYWORD [ NAME ] CREATE OPERATOR [ NAME ] CREATE TYPE [ NAME ] DELETE FROM
[] DROP TABLE [IF EXISTS]
DROP FUNCTION DROP KEYWORD DROP OPERATOR DROP TYPE INSERT [INTO]
[] VALUES LOAD SELECT SELECT [] [ ORDER BY ocol1 [ASC|DESC], ... ocolN [ASC|DESC]] ] [ GROUP BY gcol1 [, ... gcolN] ] [ LIMIT [start,] length ] UPDATE
SET [] B NATURAL, INNER, OUTER, LEFT, RIGHT, FULL B * Aggregate : MIN, MAX, AVG, SUM, COUNT * Date/Time : CURRENT_DATE, CURDATE, CURRENT_TIME, CURTIME, CURRENT_TIMESTAMP, NOW, UNIX_TIMESTAMP * String : ASCII, CHAR, BIT_LENGTH, CHARACTER_LENGTH, CHAR_LENGTH, COALESCE, NVL, IFNULL, CONV, CONCAT, DECODE, HEX, OCT, BIN, INSERT, LEFT, RIGHT, LOCATE, POSITION, LOWER, UPPER, LCASE, UCASE, LTRIM, RTRIM, OCTET_LENGTH, REGEX, REPEAT, REPLACE, SOUNDEX, SPACE, SUBSTITUTE, SUBSTRING, SUBSTR, TRANSLATE, TRIM, UNHEX * Numeric : ABS, CEILING, CEIL, FLOOR, ROUND, EXP, LOG, LN, LOG10, MOD, POWER, RAND, SIGN, SQRT, TRUNCATE, TRUNC * Trig : ACOS, ACOSEC, ACOSECH, ACOSH, ACOT, ACOTAN, ACOTANH, ACOTH, ACSC, ACSCH, ASEC, ASECH, ASIN, ASINH, ATAN, ATAN2, ATANH, COS, COSEC, COSECH, COSH, COT, COTAN, COTANH, COTH, CSC, CSCH, DEG2DEG, DEG2GRAD, DEG2RAD, DEGREES, GRAD2DEG, GRAD2GRAD, GRAD2RAD, PI, RAD2DEG, RAD2GRAD, RAD2RAD, RADIANS, SEC, SECH, SIN, SINH, TAN, TANH * System : DBNAME, USERNAME, USER B * IMPORT - imports a table from an external RDBMS or perl structure * RUN - prepares and executes statements in a file of SQL statements B = , <> , < , > , <= , >= , IS [NOT] (NULL|TRUE|FALSE) , LIKE , CLIKE , IN , BETWEEN B and B * regular identifiers are case insensitive (though see note on table names) * delimited identifiers (inside double quotes) are case sensitive * column and table aliases are supported B * use either ANSI SQL || or the CONCAT() function * e.g. these are the same: {foo || bar} {CONCAT(foo,bar)} B * comments must occur before or after statements, cannot be embedded * SQL-style single line -- and C-style multi-line /* */ comments are supported B * currently NULLs and empty strings are identical in non-ANSI dialect. * use {col IS NULL} to find NULLs, not {col=''} (though both may work depending on dialect) See below for further details. =head2 Syntax - Details =head3 CREATE TABLE Creates permanent and in-memory tables. CREATE [TEMP] TABLE ( ) CREATE [TEMP] TABLE AS will be evaluated the same as C