SQL-Abstract-2.000001/0000755000000000000000000000000014002747454014141 5ustar00rootroot00000000000000SQL-Abstract-2.000001/examples/0000755000000000000000000000000014002747454015757 5ustar00rootroot00000000000000SQL-Abstract-2.000001/examples/sqla2passthrough.pl0000644000000000000000000000336114002362432021616 0ustar00rootroot00000000000000use strict; use warnings; use Devel::Dwarn; use With::Roles; { package MySchema; use Object::Tap; use base qw(DBIx::Class::Schema); use DBIx::Class::ResultSource::Table; __PACKAGE__->register_source( Foo => DBIx::Class::ResultSource::Table->new({ name => 'foo' }) ->$_tap(add_columns => qw(x y z)) ); __PACKAGE__->register_source( Bar => DBIx::Class::ResultSource::Table->new({ name => 'bar' }) ->$_tap(add_columns => qw(x y1 y2 z)) ); } { package MyScratchpad; use DBIx::Class::SQLMaker::Role::SQLA2Passthrough qw(on); MySchema->source('Foo')->add_relationship(bars => 'Bar' => on { +{ 'foreign.x' => 'self.x', 'foreign.y1' => { '<=', 'self.y' }, 'foreign.y2' => { '>=', 'self.y' }, }; }); } my $s = MySchema->connect('dbi:SQLite:dbname=:memory:'); ::Dwarn([ $s->source('Foo')->columns ]); my $rs = $s->resultset('Foo')->search({ z => 1 }); ::Dwarn(${$rs->as_query}->[0]); $s->storage->ensure_connected; $s->storage ->sql_maker ->with::roles('DBIx::Class::SQLMaker::Role::SQLA2Passthrough') ->plugin('+ExtraClauses') ->plugin('+BangOverrides'); warn ref($s->storage->sql_maker); my $rs2 = $s->resultset('Foo')->search({ -op => [ '=', { -ident => 'outer.x' }, { -ident => 'me.y' } ] }, { 'select' => [ 'me.x', { -ident => 'me.z' } ], '!with' => [ outer => $rs->get_column('x')->as_query ], }); ::Dwarn(${$rs2->as_query}->[0]); my $rs3 = $s->resultset('Foo') ->search({}, { prefetch => 'bars' }); ::Dwarn(${$rs3->as_query}->[0]); $s->source('Foo')->result_class('DBIx::Class::Core'); $s->source('Foo')->set_primary_key('x'); my $rs4 = $s->resultset('Foo')->new_result({ x => 1, y => 2 }) ->search_related('bars'); ::Dwarn(${$rs4->as_query}->[0]); SQL-Abstract-2.000001/examples/sqla-format0000755000000000000000000000251213340604277020132 0ustar00rootroot00000000000000#!/usr/bin/env perl use warnings; use strict; use Getopt::Long; my $p = Getopt::Long::Parser->new(config => [qw( gnu_getopt no_ignore_case )]); my $opts = { profile => 'console', help => \&showhelp }; $p->getoptions( $opts, qw( profile|p=s help|h )) or showhelp(); sub showhelp { require Pod::Usage; Pod::Usage::pod2usage( -verbose => 0, -exitval => 2 ); } require SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ profile => $opts->{profile}, fill_in_placeholders => 0 }); my $chunk = ''; my $leftover = ''; do { $chunk = $leftover . $chunk if length $leftover; if ($chunk =~ / \A (.+?) (?: (?<=\S)\:\s+\'[^\n]+ # pasting DBIC_TRACE output directly | \;(?: \s | \z) | \z | ^ \s* (?=SELECT|INSERT|UPDATE|DELETE) ) (.*) /smix) { $leftover = $2; print $sqlat->format($1); print "\n"; } else { $leftover = $chunk; } } while ( (read *STDIN, $chunk, 4096) or length $leftover ); =head1 NAME sqla-format - An intelligent SQL formatter =head1 SYNOPSIS ~$ sqla-format << log.sql ~$ myprogram -v | sqla-format -p html > sqltrace.html =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. SQL-Abstract-2.000001/examples/bangdbic.pl0000644000000000000000000000274714002362432020044 0ustar00rootroot00000000000000use strict; use warnings; { package MySchema; use Object::Tap; use base qw(DBIx::Class::Schema); use DBIx::Class::ResultSource::Table; __PACKAGE__->register_source( Foo => DBIx::Class::ResultSource::Table->new({ name => 'foo' }) ->$_tap(add_columns => qw(x y z)) ); __PACKAGE__->register_source( Bar => DBIx::Class::ResultSource::Table->new({ name => 'bar' }) ->$_tap(add_columns => qw(a b c)) ); } my $s = MySchema->connect('dbi:SQLite:dbname=:memory:'); my $rs = $s->resultset('Foo')->search({ z => 1 }); warn ${$rs->as_query}->[0]."\n"; $s->storage->ensure_connected; $s->storage ->sql_maker->plugin('+ExtraClauses')->plugin('+BangOverrides'); my $rs2 = $s->resultset('Foo')->search({ -op => [ '=', { -ident => 'outer.y' }, { -ident => 'me.x' } ] }); warn ${$rs2->as_query}->[0]."\n"; my $rs3 = $rs2->search({}, { '!from' => sub { my ($sqla, $from) = @_; my $base = $sqla->expand_expr({ -old_from => $from }); return [ $base, -join => [ 'wub', on => [ 'me.z' => 'wub.z' ] ] ]; } }); warn ${$rs3->as_query}->[0]."\n"; my $rs4 = $rs3->search({}, { '!with' => [ [ qw(wub x y z) ], $s->resultset('Bar')->as_query ], }); warn ${$rs4->as_query}->[0]."\n"; my $rs5 = $rs->search({}, { select => [ { -coalesce => [ { -ident => 'x' }, { -value => 7 } ] } ] }); warn ${$rs5->as_query}->[0]."\n"; my $rs6 = $rs->search({}, { '!select' => [ { -coalesce => [ { -ident => 'x' }, { -value => 7 } ] } ] }); warn ${$rs6->as_query}->[0]."\n"; SQL-Abstract-2.000001/examples/dbic-console.pl0000644000000000000000000000065413340604277020661 0ustar00rootroot00000000000000#!/sur/bin/env perl use warnings; use strict; use DBIx::Class::Storage::Debug::PrettyPrint; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => 'console', show_progress => 1, }); $pp->txn_begin; $pp->query_start("SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE ?", q('station')); sleep 1; $pp->query_end("SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE ?", q('station')); $pp->txn_commit; SQL-Abstract-2.000001/examples/console.pl0000644000000000000000000000757713340604277017775 0ustar00rootroot00000000000000#!/sur/bin/env perl use warnings; use strict; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ profile => 'console' }); my @sql = ( "BEGIN WORK", "SELECT a, b, c FROM foo WHERE foo.a =1 and foo.b LIKE 'station'", "SELECT * FROM (SELECT * FROM foobar) WHERE foo.a =1 and foo.b LIKE 'station'", "SELECT * FROM lolz WHERE ( foo.a =1 ) and foo.b LIKE 'station'", "SELECT * LIMIT 5 OFFSET 5 FROM lolz ", "SELECT * LIMIT 5 5 FROM lolz ", "SELECT SKIP 5 FIRST 5 * FROM lolz ", "SELECT FIRST 5 SKIP 5 * FROM lolz ", "UPDATE session SET expires = ? WHERE (id = ?)", "INSERT INTO Request (creation_date, is_private, owner_id, request) VALUES (? , ? , ? , ?)", "SELECT [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype] FROM [users_roles] [me] JOIN [roles] [role] ON [role].[id] = [me].[role_id] JOIN [roles_permissions] [role_permissions] ON [role_permissions].[role_id] = [role].[id] JOIN [permissions] [permission] ON [permission].[id] = [role_permissions].[permission_id] JOIN [permissionscreens] [permission_screens] ON [permission_screens].[permission_id] = [permission].[id] JOIN [screens] [screen] ON [screen].[id] = [permission_screens].[screen_id] WHERE ( [me].[user_id] = ? ) GROUP BY [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype]", "SELECT [status], [supplier_id], [ship_to_supplier_id], [request_by_user_id], [is_printed], [creation_date], [id], [date], [fob_state], [is_confirmed], [is_outside_process], [ship_via], [special_instructions], [when_shipped] FROM ( SELECT [status], [supplier_id], [ship_to_supplier_id], [request_by_user_id], [is_printed], [creation_date], [id], [date], [fob_state], [is_confirmed], [is_outside_process], [ship_via], [special_instructions], [when_shipped], ROW_NUMBER() OVER( ORDER BY [me].[id] DESC ) AS [rno__row__index] FROM ( SELECT [me].[status], [me].[supplier_id], [me].[ship_to_supplier_id], [me].[request_by_user_id], [me].[is_printed], [me].[creation_date], [me].[id], [me].[date], [me].[fob_state], [me].[is_confirmed], [me].[is_outside_process], [me].[ship_via], [me].[special_instructions], [me].[when_shipped] FROM [PurchaseOrders] [me] WHERE ( [me].[status] = ? ) ) [me] ) [me] WHERE [rno__row__index] BETWEEN 1 AND 25", "SELECT me.id, me.name, me.creator_id, group_users.group_id, group_users.user_id, user.id, user.first_name, user.last_name, user.nickname, user.email, user.password, user.is_active, user.logins FROM Group me LEFT JOIN GroupUser group_users ON group_users.group_id = me.id LEFT JOIN User user ON user.id = group_users.user_id WHERE (me.creator_id = ?) ORDER BY name, group_users.group_id", "COMMIT", 'ROLLBACK', 'SAVEPOINT station', 'ROLLBACK TO SAVEPOINT station', 'RELEASE SAVEPOINT station', "SELECT COUNT( * ) FROM message_children me WHERE( ( me.phone_number NOT IN ( SELECT message_child.phone_number FROM blocked_destinations me JOIN message_children_status reason ON reason.id = me.reason_id JOIN message_children message_child ON message_child.id = reason.message_child_id) AND ( ( me.api_id IS NULL ) ) ) )" ); print "\n\n'" . $sqlat->format($_) . "'\n" for @sql; print "\n\n'" . $sqlat->format( "UPDATE session SET expires = ? WHERE (id = ?)", ['2010-12-02', 1] ) . "'\n"; print "\n\n'" . $sqlat->format( "SELECT raw_scores FROM ( SELECT raw_scores, ROW_NUMBER() OVER ( ORDER BY ( SELECT (1))) AS rno__row__index FROM ( SELECT rpt_score.raw_scores FROM users me JOIN access access ON access.userid = me.userid JOIN mgmt mgmt ON mgmt.mgmtid = access.mgmtid JOIN [order] orders ON orders.mgmtid = mgmt.mgmtid JOIN shop shops ON shops.orderno = orders.orderno JOIN rpt_scores rpt_score ON rpt_score.shopno = shops.shopno WHERE ( datecompleted IS NOT NULL AND ( (shops.datecompleted BETWEEN ? AND ?) AND (type = ? AND me.userid = ?)))) rpt_score) rpt_score WHERE rno__row__index BETWEEN ? AND ? )", ['2009-10-01', '2009-10-08', 1, 'frew', 1, 1] ) . "'\n"; SQL-Abstract-2.000001/LICENSE0000644000000000000000000004342114002747454015152 0ustar00rootroot00000000000000Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2021 by Nathan Wiger . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2021 by Nathan Wiger . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End SQL-Abstract-2.000001/maint/0000755000000000000000000000000014002747454015251 5ustar00rootroot00000000000000SQL-Abstract-2.000001/maint/podregen0000755000000000000000000000305014002362432016765 0ustar00rootroot00000000000000#!/usr/bin/env perl use lib 'lib'; use strictures 2; use Data::Dumper::Compact; use Devel::DDCWarn; use SQL::Abstract::Formatter; use SQL::Abstract; my $ddc = Data::Dumper::Compact->new(max_width => 72); my $sqla = SQL::Abstract->new( lazy_join_sql_parts => 1, )->plugin('+ExtraClauses'); my $sqlaf = SQL::Abstract::Formatter->new(max_width => 72); while (1) { my $line = ; exit 0 unless defined $line; print $line; last if $line =~ /\A__END__/; } my $slurp = do { local $/; }; my ($expr_re, $aqt_re, $query_re) = map qr/(?sm:(.*?)( +)(# ${_}\n)(?:\n|(.*?)\n\n))/, qw(expr aqt query); sub reformat { my ($thing, $indent) = @_; my $thing_ddc = $ddc->dump($thing); $thing_ddc =~ s/^/$indent/mg; return $thing_ddc; } sub seval { eval('+('.$_[0].')') or die "seval: $_[0]: $@" } while ($slurp =~ m/\G$expr_re/gc) { my ($pre, $indent, $type, $expr_str) = ($1, $2, $3, $4); print $pre.$indent.$type; print reformat(my $expr = seval($expr_str), $indent); print "\n"; die unless $slurp =~ m/\G$query_re/g; my ($qpre, $qindent, $qtype) = ($1, $2, $3); if ($qpre =~ s/\A$aqt_re//) { my ($apre, $aindent, $atype) = ($1, $2, $3); print $apre.$aindent.$atype; print reformat($sqla->expand_expr($expr), $aindent); print "\n"; } print $qpre.$qindent.$qtype; my ($sql, @bind) = $sqla->render_statement($expr); my $fsql = (ref($sql) ? $sqlaf->format(@$sql) : $sql); s/^/$indent/mg, s/\n+\Z// for $fsql; print $fsql."\n"; print reformat(\@bind, $qindent); print "\n"; } $slurp =~ /\G(.*)$/sm; print $1; SQL-Abstract-2.000001/maint/sqlacexpr0000755000000000000000000000066614002362432017176 0ustar00rootroot00000000000000#!/usr/bin/env perl use lib 'lib'; use strictures 2; use SQL::Abstract; use Devel::DDCWarn; warn $ARGV[1]."\n"; my $sqlac = SQL::Abstract->new( unknown_unop_always_func => 1, lazy_join_sql_parts => 1, )->plugin('+ExtraClauses'); my @args = ($ARGV[1] =~ /^\.\// ? do $ARGV[1] : eval '+('.$ARGV[1].')'); die $@ if $@; my ($q, @bind) = $sqlac->${\$ARGV[0]}(@args); print STDERR +(ref($q) ? $q->format : $q)."\n"; Dwarn [ @bind ]; SQL-Abstract-2.000001/maint/inplace0000755000000000000000000000036114002362432016577 0ustar00rootroot00000000000000#!/usr/bin/env perl use strictures 2; use autodie; my ($cmd, $file, @args) = @ARGV; my $input = do { local (@ARGV, $/) = $file; <> }; close STDOUT; open STDOUT, '>', $file; open $out, '|-', $cmd, @args; print $out $input; close $out; SQL-Abstract-2.000001/maint/Makefile.PL.include0000644000000000000000000000041113340604277020640 0ustar00rootroot00000000000000BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar 0.001; use ExtUtils::MakeMaker 6.57_10 (); author 'Nathan Wiger '; manifest_include examples => qr/sqla-format|.*\.pl/; 1; SQL-Abstract-2.000001/maint/sqlaexpr0000755000000000000000000000030014002362432017014 0ustar00rootroot00000000000000#!/usr/bin/env perl use lib 'lib'; use SQL::Abstract; use Devel::Dwarn; warn $ARGV[1]; my @args = eval '('.$ARGV[1].')'; die $@ if $@; Dwarn([ SQL::Abstract->new->${\$ARGV[0]}(@args) ]); SQL-Abstract-2.000001/maint/lib/0000755000000000000000000000000014002747454016017 5ustar00rootroot00000000000000SQL-Abstract-2.000001/maint/lib/Chunkstrumenter.pm0000644000000000000000000000104014002362432021536 0ustar00rootroot00000000000000package Chunkstrumenter; use strictures 2; use Class::Method::Modifiers qw(install_modifier); use Data::Dumper::Concise; use Context::Preserve; require SQL::Abstract; open my $log_fh, '>>', 'chunkstrumenter.log'; install_modifier 'SQL::Abstract', around => '_order_by_chunks' => sub { my ($orig, $self) = (shift, shift); my @args = @_; preserve_context { $self->$orig(@args) } after => sub { my $dumped = Dumper([ $self->{quote_char}, \@args, \@_ ]); $dumped =~ s/\n\Z/,\n/; print $log_fh $dumped; }; }; 1; SQL-Abstract-2.000001/t/0000755000000000000000000000000014002747454014404 5ustar00rootroot00000000000000SQL-Abstract-2.000001/t/02where.t0000644000000000000000000002641014002362432016035 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where dumper) ]; use SQL::Abstract; my $not_stringifiable = bless {}, 'SQLA::NotStringifiable'; my @handle_tests = ( { where => 'foo', order => [], stmt => ' WHERE foo', bind => [], }, { where => { requestor => 'inna', worker => ['nwiger', 'rcwe', 'sfz'], status => { '!=', 'completed' } }, order => [], stmt => " WHERE ( requestor = ? AND status != ? AND ( ( worker = ? ) OR" . " ( worker = ? ) OR ( worker = ? ) ) )", bind => [qw/inna completed nwiger rcwe sfz/], }, { where => [ status => 'completed', user => 'nwiger', ], stmt => " WHERE ( status = ? OR user = ? )", bind => [qw/completed nwiger/], }, { where => { user => 'nwiger', status => 'completed' }, order => [qw/ticket/], stmt => " WHERE ( status = ? AND user = ? ) ORDER BY ticket", bind => [qw/completed nwiger/], }, { where => { user => 'nwiger', status => { '!=', 'completed' } }, order => [qw/ticket/], stmt => " WHERE ( status != ? AND user = ? ) ORDER BY ticket", bind => [qw/completed nwiger/], }, { where => { status => 'completed', reportid => { 'in', [567, 2335, 2] } }, order => [], stmt => " WHERE ( reportid IN ( ?, ?, ? ) AND status = ? )", bind => [qw/567 2335 2 completed/], }, { where => { status => 'completed', reportid => { 'not in', [567, 2335, 2] } }, order => [], stmt => " WHERE ( reportid NOT IN ( ?, ?, ? ) AND status = ? )", bind => [qw/567 2335 2 completed/], }, { where => { status => 'completed', completion_date => { 'between', ['2002-10-01', '2003-02-06'] }, }, order => \'ticket, requestor', stmt => "WHERE ( ( completion_date BETWEEN ? AND ? ) AND status = ? ) ORDER BY ticket, requestor", bind => [qw/2002-10-01 2003-02-06 completed/], }, { where => [ { user => 'nwiger', status => { 'in', ['pending', 'dispatched'] }, }, { user => 'robot', status => 'unassigned', }, ], order => [], stmt => " WHERE ( ( status IN ( ?, ? ) AND user = ? ) OR ( status = ? AND user = ? ) )", bind => [qw/pending dispatched nwiger unassigned robot/], }, { where => { priority => [ {'>', 3}, {'<', 1} ], requestor => \'is not null', }, order => 'priority', stmt => " WHERE ( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor is not null ) ORDER BY priority", bind => [qw/3 1/], }, { where => { requestor => { '!=', ['-and', undef, ''] }, }, stmt => " WHERE ( requestor IS NOT NULL AND requestor != ? )", bind => [''], }, { where => { requestor => [undef, ''], }, stmt => " WHERE ( requestor IS NULL OR requestor = ? )", bind => [''], }, { where => { priority => [ {'>', 3}, {'<', 1} ], requestor => { '!=', undef }, }, order => [qw/a b c d e f g/], stmt => " WHERE ( ( ( priority > ? ) OR ( priority < ? ) ) AND requestor IS NOT NULL )" . " ORDER BY a, b, c, d, e, f, g", bind => [qw/3 1/], }, { where => { priority => { 'between', [1, 3] }, requestor => { 'like', undef }, }, order => \'requestor, ticket', stmt => " WHERE ( ( priority BETWEEN ? AND ? ) AND requestor IS NULL ) ORDER BY requestor, ticket", bind => [qw/1 3/], warns => qr/Supplying an undefined argument to 'LIKE' is deprecated/, }, { where => { id => 1, num => { '<=' => 20, '>' => 10, }, }, stmt => " WHERE ( id = ? AND ( num <= ? AND num > ? ) )", bind => [qw/1 20 10/], }, { where => { foo => {-not_like => [7,8,9]}, fum => {'like' => [qw/a b/]}, nix => {'between' => [100,200] }, nox => {'not between' => [150,160] }, wix => {'in' => [qw/zz yy/]}, wux => {'not_in' => [qw/30 40/]} }, stmt => " WHERE ( ( ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) OR ( foo NOT LIKE ? ) ) AND ( ( fum LIKE ? ) OR ( fum LIKE ? ) ) AND ( nix BETWEEN ? AND ? ) AND ( nox NOT BETWEEN ? AND ? ) AND wix IN ( ?, ? ) AND wux NOT IN ( ?, ? ) )", bind => [7,8,9,'a','b',100,200,150,160,'zz','yy','30','40'], warns => qr/\QA multi-element arrayref as an argument to the inequality op 'NOT LIKE' is technically equivalent to an always-true 1=1/, }, { where => { bar => {'!=' => []}, }, stmt => " WHERE ( 1=1 )", bind => [], }, { where => { id => [], }, stmt => " WHERE ( 0=1 )", bind => [], }, { where => { foo => \["IN (?, ?)", 22, 33], bar => [-and => \["> ?", 44], \["< ?", 55] ], }, stmt => " WHERE ( (bar > ? AND bar < ?) AND foo IN (?, ?) )", bind => [44, 55, 22, 33], }, { where => { -and => [ user => 'nwiger', [ -and => [ workhrs => {'>', 20}, geo => 'ASIA' ], -or => { workhrs => {'<', 50}, geo => 'EURO' }, ], ], }, stmt => "WHERE ( user = ? AND ( ( workhrs > ? AND geo = ? ) OR ( geo = ? OR workhrs < ? ) ) )", bind => [qw/nwiger 20 ASIA EURO 50/], }, { where => { -and => [{}, { 'me.id' => '1'}] }, stmt => " WHERE ( ( me.id = ? ) )", bind => [ 1 ], }, { where => { foo => $not_stringifiable, }, stmt => " WHERE ( foo = ? )", bind => [ $not_stringifiable ], }, { where => \[ 'foo = ?','bar' ], stmt => " WHERE (foo = ?)", bind => [ "bar" ], }, { where => [ \[ 'foo = ?','bar' ] ], stmt => " WHERE (foo = ?)", bind => [ "bar" ], }, { where => { -bool => \'function(x)' }, stmt => " WHERE function(x)", bind => [], }, { where => { -bool => 'foo' }, stmt => " WHERE foo", bind => [], }, { where => { -and => [-bool => 'foo', -bool => 'bar'] }, stmt => " WHERE foo AND bar", bind => [], }, { where => { -or => [-bool => 'foo', -bool => 'bar'] }, stmt => " WHERE foo OR bar", bind => [], }, { where => { -not_bool => \'function(x)' }, stmt => " WHERE NOT function(x)", bind => [], }, { where => { -not_bool => 'foo' }, stmt => " WHERE NOT foo", bind => [], }, { where => { -and => [-not_bool => 'foo', -not_bool => 'bar'] }, stmt => " WHERE (NOT foo) AND (NOT bar)", bind => [], }, { where => { -or => [-not_bool => 'foo', -not_bool => 'bar'] }, stmt => " WHERE (NOT foo) OR (NOT bar)", bind => [], }, { where => { -bool => \['function(?)', 20] }, stmt => " WHERE function(?)", bind => [20], }, { where => { -not_bool => \['function(?)', 20] }, stmt => " WHERE NOT function(?)", bind => [20], }, { where => { -bool => { a => 1, b => 2} }, stmt => " WHERE a = ? AND b = ?", bind => [1, 2], }, { where => { -bool => [ a => 1, b => 2] }, stmt => " WHERE a = ? OR b = ?", bind => [1, 2], }, { where => { -not_bool => { a => 1, b => 2} }, stmt => " WHERE NOT (a = ? AND b = ?)", bind => [1, 2], }, { where => { -not_bool => [ a => 1, b => 2] }, stmt => " WHERE NOT ( a = ? OR b = ? )", bind => [1, 2], }, # Op against internal function { where => { bool1 => { '=' => { -not_bool => 'bool2' } } }, stmt => " WHERE ( bool1 = (NOT bool2) )", bind => [], }, { where => { -not_bool => { -not_bool => { -not_bool => 'bool2' } } }, stmt => " WHERE ( NOT ( NOT ( NOT bool2 ) ) )", bind => [], }, # Op against random functions (these two are oracle-specific) { where => { timestamp => { '!=' => { -trunc => { -year => \'sysdate' } } } }, stmt => " WHERE ( timestamp != TRUNC(YEAR(sysdate)) )", bind => [], }, { where => { timestamp => { '>=' => { -to_date => '2009-12-21 00:00:00' } } }, stmt => " WHERE ( timestamp >= TO_DATE(?) )", bind => ['2009-12-21 00:00:00'], }, # Legacy function specs { where => { ip => {'<<=' => '127.0.0.1/32' } }, stmt => "WHERE ( ip <<= ? )", bind => ['127.0.0.1/32'], }, { where => { foo => { 'GLOB' => '*str*' } }, stmt => " WHERE foo GLOB ? ", bind => [ '*str*' ], }, { where => { foo => { 'REGEXP' => 'bar|baz' } }, stmt => " WHERE foo REGEXP ? ", bind => [ 'bar|baz' ], }, # Tests for -not # Basic tests only { where => { -not => { a => 1 } }, stmt => " WHERE ( (NOT a = ?) ) ", bind => [ 1 ], }, { where => { a => 1, -not => { b => 2 } }, stmt => " WHERE ( ( (NOT b = ?) AND a = ? ) ) ", bind => [ 2, 1 ], }, { where => { -not => { a => 1, b => 2, c => 3 } }, stmt => " WHERE ( (NOT ( a = ? AND b = ? AND c = ? )) ) ", bind => [ 1, 2, 3 ], }, { where => { -not => [ a => 1, b => 2, c => 3 ] }, stmt => " WHERE ( (NOT ( a = ? OR b = ? OR c = ? )) ) ", bind => [ 1, 2, 3 ], }, { where => { -not => { c => 3, -not => { b => 2, -not => { a => 1 } } } }, stmt => " WHERE ( (NOT ( (NOT ( (NOT a = ?) AND b = ? )) AND c = ? )) ) ", bind => [ 1, 2, 3 ], }, { where => { -not => { -bool => 'c', -not => { -not_bool => 'b', -not => { a => 1 } } } }, stmt => " WHERE ( (NOT ( c AND (NOT ( (NOT a = ?) AND (NOT b) )) )) ) ", bind => [ 1 ], }, { where => \"0", stmt => " WHERE ( 0 ) ", bind => [ ], }, { where => { artistid => {} }, stmt => '', bind => [ ], }, { where => [ -and => [ {}, [] ], -or => [ {}, [] ] ], stmt => '', bind => [ ], }, { where => { '=' => \'bozz' }, stmt => 'WHERE = bozz', bind => [ ], }, ); for my $case (@handle_tests) { my $sql = SQL::Abstract->new; my ($stmt, @bind); lives_ok { warnings_like { ($stmt, @bind) = $sql->where($case->{where}, $case->{order}); } $case->{warns} || []; }; is_same_sql_bind($stmt, \@bind, $case->{stmt}, $case->{bind}) || do { diag_where ( $case->{where} ); diag dumper($sql->_expand_expr($case->{where})) }; } done_testing; SQL-Abstract-2.000001/t/08special_ops.t0000644000000000000000000000520614002362432017232 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract; my $sqlmaker = SQL::Abstract->new(special_ops => [ # special op for MySql MATCH (field) AGAINST(word1, word2, ...) {regex => qr/^match$/i, handler => sub { my ($self, $field, $op, $arg) = @_; $arg = [$arg] if not ref $arg; my $label = $self->_quote($field); my ($placeholder) = $self->_convert('?'); my $placeholders = join ", ", (($placeholder) x @$arg); my $sql = $self->_sqlcase('match') . " ($label) " . $self->_sqlcase('against') . " ($placeholders) "; my @bind = $self->_bindtype($field, @$arg); return ($sql, @bind); } }, # special op for Basis+ NATIVE {regex => qr/^native$/i, handler => sub { my ($self, $field, $op, $arg) = @_; $arg =~ s/'/''/g; my $sql = "NATIVE (' $field $arg ')"; return ($sql); } }, # PRIOR op from DBIx::Class::SQLMaker::Oracle { regex => qr/^prior$/i, handler => sub { my ($self, $lhs, $op, $rhs) = @_; my ($sql, @bind) = $self->_recurse_where ($rhs); $sql = sprintf ('%s = %s %s ', $self->_convert($self->_quote($lhs)), $self->_sqlcase ($op), $sql ); return ($sql, @bind); }, }, ], unary_ops => [ # unary op from Mojo::Pg {regex => qr/^json$/i, handler => sub { '?', { json => $_[2] } } }, ]); my @tests = ( #1 { where => {foo => {-match => 'foo'}, bar => {-match => [qw/foo bar/]}}, stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )", bind => [qw/foo bar foo/], }, #2 { where => {foo => {-native => "PH IS 'bar'"}}, stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )", bind => [], }, #3 { where => { foo => { -json => { bar => 'baz' } } }, stmt => "WHERE foo = ?", bind => [ { json => { bar => 'baz' } } ], }, #4 { where => { foo => { '@>' => { -json => { bar => 'baz' } } } }, stmt => "WHERE foo @> ?", bind => [ { json => { bar => 'baz' } } ], }, # Verify inconsistent behaviour from DBIx::Class:SQLMaker::Oracle works # (unary use of special op is not equivalent to special op + =) { where => { foo_id => { '=' => { '-prior' => { -ident => 'bar_id' } } }, baz_id => { '-prior' => { -ident => 'quux_id' } }, }, stmt => ' WHERE ( baz_id = PRIOR quux_id AND foo_id = ( PRIOR bar_id ) )', bind => [], }, ); for (@tests) { my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order}); is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); } done_testing; SQL-Abstract-2.000001/t/80extra_clauses.t0000644000000000000000000002650714002362432017602 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Test import => [ qw(is_same_sql_bind is_same_sql) ]; use SQL::Abstract; my $sqlac = SQL::Abstract->new->plugin('+ExtraClauses'); is_deeply( [ $sqlac->statement_list ], [ sort qw(select update insert delete) ], ); my ($sql, @bind) = $sqlac->select({ select => [ qw(artist.id artist.name), { -json_agg => 'cd' } ], from => [ { artists => { -as => 'artist' } }, -join => [ cds => as => 'cd' => on => { 'cd.artist_id' => 'artist.id' } ], ], where => { 'artist.genres', => { '@>', { -value => [ 'Rock' ] } } }, order_by => 'artist.name', group_by => 'artist.id', having => { '>' => [ { -count => 'cd.id' }, 3 ] } }); is_same_sql_bind( $sql, \@bind, q{ SELECT artist.id, artist.name, JSON_AGG(cd) FROM artists AS artist JOIN cds AS cd ON cd.artist_id = artist.id WHERE artist.genres @> ? GROUP BY artist.id HAVING COUNT(cd.id) > ? ORDER BY artist.name }, [ [ 'Rock' ], 3 ] ); ($sql) = $sqlac->select({ select => [ 'a' ], from => [ { -values => [ [ 1, 2 ], [ 3, 4 ] ] }, -as => [ qw(t a b) ] ], }); is_same_sql($sql, q{SELECT a FROM (VALUES (1, 2), (3, 4)) AS t(a,b)}); ($sql) = $sqlac->update({ update => 'employees', set => { sales_count => { sales_count => { '+', \1 } } }, from => 'accounts', where => { 'accounts.name' => { '=' => \"'Acme Corporation'" }, 'employees.id' => { -ident => 'accounts.sales_person' }, } }); is_same_sql( $sql, q{UPDATE employees SET sales_count = sales_count + 1 FROM accounts WHERE accounts.name = 'Acme Corporation' AND employees.id = accounts.sales_person } ); ($sql) = $sqlac->update({ update => [ qw(tab1 tab2) ], set => { 'tab1.column1' => { -ident => 'value1' }, 'tab1.column2' => { -ident => 'value2' }, }, where => { 'tab1.id' => { -ident => 'tab2.id' } }, }); is_same_sql( $sql, q{UPDATE tab1, tab2 SET tab1.column1 = value1, tab1.column2 = value2 WHERE tab1.id = tab2.id} ); is_same_sql( $sqlac->delete({ from => 'x', using => 'y', where => { 'x.id' => { -ident => 'y.x_id' } } }), q{DELETE FROM x USING y WHERE x.id = y.x_id} ); is_same_sql( $sqlac->select({ select => [ 'x.*', 'y.*' ], from => [ 'x', -join => [ 'y', using => 'y_id' ] ], }), q{SELECT x.*, y.* FROM x JOIN y USING (y_id)}, ); is_same_sql( $sqlac->select({ select => 'x.*', from => [ { -select => { select => '*', from => 'y' } }, -as => 'x' ], }), q{SELECT x.* FROM (SELECT * FROM y) AS x}, ); is_same_sql( $sqlac->insert({ into => 'foo', select => { select => '*', from => 'bar' } }), q{INSERT INTO foo SELECT * FROM bar} ); ($sql, @bind) = $sqlac->insert({ into => 'eh', rowvalues => [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ] }); is_same_sql_bind( $sql, \@bind, q{INSERT INTO eh VALUES (?, ?), (?, ?), (?, ?)}, [ 1..6 ], ); is_same_sql( $sqlac->select({ select => '*', from => 'foo', where => { -not_exists => { -select => { select => \1, from => 'bar', where => { 'foo.id' => { -ident => 'bar.foo_id' } } }, } }, }), q{SELECT * FROM foo WHERE NOT EXISTS (SELECT 1 FROM bar WHERE foo.id = bar.foo_id)}, ); is_same_sql( $sqlac->select({ select => '*', from => 'foo', where => { id => { '=' => { -select => { select => { -max => 'id' }, from => 'foo' } } } }, }), q{SELECT * FROM foo WHERE id = (SELECT MAX(id) FROM foo)}, ); { my $sqlac = $sqlac->clone ->clauses_of( select => ( $sqlac->clauses_of('select'), qw(limit offset), ) ); ($sql, @bind) = $sqlac->select({ select => '*', from => 'foo', limit => 10, offset => 20, }); is_same_sql_bind( $sql, \@bind, q{SELECT * FROM foo LIMIT ? OFFSET ?}, [ 10, 20 ] ); } $sql = $sqlac->select({ select => { -as => [ \1, 'x' ] }, union => { -select => { select => { -as => [ \2, 'x' ] } } }, order_by => { -desc => 'x' }, }); is_same_sql( $sql, q{(SELECT 1 AS x) UNION (SELECT 2 AS x) ORDER BY x DESC}, ); $sql = $sqlac->select({ select => '*', from => 'foo', except => { -select => { select => '*', from => 'foo_exclusions' } } }); is_same_sql( $sql, q{(SELECT * FROM foo) EXCEPT (SELECT * FROM foo_exclusions)}, ); $sql = $sqlac->select({ with => [ foo => { -select => { select => \1 } } ], select => '*', from => 'foo' }); is_same_sql( $sql, q{WITH foo AS (SELECT 1) SELECT * FROM foo}, ); $sql = $sqlac->update({ _ => [ 'tree_table', -join => { to => { -select => { with_recursive => [ [ tree_with_path => qw(id parent_id path) ], { -select => { _ => [ qw(id parent_id), { -as => [ { -cast => { -as => [ id => char => 255 ] } }, 'path' ] }, ], from => 'tree_table', where => { parent_id => undef }, union_all => { -select => { _ => [ qw(t.id t.parent_id), { -as => [ { -concat => [ 'r.path', \q{'/'}, 't.id' ] }, 'path', ] }, ], from => [ tree_table => -as => t => -join => { to => 'tree_with_path', as => 'r', on => { 't.parent_id' => 'r.id' }, }, ], } }, } }, ], select => '*', from => 'tree_with_path' } }, as => 'tree', on => { 'tree.id' => 'tree_with_path.id' }, } ], set => { path => { -ident => [ qw(tree path) ] } }, }); is_same_sql( $sql, q{ UPDATE tree_table JOIN ( WITH RECURSIVE tree_with_path(id, parent_id, path) AS ( ( SELECT id, parent_id, CAST(id AS char(255)) AS path FROM tree_table WHERE parent_id IS NULL ) UNION ALL ( SELECT t.id, t.parent_id, CONCAT(r.path, '/', t.id) AS path FROM tree_table AS t JOIN tree_with_path AS r ON t.parent_id = r.id ) ) SELECT * FROM tree_with_path ) AS tree ON tree.id = tree_with_path.id SET path = tree.path }, ); ($sql, @bind) = $sqlac->insert({ with => [ faculty => { -select => { _ => [qw /p.person p.email/], from => [ person => -as => 'p' ], where => { 'p.person_type' => 'faculty', 'p.person_status' => { '!=' => 'pending' }, 'p.default_license_id' => undef, }, }, }, grandfather => { -insert => { into => 'license', fields => [ qw(kind expires_on valid_from) ], select => { select => [\(qw('grandfather' '2017-06-30' '2016-07-01'))], from => 'faculty', }, returning => 'license_id', } }, ], into => 'license_person', fields => [ qw(person_id license_id) ], select => { _ => ['person_id', 'license_id'], from => ['grandfather'], where => { 'a.index' => { -ident => 'b.index' }, }, }, }); is_same_sql_bind( $sql, \@bind, q{ WITH faculty AS ( SELECT p.person, p.email FROM person AS p WHERE ( p.default_license_id IS NULL AND p.person_status != ? AND p.person_type = ? ) ), grandfather AS ( INSERT INTO license (kind, expires_on, valid_from) SELECT 'grandfather', '2017-06-30', '2016-07-01' FROM faculty RETURNING license_id ) INSERT INTO license_person (person_id, license_id) SELECT person_id, license_id FROM grandfather WHERE a.index = b.index }, [ qw(pending faculty) ], ); ($sql, @bind) = $sqlac->delete({ with => [ instructors => { -select => { _ => [qw/p.person_id email default_license_id/], from => [ person => -as => 'p', -join => { to => 'license_person', as => 'lp', on => { 'lp.person_id' => 'p.person_id' }, }, -join => { to => 'license', as => 'l', on => { 'l.license_id' => 'lp.license_id' }, }, ], where => { 'p.person_type' => 'faculty', 'p.person_status' => { '!=' => 'pending' }, 'l.kind' => 'pending', }, group_by => [qw/ p.person_id /], having => { '>' => [ { -count => 'l.license_id' }, 1 ] } }, }, deletable_licenses => { -select => { _ => [qw/lp.ctid lp.person_id lp.license_id/], from => [ instructors => -as => 'i', -join => { to => 'license_person', as => 'lp', on => { 'lp.person_id' => 'i.person_id' }, }, -join => { to => 'license', as => 'l', on => { 'l.license_id' => 'lp.license_id' }, }, ], where => { 'lp.license_id' => { '<>' => {-ident => 'i.default_license_id'} }, 'l.kind' => 'pending', }, }, }, ], from => 'license_person', where => { ctid => { -in => { -select => { _ => ['ctid'], from => 'deletable_licenses', } } } } }); is_same_sql_bind( $sql, \@bind, q{ with instructors as ( select p.person_id, email, default_license_id from person as p join license_person as lp on lp.person_id = p.person_id join license as l on l.license_id = lp.license_id where l.kind = ? AND p.person_status != ? AND p.person_type = ? group by p.person_id having COUNT(l.license_id) > ?), deletable_licenses as ( select lp.ctid, lp.person_id, lp.license_id from instructors as i join license_person as lp on lp.person_id = i.person_id join license as l on l.license_id = lp.license_id where l.kind = ? and lp.license_id <> i.default_license_id ) delete from license_person where ctid IN ( (select ctid from deletable_licenses) ) }, [qw( pending pending faculty 1 pending )] ); ($sql, @bind) = $sqlac->update({ _ => ['survey'], set => { license_id => { -ident => 'info.default_license_id' }, }, from => [ -select => { select => [qw( s.survey_id p.default_license_id p.person_id)], from => [ person => -as => 'p', -join => { to => 'class', as => 'c', on => { 'c.faculty_id' => 'p.person_id' }, }, -join => { to => 'survey', as => 's', on => { 's.class_id' => 'c.class_id' }, }, ], where => { 'p.institution_id' => { -value => 15031 } }, }, -as => 'info', ], where => { 'info.survey_id' => { -ident => 'survey.survey_id' }, } }); is_same_sql_bind( $sql, \@bind, q{ update survey set license_id=info.default_license_id from ( select s.survey_id, p.default_license_id, p.person_id from person AS p join class AS c on c.faculty_id = p.person_id join survey AS s on s.class_id = c.class_id where p.institution_id = ? ) AS info where info.survey_id=survey.survey_id }, [qw( 15031 )] ); done_testing; SQL-Abstract-2.000001/t/01generate.t0000644000000000000000000012252214002362432016515 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where dumper)]; use SQL::Abstract; #### WARNING #### # # -nest has been undocumented on purpose, but is still supported for the # foreseable future. Do not rip out the -nest tests before speaking to # someone on the DBIC mailing list or in irc.perl.org#dbix-class # ################# my @tests = ( { func => 'select', args => ['test', '*'], stmt => 'SELECT * FROM test', stmt_q => 'SELECT * FROM `test`', bind => [] }, { func => 'select', args => ['test', [qw(one two three)]], stmt => 'SELECT one, two, three FROM test', stmt_q => 'SELECT `one`, `two`, `three` FROM `test`', bind => [] }, { func => 'select', args => ['test', '*', { a => 0 }, [qw/boom bada bing/]], stmt => 'SELECT * FROM test WHERE ( a = ? ) ORDER BY boom, bada, bing', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? ) ORDER BY `boom`, `bada`, `bing`', bind => [0] }, { func => 'select', args => ['test', '*', [ { a => 5 }, { b => 6 } ]], stmt => 'SELECT * FROM test WHERE ( ( a = ? ) OR ( b = ? ) )', stmt_q => 'SELECT * FROM `test` WHERE ( ( `a` = ? ) OR ( `b` = ? ) )', bind => [5,6] }, { func => 'select', args => ['test', '*', undef, ['id']], stmt => 'SELECT * FROM test ORDER BY id', stmt_q => 'SELECT * FROM `test` ORDER BY `id`', bind => [] }, { func => 'select', args => ['test', '*', { a => 'boom' } , ['id']], stmt => 'SELECT * FROM test WHERE ( a = ? ) ORDER BY id', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? ) ORDER BY `id`', bind => ['boom'] }, { func => 'select', args => ['test', '*', { a => ['boom', 'bang'] }], stmt => 'SELECT * FROM test WHERE ( ( ( a = ? ) OR ( a = ? ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( ( ( `a` = ? ) OR ( `a` = ? ) ) )', bind => ['boom', 'bang'] }, { func => 'select', args => ['test', '*', { a => { '!=', 'boom' } }], stmt => 'SELECT * FROM test WHERE ( a != ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` != ? )', bind => ['boom'] }, { # this is maybe wrong but a single arg doesn't get quoted func => 'select', args => ['test', 'id', { a => { '!=', 'boom' } }], stmt => 'SELECT id FROM test WHERE ( a != ? )', stmt_q => 'SELECT id FROM `test` WHERE ( `a` != ? )', bind => ['boom'] }, { func => 'update', args => ['test', {a => 'boom'}, {a => undef}], stmt => 'UPDATE test SET a = ? WHERE ( a IS NULL )', stmt_q => 'UPDATE `test` SET `a` = ? WHERE ( `a` IS NULL )', bind => ['boom'] }, { func => 'update', args => ['test', {a => undef }, {a => 'boom'}], stmt => 'UPDATE test SET a = ? WHERE ( a = ? )', stmt_q => 'UPDATE `test` SET `a` = ? WHERE ( `a` = ? )', bind => [undef,'boom'] }, { func => 'update', args => ['test', {a => 'boom'}, { a => {'!=', "bang" }} ], stmt => 'UPDATE test SET a = ? WHERE ( a != ? )', stmt_q => 'UPDATE `test` SET `a` = ? WHERE ( `a` != ? )', bind => ['boom', 'bang'] }, { func => 'update', args => ['test', {'a-funny-flavored-candy' => 'yummy', b => 'oops'}, { a42 => "bang" }], stmt => 'UPDATE test SET a-funny-flavored-candy = ?, b = ? WHERE ( a42 = ? )', stmt_q => 'UPDATE `test` SET `a-funny-flavored-candy` = ?, `b` = ? WHERE ( `a42` = ? )', bind => ['yummy', 'oops', 'bang'] }, { func => 'delete', args => ['test', {requestor => undef}], stmt => 'DELETE FROM test WHERE ( requestor IS NULL )', stmt_q => 'DELETE FROM `test` WHERE ( `requestor` IS NULL )', bind => [] }, { func => 'delete', args => [[qw/test1 test2 test3/], { 'test1.field' => \'!= test2.field', user => {'!=','nwiger'} }, ], stmt => 'DELETE FROM test1, test2, test3 WHERE ( test1.field != test2.field AND user != ? )', stmt_q => 'DELETE FROM `test1`, `test2`, `test3` WHERE ( `test1`.`field` != test2.field AND `user` != ? )', # test2.field is a literal value, cannnot be quoted. bind => ['nwiger'] }, { func => 'select', args => [[\'test1', 'test2'], '*', { 'test1.a' => 'boom' } ], stmt => 'SELECT * FROM test1, test2 WHERE ( test1.a = ? )', stmt_q => 'SELECT * FROM test1, `test2` WHERE ( `test1`.`a` = ? )', bind => ['boom'] }, { func => 'insert', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => 5}], stmt => 'INSERT INTO test (a, b, c, d, e) VALUES (?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`, `c`, `d`, `e`) VALUES (?, ?, ?, ?, ?)', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [1..30]], stmt => 'INSERT INTO test VALUES ('.join(', ', ('?')x30).')', stmt_q => 'INSERT INTO `test` VALUES ('.join(', ', ('?')x30).')', bind => [1..30], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/, undef]], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?, ?)', bind => [qw/1 2 3 4 5/, undef], }, { func => 'update', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => 5}], stmt => 'UPDATE test SET a = ?, b = ?, c = ?, d = ?, e = ?', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?, `c` = ?, `d` = ?, `e` = ?', bind => [qw/1 2 3 4 5/], }, { func => 'update', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => 5}, {a => {'in', [1..5]}}], stmt => 'UPDATE test SET a = ?, b = ?, c = ?, d = ?, e = ? WHERE ( a IN ( ?, ?, ?, ?, ? ) )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?, `c` = ?, `d` = ?, `e` = ? WHERE ( `a` IN ( ?, ?, ?, ?, ? ) )', bind => [qw/1 2 3 4 5 1 2 3 4 5/], }, { func => 'update', args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )', bind => [qw(1 02/02/02 1 2)], }, { func => 'insert', args => ['test.table', {high_limit => \'max(all_limits)', low_limit => 4} ], stmt => 'INSERT INTO test.table (high_limit, low_limit) VALUES (max(all_limits), ?)', stmt_q => 'INSERT INTO `test`.`table` (`high_limit`, `low_limit`) VALUES (max(all_limits), ?)', bind => ['4'], }, { func => 'insert', args => ['test.table', [ \'max(all_limits)', 4 ] ], stmt => 'INSERT INTO test.table VALUES (max(all_limits), ?)', stmt_q => 'INSERT INTO `test`.`table` VALUES (max(all_limits), ?)', bind => ['4'], }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test.table', {one => 2, three => 4, five => 6} ], stmt => 'INSERT INTO test.table (five, one, three) VALUES (?, ?, ?)', stmt_q => 'INSERT INTO `test`.`table` (`five`, `one`, `three`) VALUES (?, ?, ?)', bind => [['five', 6], ['one', 2], ['three', 4]], # alpha order, man... }, { func => 'select', new => {bindtype => 'columns', case => 'lower'}, args => ['test.table', [qw/one two three/], {one => 2, three => 4, five => 6} ], stmt => 'select one, two, three from test.table where ( five = ? and one = ? and three = ? )', stmt_q => 'select `one`, `two`, `three` from `test`.`table` where ( `five` = ? and `one` = ? and `three` = ? )', bind => [['five', 6], ['one', 2], ['three', 4]], # alpha order, man... }, { func => 'update', new => {bindtype => 'columns', cmp => 'like'}, args => ['testin.table2', {One => 22, Three => 44, FIVE => 66}, {Beer => 'is', Yummy => '%YES%', IT => ['IS','REALLY','GOOD']}], stmt => 'UPDATE testin.table2 SET FIVE = ?, One = ?, Three = ? WHERE ' . '( Beer LIKE ? AND ( ( IT LIKE ? ) OR ( IT LIKE ? ) OR ( IT LIKE ? ) ) AND Yummy LIKE ? )', stmt_q => 'UPDATE `testin`.`table2` SET `FIVE` = ?, `One` = ?, `Three` = ? WHERE ' . '( `Beer` LIKE ? AND ( ( `IT` LIKE ? ) OR ( `IT` LIKE ? ) OR ( `IT` LIKE ? ) ) AND `Yummy` LIKE ? )', bind => [['FIVE', 66], ['One', 22], ['Three', 44], ['Beer','is'], ['IT','IS'], ['IT','REALLY'], ['IT','GOOD'], ['Yummy','%YES%']], }, { func => 'select', args => ['test', '*', {priority => [ -and => {'!=', 2}, { -not_like => '3%'} ]}], stmt => 'SELECT * FROM test WHERE ( ( ( priority != ? ) AND ( priority NOT LIKE ? ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( ( ( `priority` != ? ) AND ( `priority` NOT LIKE ? ) ) )', bind => [qw(2 3%)], }, { func => 'select', args => ['Yo Momma', '*', { user => 'nwiger', -nest => [ workhrs => {'>', 20}, geo => 'ASIA' ] }], stmt => 'SELECT * FROM Yo Momma WHERE ( ( ( workhrs > ? ) OR ( geo = ? ) ) AND user = ? )', stmt_q => 'SELECT * FROM `Yo Momma` WHERE ( ( ( `workhrs` > ? ) OR ( `geo` = ? ) ) AND `user` = ? )', bind => [qw(20 ASIA nwiger)], }, { func => 'update', args => ['taco_punches', { one => 2, three => 4 }, { bland => [ -and => {'!=', 'yes'}, {'!=', 'YES'} ], tasty => { '!=', [qw(yes YES)] }, -nest => [ face => [ -or => {'=', 'mr.happy'}, {'=', undef} ] ] }, ], warns => qr/\QA multi-element arrayref as an argument to the inequality op '!=' is technically equivalent to an always-true 1=1/, stmt => 'UPDATE taco_punches SET one = ?, three = ? WHERE ( ( ( ( ( face = ? ) OR ( face IS NULL ) ) ) )' . ' AND ( ( bland != ? ) AND ( bland != ? ) ) AND ( ( tasty != ? ) OR ( tasty != ? ) ) )', stmt_q => 'UPDATE `taco_punches` SET `one` = ?, `three` = ? WHERE ( ( ( ( ( `face` = ? ) OR ( `face` IS NULL ) ) ) )' . ' AND ( ( `bland` != ? ) AND ( `bland` != ? ) ) AND ( ( `tasty` != ? ) OR ( `tasty` != ? ) ) )', bind => [qw(2 4 mr.happy yes YES yes YES)], }, { func => 'select', args => ['jeff', '*', { name => {'ilike', '%smith%', -not_in => ['Nate','Jim','Bob','Sally']}, -nest => [ -or => [ -and => [age => { -between => [20,30] }, age => {'!=', 25} ], yob => {'<', 1976} ] ] } ], stmt => 'SELECT * FROM jeff WHERE ( ( ( ( ( ( ( age BETWEEN ? AND ? ) AND ( age != ? ) ) ) OR ( yob < ? ) ) ) )' . ' AND name NOT IN ( ?, ?, ?, ? ) AND name ILIKE ? )', stmt_q => 'SELECT * FROM `jeff` WHERE ( ( ( ( ( ( ( `age` BETWEEN ? AND ? ) AND ( `age` != ? ) ) ) OR ( `yob` < ? ) ) ) )' . ' AND `name` NOT IN ( ?, ?, ?, ? ) AND `name` ILIKE ? )', bind => [qw(20 30 25 1976 Nate Jim Bob Sally %smith%)] }, { func => 'update', args => ['fhole', {fpoles => 4}, [ { race => [qw/-or black white asian /] }, { -nest => { firsttime => [-or => {'=','yes'}, undef] } }, { -and => [ { firstname => {-not_like => 'candace'} }, { lastname => {-in => [qw(jugs canyon towers)] } } ] }, ] ], stmt => 'UPDATE fhole SET fpoles = ? WHERE ( ( ( ( ( ( ( race = ? ) OR ( race = ? ) OR ( race = ? ) ) ) ) ) )' . ' OR ( ( ( ( firsttime = ? ) OR ( firsttime IS NULL ) ) ) ) OR ( ( ( firstname NOT LIKE ? ) ) AND ( lastname IN (?, ?, ?) ) ) )', stmt_q => 'UPDATE `fhole` SET `fpoles` = ? WHERE ( ( ( ( ( ( ( `race` = ? ) OR ( `race` = ? ) OR ( `race` = ? ) ) ) ) ) )' . ' OR ( ( ( ( `firsttime` = ? ) OR ( `firsttime` IS NULL ) ) ) ) OR ( ( ( `firstname` NOT LIKE ? ) ) AND ( `lastname` IN( ?, ?, ? )) ) )', bind => [qw(4 black white asian yes candace jugs canyon towers)] }, { func => 'insert', args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}], stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', bind => [qw(1 02/02/02)], }, { func => 'select', args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}], stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, bind => ['02/02/02'], }, { func => 'insert', new => {array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'INSERT INTO test (a, b) VALUES (?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, ?)', bind => [1, [1, 1, 2, 3, 5, 8]], }, { func => 'insert', new => {bindtype => 'columns', array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'INSERT INTO test (a, b) VALUES (?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, ?)', bind => [[a => 1], [b => [1, 1, 2, 3, 5, 8]]], }, { func => 'update', new => {array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'UPDATE test SET a = ?, b = ?', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?', bind => [1, [1, 1, 2, 3, 5, 8]], }, { func => 'update', new => {bindtype => 'columns', array_datatypes => 1}, args => ['test', {a => 1, b => [1, 1, 2, 3, 5, 8]}], stmt => 'UPDATE test SET a = ?, b = ?', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = ?', bind => [[a => 1], [b => [1, 1, 2, 3, 5, 8]]], }, { func => 'select', args => ['test', '*', { a => {'>', \'1 + 1'}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a > 1 + 1 AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` > 1 + 1 AND `b` = ? )', bind => [8], }, { func => 'select', args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )', bind => ['02/02/02', 8], }, { #TODO in SQLA >= 2.0 it will die instead (we kept this just because old SQLA passed it through) func => 'insert', args => ['test', {a => 1, b => 2, c => 3, d => 4, e => { answer => 42 }}], stmt => 'INSERT INTO test (a, b, c, d, e) VALUES (?, ?, ?, ?, ?)', stmt_q => 'INSERT INTO `test` (`a`, `b`, `c`, `d`, `e`) VALUES (?, ?, ?, ?, ?)', bind => [qw/1 2 3 4/, { answer => 42}], warns => qr/HASH ref as bind value in insert is not supported/i, }, { func => 'update', args => ['test', {a => 1, b => \["42"]}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = 42 WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = 42 WHERE ( `a` BETWEEN ? AND ? )', bind => [qw(1 1 2)], }, { func => 'insert', args => ['test', {a => 1, b => \["42"]}], stmt => 'INSERT INTO test (a, b) VALUES (?, 42)', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, 42)', bind => [qw(1)], }, { func => 'select', args => ['test', '*', { a => \["= 42"], b => 1}], stmt => q{SELECT * FROM test WHERE ( a = 42 ) AND (b = ? )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = 42 ) AND ( `b` = ? )}, bind => [qw(1)], }, { func => 'select', args => ['test', '*', { a => {'<' => \["42"]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < 42 AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < 42 AND `b` = ? )', bind => [qw(8)], }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}], stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', bind => [[a => '1'], [dummy => '02/02/02']], }, { func => 'update', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}, {a => {'between', [1,2]}}], stmt => 'UPDATE test SET a = ?, b = to_date(?, \'MM/DD/YY\') WHERE ( a BETWEEN ? AND ? )', stmt_q => 'UPDATE `test` SET `a` = ?, `b` = to_date(?, \'MM/DD/YY\') WHERE ( `a` BETWEEN ? AND ? )', bind => [[a => '1'], [dummy => '02/02/02'], [a => '1'], [a => '2']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}], stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, bind => [[dummy => '02/02/02']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", [dummy => '02/02/02']]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )', bind => [[dummy => '02/02/02'], [b => 8]], }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'update', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, {a => {'between', [1,2]}}], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", '02/02/02']}], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", '02/02/02']}, b => 8 }], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'select', args => ['test', '*', { foo => { '>=' => [] }} ], throws => qr/\Qoperator '>=' applied on an empty array (field 'foo')/, }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {-in => \["(SELECT d FROM to_date(?, 'MM/DD/YY') AS d)", [dummy => '02/02/02']]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a IN (SELECT d FROM to_date(?, \'MM/DD/YY\') AS d) AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IN (SELECT d FROM to_date(?, \'MM/DD/YY\') AS d) AND `b` = ? )', bind => [[dummy => '02/02/02'], [b => 8]], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {-in => \["(SELECT d FROM to_date(?, 'MM/DD/YY') AS d)", '02/02/02']}, b => 8 }], throws => qr/bindtype 'columns' selected, you need to pass: \[column_name => bind_value\]/, }, { func => 'insert', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}], stmt => 'INSERT INTO test (a, b) VALUES (?, to_date(?, \'MM/DD/YY\'))', stmt_q => 'INSERT INTO `test` (`a`, `b`) VALUES (?, to_date(?, \'MM/DD/YY\'))', bind => [[a => '1'], [{dummy => 1} => '02/02/02']], }, { func => 'update', new => {bindtype => 'columns'}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']], c => { -lower => 'foo' }}, {a => {'between', [1,2]}}], stmt => "UPDATE test SET a = ?, b = to_date(?, 'MM/DD/YY'), c = LOWER(?) WHERE ( a BETWEEN ? AND ? )", stmt_q => "UPDATE `test` SET `a` = ?, `b` = to_date(?, 'MM/DD/YY'), `c` = LOWER(?) WHERE ( `a` BETWEEN ? AND ? )", bind => [[a => '1'], [{dummy => 1} => '02/02/02'], [c => 'foo'], [a => '1'], [a => '2']], }, { func => 'update', new => {bindtype => 'columns',restore_old_unop_handling => 1}, args => ['test', {a => 1, b => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']], c => { -lower => 'foo' }}, {a => {'between', [1,2]}}], stmt => "UPDATE test SET a = ?, b = to_date(?, 'MM/DD/YY'), c = LOWER ? WHERE ( a BETWEEN ? AND ? )", stmt_q => "UPDATE `test` SET `a` = ?, `b` = to_date(?, 'MM/DD/YY'), `c` = LOWER ? WHERE ( `a` BETWEEN ? AND ? )", bind => [[a => '1'], [{dummy => 1} => '02/02/02'], [c => 'foo'], [a => '1'], [a => '2']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => \["= to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}], stmt => q{SELECT * FROM test WHERE ( a = to_date(?, 'MM/DD/YY') )}, stmt_q => q{SELECT * FROM `test` WHERE ( `a` = to_date(?, 'MM/DD/YY') )}, bind => [[{dummy => 1} => '02/02/02']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { a => {'<' => \["to_date(?, 'MM/DD/YY')", [{dummy => 1} => '02/02/02']]}, b => 8 }], stmt => 'SELECT * FROM test WHERE ( a < to_date(?, \'MM/DD/YY\') AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` < to_date(?, \'MM/DD/YY\') AND `b` = ? )', bind => [[{dummy => 1} => '02/02/02'], [b => 8]], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', { -or => [ -and => [ a => 'a', b => 'b' ], -and => [ c => 'c', d => 'd' ] ] }], stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? ) OR ( c = ? AND d = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? AND `b` = ? ) OR ( `c` = ? AND `d` = ? )', bind => [[a => 'a'], [b => 'b'], [ c => 'c'],[ d => 'd']], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', [ { a => 1, b => 1}, [ a => 2, b => 2] ] ], stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? ) OR ( a = ? OR b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? AND `b` = ? ) OR ( `a` = ? OR `b` = ? )', bind => [[a => 1], [b => 1], [ a => 2], [ b => 2]], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', [ [ a => 1, b => 1], { a => 2, b => 2 } ] ], stmt => 'SELECT * FROM test WHERE ( a = ? OR b = ? ) OR ( a = ? AND b = ? )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` = ? OR `b` = ? ) OR ( `a` = ? AND `b` = ? )', bind => [[a => 1], [b => 1], [ a => 2], [ b => 2]], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => 'id' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id`', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => 'id, foo, bar' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id, foo, bar`', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => [qw(id foo bar) ] }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING `id`, `foo`, `bar`', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => \'id, foo, bar' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id, foo, bar', bind => [qw/1 2 3 4 5/], }, { func => 'insert', args => ['test', [qw/1 2 3 4 5/], { returning => \'id' }], stmt => 'INSERT INTO test VALUES (?, ?, ?, ?, ?) RETURNING id', stmt_q => 'INSERT INTO `test` VALUES (?, ?, ?, ?, ?) RETURNING id', bind => [qw/1 2 3 4 5/], }, { func => 'select', new => {bindtype => 'columns'}, args => ['test', '*', [ Y => { '=' => { -max => { -LENGTH => { -min => 'x' } } } } ] ], stmt => 'SELECT * FROM test WHERE ( Y = ( MAX( LENGTH( MIN(?) ) ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( `Y` = ( MAX( LENGTH( MIN(?) ) ) ) )', bind => [[Y => 'x']], }, { func => 'select', new => {bindtype => 'columns',restore_old_unop_handling => 1}, args => ['test', '*', [ Y => { '=' => { -max => { -LENGTH => { -min => 'x' } } } } ] ], stmt => 'SELECT * FROM test WHERE ( Y = ( MAX( LENGTH( MIN ? ) ) ) )', stmt_q => 'SELECT * FROM `test` WHERE ( `Y` = ( MAX( LENGTH( MIN ? ) ) ) )', bind => [[Y => 'x']], }, { func => 'select', args => ['test', '*', { a => { '=' => undef }, b => { -is => undef }, c => { -like => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NULL AND b IS NULL AND c IS NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NULL AND `b` IS NULL AND `c` IS NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'LIKE' is deprecated/, }, { func => 'select', args => ['test', '*', { a => { '!=' => undef }, b => { -is_not => undef }, c => { -not_like => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NOT NULL AND b IS NOT NULL AND c IS NOT NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NOT NULL AND `b` IS NOT NULL AND `c` IS NOT NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'NOT LIKE' is deprecated/, }, { func => 'select', args => ['test', '*', { a => { IS => undef }, b => { LIKE => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NULL AND b IS NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NULL AND `b` IS NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'LIKE' is deprecated/, }, { func => 'select', args => ['test', '*', { a => { 'IS NOT' => undef }, b => { 'NOT LIKE' => undef } }], stmt => 'SELECT * FROM test WHERE ( a IS NOT NULL AND b IS NOT NULL )', stmt_q => 'SELECT * FROM `test` WHERE ( `a` IS NOT NULL AND `b` IS NOT NULL )', bind => [], warns => qr/\QSupplying an undefined argument to 'NOT LIKE' is deprecated/, }, { func => 'select', args => ['`test``table`', ['`test``column`']], stmt => 'SELECT `test``column` FROM `test``table`', stmt_q => 'SELECT ```test````column``` FROM ```test````table```', bind => [], }, { func => 'select', args => ['`test\\`table`', ['`test`\\column`']], stmt => 'SELECT `test`\column` FROM `test\`table`', stmt_q => 'SELECT `\`test\`\\\\column\`` FROM `\`test\\\\\`table\``', esc => '\\', bind => [], }, { func => 'update', args => ['mytable', { foo => 42 }, { baz => 32 }, { returning => 'id' }], stmt => 'UPDATE mytable SET foo = ? WHERE baz = ? RETURNING id', stmt_q => 'UPDATE `mytable` SET `foo` = ? WHERE `baz` = ? RETURNING `id`', bind => [42, 32], }, { func => 'update', args => ['mytable', { foo => 42 }, { baz => 32 }, { returning => \'*' }], stmt => 'UPDATE mytable SET foo = ? WHERE baz = ? RETURNING *', stmt_q => 'UPDATE `mytable` SET `foo` = ? WHERE `baz` = ? RETURNING *', bind => [42, 32], }, { func => 'update', args => ['mytable', { foo => 42 }, { baz => 32 }, { returning => ['id','created_at'] }], stmt => 'UPDATE mytable SET foo = ? WHERE baz = ? RETURNING id, created_at', stmt_q => 'UPDATE `mytable` SET `foo` = ? WHERE `baz` = ? RETURNING `id`, `created_at`', bind => [42, 32], }, { func => 'delete', args => ['test', {requestor => undef}, {returning => 'id'}], stmt => 'DELETE FROM test WHERE ( requestor IS NULL ) RETURNING id', stmt_q => 'DELETE FROM `test` WHERE ( `requestor` IS NULL ) RETURNING `id`', bind => [] }, { func => 'delete', args => ['test', {requestor => undef}, {returning => \'*'}], stmt => 'DELETE FROM test WHERE ( requestor IS NULL ) RETURNING *', stmt_q => 'DELETE FROM `test` WHERE ( `requestor` IS NULL ) RETURNING *', bind => [] }, { func => 'delete', args => ['test', {requestor => undef}, {returning => ['id', 'created_at']}], stmt => 'DELETE FROM test WHERE ( requestor IS NULL ) RETURNING id, created_at', stmt_q => 'DELETE FROM `test` WHERE ( `requestor` IS NULL ) RETURNING `id`, `created_at`', bind => [] }, { func => 'delete', args => ['test', \[ undef ] ], stmt => 'DELETE FROM test', stmt_q => 'DELETE FROM `test`', bind => [] }, ); # check is( not) => undef for my $op (qw(not is is_not), 'is not') { (my $sop = uc $op) =~ s/_/ /gi; $sop = 'IS NOT' if $sop eq 'NOT'; for my $uc (0, 1) { for my $prefix ('', '-') { push @tests, { func => 'where', args => [{ a => { ($prefix . ($uc ? uc $op : lc $op) ) => undef } }], stmt => "WHERE a $sop NULL", stmt_q => "WHERE `a` $sop NULL", bind => [], }; } } } # check single-element inequality ops for no warnings for my $op (qw(!= <>)) { for my $val (undef, 42) { push @tests, { func => 'where', args => [ { x => { "$_$op" => [ $val ] } } ], stmt => "WHERE x " . ($val ? "$op ?" : 'IS NOT NULL'), stmt_q => "WHERE `x` " . ($val ? "$op ?" : 'IS NOT NULL'), bind => [ $val || () ], } for ('', '-'); # with and without - } } # check single-element not-like ops for no warnings, and NULL exception # (the last two "is not X" are a weird syntax, but mebbe a dialect...) for my $op (qw(not_like not_rlike), 'not like', 'not rlike', 'is not like','is not rlike') { (my $sop = uc $op) =~ s/_/ /gi; for my $val (undef, 42) { push @tests, { func => 'where', args => [ { x => { "$_$op" => [ $val ] } } ], $val ? ( stmt => "WHERE x $sop ?", stmt_q => "WHERE `x` $sop ?", bind => [ $val ], ) : ( stmt => "WHERE x IS NOT NULL", stmt_q => "WHERE `x` IS NOT NULL", bind => [], warns => qr/\QSupplying an undefined argument to '$sop' is deprecated/, ), } for ('', '-'); # with and without - } } # check all multi-element inequality/not-like ops for warnings for my $op (qw(!= <> not_like not_rlike), 'not like', 'not rlike', 'is not like','is not rlike') { (my $sop = uc $op) =~ s/_/ /gi; push @tests, { func => 'where', args => [ { x => { "$_$op" => [ 42, 69 ] } } ], stmt => "WHERE x $sop ? OR x $sop ?", stmt_q => "WHERE `x` $sop ? OR `x` $sop ?", bind => [ 42, 69 ], warns => qr/\QA multi-element arrayref as an argument to the inequality op '$sop' is technically equivalent to an always-true 1=1/, } for ('', '-'); # with and without - } # check all like/not-like ops for empty-arrayref warnings for my $op (qw(like rlike not_like not_rlike), 'not like', 'not rlike', 'is like', 'is not like', 'is rlike', 'is not rlike') { (my $sop = uc $op) =~ s/_/ /gi; push @tests, { func => 'where', args => [ { x => { "$_$op" => [] } } ], stmt => ( $sop =~ /NOT/ ? "WHERE 1=1" : "WHERE 0=1" ), stmt_q => ( $sop =~ /NOT/ ? "WHERE 1=1" : "WHERE 0=1" ), bind => [], warns => qr/\QSupplying an empty arrayref to '$sop' is deprecated/, } for ('', '-'); # with and without - } # check emtpty-lhs in a hashpair and arraypair for my $lhs (undef, '') { no warnings 'uninitialized'; ## ## hard exceptions - never worked for my $where_arg ( ( map { $_, { @$_ } } [ $lhs => "foo" ], [ $lhs => { "=" => "bozz" } ], [ $lhs => { "=" => \"bozz" } ], [ $lhs => { -max => \"bizz" } ], ), [ -and => { $lhs => "baz" }, bizz => "buzz" ], [ foo => "bar", { $lhs => "baz" }, bizz => "buzz" ], { foo => "bar", -or => { $lhs => "baz" } }, # the hashref forms of these work sadly - check for warnings below { foo => "bar", -and => [ $lhs => \"baz" ], bizz => "buzz" }, { foo => "bar", -or => [ $lhs => \"baz" ], bizz => "buzz" }, [ foo => "bar", [ $lhs => \"baz" ], bizz => "buzz" ], [ foo => "bar", $lhs => \"baz", bizz => "buzz" ], [ foo => "bar", $lhs => \["baz"], bizz => "buzz" ], [ $lhs => \"baz" ], [ $lhs => \["baz"] ], ) { push @tests, { func => 'where', args => [ $where_arg ], throws => qr/\QSupplying an empty left hand side argument is not supported/, }; } ## ## deprecations - sorta worked, likely abused by folks for my $where_arg ( # the arrayref forms of this never worked and throw above { foo => "bar", -or => { $lhs => \"baz" }, bizz => "buzz" }, { foo => "bar", -and => { $lhs => \"baz" }, bizz => "buzz" }, { foo => "bar", $lhs => \"baz", bizz => "buzz" }, { foo => "bar", $lhs => \["baz"], bizz => "buzz" }, ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE baz AND bizz = ? AND foo = ?', stmt_q => 'WHERE baz AND `bizz` = ? AND `foo` = ?', bind => [qw( buzz bar )], warns => qr/\QHash-pairs consisting of an empty string with a literal are deprecated/, }; } for my $where_arg ( { $lhs => \"baz" }, { $lhs => \["baz"] }, ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE baz', stmt_q => 'WHERE baz', bind => [], warns => qr/\QHash-pairs consisting of an empty string with a literal are deprecated/, } } } # check false lhs, silly but possible { for my $where_arg ( [ { 0 => "baz" }, bizz => "buzz", foo => "bar" ], [ -or => { foo => "bar", -or => { 0 => "baz" }, bizz => "buzz" } ], ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE 0 = ? OR bizz = ? OR foo = ?', stmt_q => 'WHERE `0` = ? OR `bizz` = ? OR `foo` = ?', bind => [qw( baz buzz bar )], }; } for my $where_arg ( { foo => "bar", -and => [ 0 => \"= baz" ], bizz => "buzz" }, { foo => "bar", -or => [ 0 => \"= baz" ], bizz => "buzz" }, { foo => "bar", -and => { 0 => \"= baz" }, bizz => "buzz" }, { foo => "bar", -or => { 0 => \"= baz" }, bizz => "buzz" }, { foo => "bar", 0 => \"= baz", bizz => "buzz" }, { foo => "bar", 0 => \["= baz"], bizz => "buzz" }, ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE 0 = baz AND bizz = ? AND foo = ?', stmt_q => 'WHERE `0` = baz AND `bizz` = ? AND `foo` = ?', bind => [qw( buzz bar )], }; } for my $where_arg ( [ -and => [ 0 => \"= baz" ], bizz => "buzz", foo => "bar" ], [ -or => [ 0 => \"= baz" ], bizz => "buzz", foo => "bar" ], [ 0 => \"= baz", bizz => "buzz", foo => "bar" ], [ 0 => \["= baz"], bizz => "buzz", foo => "bar" ], ) { push @tests, { func => 'where', args => [ $where_arg ], stmt => 'WHERE 0 = baz OR bizz = ? OR foo = ?', stmt_q => 'WHERE `0` = baz OR `bizz` = ? OR `foo` = ?', bind => [qw( buzz bar )], }; } } for my $t (@tests) { my $new = $t->{new} || {}; for my $quoted (0, 1) { my $maker = SQL::Abstract->new( %$new, ($quoted ? ( quote_char => '`', name_sep => '.', ( $t->{esc} ? ( escape_char => $t->{esc}, ) : ()) ) : ()) ); my($stmt, @bind); my $cref = sub { my $op = $t->{func}; ($stmt, @bind) = $maker->$op(@{ $t->{args} }); }; if (my $e = $t->{throws}) { throws_ok( sub { $cref->() }, $e, ) || diag dumper({ args => $t->{args}, result => $stmt }); } else { lives_ok(sub { alarm(1); local $SIG{ALRM} = sub { no warnings 'redefine'; my $orig = Carp->can('caller_info'); local *Carp::caller_info = sub { return if $_[0] > 20; &$orig }; print STDERR "ARGH ($SQL::Abstract::Default_Scalar_To): ".Carp::longmess(); die "timed out"; }; warnings_like( sub { $cref->() }, $t->{warns} || [], ) || diag dumper({ args => $t->{args}, result => $stmt }); }) || diag dumper({ args => $t->{args}, result => $stmt, threw => $@ }); is_same_sql_bind( $stmt, \@bind, $quoted ? $t->{stmt_q}: $t->{stmt}, $t->{bind} ) || diag dumper({ args => $t->{args}, result => $stmt });; } } } done_testing; SQL-Abstract-2.000001/t/11parser.t0000644000000000000000000006115213340604277016233 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Warn; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new; is_deeply($sqlat->parse("SELECT a, b.*, * FROM foo WHERE foo.a =1 and foo.b LIKE 'station'"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "a" ] ], [ "-LITERAL", [ "b.*" ] ], [ "-LITERAL", [ "*" ] ] ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foo" ] ] ] ], [ "WHERE", [ [ "AND", [ [ "=", [ [ "-LITERAL", [ "foo.a" ] ], [ "-LITERAL", [ 1 ] ] ] ], [ "LIKE", [ [ "-LITERAL", [ "foo.b" ] ], [ "-LITERAL", [ "'station'" ] ] ] ] ] ] ] ] ], 'simple statement parsed correctly'); is_deeply($sqlat->parse( "SELECT * FROM (SELECT * FROM foobar) foo WHERE foo.a =1 and foo.b LIKE 'station'"), [ [ "SELECT", [ [ "-LITERAL", [ "*" ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-PAREN", [ [ "SELECT", [ [ "-LITERAL", [ "*" ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foobar" ] ] ] ] ] ], [ "-LITERAL", [ "foo" ] ] ] ] ] ], [ "WHERE", [ [ "AND", [ [ "=", [ [ "-LITERAL", [ "foo.a" ] ], [ "-LITERAL", [ 1 ] ] ] ], [ "LIKE", [ [ "-LITERAL", [ "foo.b" ] ], [ "-LITERAL", [ "'station'" ] ] ] ] ] ] ] ] ], 'subquery statement parsed correctly'); is_deeply($sqlat->parse( "SELECT [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype] FROM [users_roles] [me] JOIN [roles] [role] ON [role].[id] = [me].[role_id] JOIN [roles_permissions] [role_permissions] ON [role_permissions].[role_id] = [role].[id] JOIN [permissions] [permission] ON [permission].[id] = [role_permissions].[permission_id] JOIN [permissionscreens] [permission_screens] ON [permission_screens].[permission_id] = [permission].[id] JOIN [screens] [screen] ON [screen].[id] = [permission_screens].[screen_id] WHERE ( [me].[user_id] = ? ) GROUP BY [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype]"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "[screen].[id]" ] ], [ "-LITERAL", [ "[screen].[name]" ] ], [ "-LITERAL", [ "[screen].[section_id]" ] ], [ "-LITERAL", [ "[screen].[xtype]" ] ] ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-LITERAL", [ "[users_roles]" ] ], [ "-LITERAL", [ "[me]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[roles]" ] ], [ "-LITERAL", [ "[role]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[role].[id]" ] ], [ "-LITERAL", [ "[me].[role_id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[roles_permissions]" ] ], [ "-LITERAL", [ "[role_permissions]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[role_permissions].[role_id]" ] ], [ "-LITERAL", [ "[role].[id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[permissions]" ] ], [ "-LITERAL", [ "[permission]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[permission].[id]" ] ], [ "-LITERAL", [ "[role_permissions].[permission_id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[permissionscreens]" ] ], [ "-LITERAL", [ "[permission_screens]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[permission_screens].[permission_id]" ] ], [ "-LITERAL", [ "[permission].[id]" ] ] ] ] ] ], [ "JOIN", [ [ "-MISC", [ [ "-LITERAL", [ "[screens]" ] ], [ "-LITERAL", [ "[screen]" ] ] ] ] ] ], [ "ON", [ [ "=", [ [ "-LITERAL", [ "[screen].[id]" ] ], [ "-LITERAL", [ "[permission_screens].[screen_id]" ] ] ] ] ] ], [ "WHERE", [ [ "-PAREN", [ [ "=", [ [ "-LITERAL", [ "[me].[user_id]" ] ], [ "-PLACEHOLDER", [ "?" ] ] ] ] ] ] ] ], [ "GROUP BY", [ [ "-LIST", [ [ "-LITERAL", [ "[screen].[id]" ] ], [ "-LITERAL", [ "[screen].[name]" ] ], [ "-LITERAL", [ "[screen].[section_id]" ] ], [ "-LITERAL", [ "[screen].[xtype]" ] ] ] ] ] ] ], 'real life statement 1 parsed correctly'); is_deeply($sqlat->parse("CASE WHEN FOO() > BAR()"), [ [ "-MISC", [ [ "-LITERAL", [ "CASE" ] ], [ "-LITERAL", [ "WHEN" ] ] ] ], [ ">", [ [ "FOO", [ [ "-PAREN", [] ] ] ], [ "BAR", [ [ "-PAREN", [] ] ] ] ] ] ]); is_deeply($sqlat->parse("SELECT [me].[id], ROW_NUMBER ( ) OVER (ORDER BY (SELECT 1)) AS [rno__row__index] FROM bar"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "[me].[id]" ] ], [ "AS", [ [ "ROW_NUMBER() OVER", [ [ "-PAREN", [ [ "ORDER BY", [ [ "-PAREN", [ [ "SELECT", [ [ "-LITERAL", [ 1 ] ] ] ] ] ] ] ] ] ] ] ], [ "-LITERAL", [ "[rno__row__index]" ] ] ] ] ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "bar" ] ] ] ] ]); is_deeply($sqlat->parse("SELECT x, y FROM foo WHERE x IN (?, ?, ?, ?)"), [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "y" ] ] ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foo" ] ] ] ], [ "WHERE", [ [ "IN", [ [ "-LITERAL", [ "x" ] ], [ "-PAREN", [ [ "-LIST", [ [ "-PLACEHOLDER", [ "?" ] ], [ "-PLACEHOLDER", [ "?" ] ], [ "-PLACEHOLDER", [ "?" ] ], [ "-PLACEHOLDER", [ "?" ] ] ] ] ] ] ] ] ] ] ], 'Lists parsed correctly'); is_deeply($sqlat->parse('SELECT foo FROM bar ORDER BY x + ? DESC, oomph, y - ? DESC, unf, baz.g / ? ASC, buzz * 0 DESC, foo LIKE ? DESC, ickk ASC'), [ [ "SELECT", [ [ "-LITERAL", [ "foo" ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "bar" ] ] ] ], [ "ORDER BY", [ [ "-LIST", [ [ "-DESC", [ [ "-MISC", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "+" ] ], [ "-PLACEHOLDER", [ "?" ] ] ] ], ] ], [ "-LITERAL", [ "oomph" ] ], [ "-DESC", [ [ "-MISC", [ [ "-LITERAL", [ "y" ] ], [ "-LITERAL", [ "-" ] ], [ "-PLACEHOLDER", [ "?" ] ], ] ], ] ], [ "-LITERAL", [ "unf" ] ], [ "-ASC", [ [ "-MISC", [ [ "-LITERAL", [ "baz.g" ] ], [ "-LITERAL", [ "/" ] ], [ "-PLACEHOLDER", [ "?" ] ], ] ], ] ], [ "-DESC", [ [ "-MISC", [ [ "-LITERAL", [ "buzz" ] ], [ "-LITERAL", [ "*" ] ], [ "-LITERAL", [ 0 ] ] ] ] ] ], [ "-DESC", [ [ "LIKE", [ [ "-LITERAL", [ "foo" ] ], [ "-PLACEHOLDER", [ "?" ] ], ], ], ] ], [ "-ASC", [ [ "-LITERAL", [ "ickk" ] ] ] ] ] ] ] ] ], 'Crazy ORDER BY parsed correctly'); is_deeply( $sqlat->parse("META SELECT * * FROM (SELECT *, FROM foobar baz buzz) foo bar WHERE NOT NOT NOT EXISTS (SELECT 'cr,ap') AND foo.a = ? STUFF moar(stuff) and not (foo.b LIKE 'station') and x = y and z in ((1, 2)) and a = b and GROUP BY , ORDER BY x x1 x2 y asc, max(y) desc x z desc"), [ [ "-LITERAL", [ "META" ] ], [ "SELECT", [ [ "-MISC", [ [ "-LITERAL", [ "*" ] ], [ "-LITERAL", [ "*" ] ] ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-PAREN", [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "*" ] ], [] ] ] ] ], [ "FROM", [ [ "-MISC", [ [ "-LITERAL", [ "foobar" ] ], [ "-LITERAL", [ "baz" ] ], [ "-LITERAL", [ "buzz" ] ] ] ] ] ] ] ], [ "-LITERAL", [ "foo" ] ], [ "-LITERAL", [ "bar" ] ] ] ] ] ], [ "WHERE", [ [ "AND", [ [ "NOT", [] ], [ "NOT", [] ], [ "NOT EXISTS", [ [ "-PAREN", [ [ "SELECT", [ [ "-LIST", [ [ "-LITERAL", [ "'cr" ] ], [ "-LITERAL", [ "ap'" ] ] ] ] ] ] ] ] ] ], [ "-MISC", [ [ "=", [ [ "-LITERAL", [ "foo.a" ] ], [ "-PLACEHOLDER", [ "?" ] ], ], ], [ "-LITERAL", [ "STUFF" ] ], ], ], [ 'moar', [ [ '-PAREN', [ [ '-LITERAL', [ 'stuff' ] ] ] ] ] ], [ "NOT", [ [ "-PAREN", [ [ "LIKE", [ [ "-LITERAL", [ "foo.b" ] ], [ "-LITERAL", [ "'station'" ] ] ] ] ] ] ] ], [ "=", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "y" ] ] ] ], [ 'IN', [ [ '-LITERAL', [ 'z', ], ], [ '-PAREN', [ [ '-PAREN', [ [ '-LIST', [ [ '-LITERAL', [ '1' ] ], [ '-LITERAL', [ '2' ] ], ], ], ], ], ], ], ], ], [ "=", [ [ "-LITERAL", [ "a" ] ], [ "-LITERAL", [ "b" ] ] ] ] ] ] ] ], [ "GROUP BY", [ [ "-LIST", [ [], [] ] ] ] ], [ "ORDER BY", [ [ "-LIST", [ [ "-ASC", [ [ "-MISC", [ [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "x1" ] ], [ "-LITERAL", [ "x2" ] ], [ "-LITERAL", [ "y" ] ] ] ], ], ], [ "-DESC", [ [ "-MISC", [ [ "-DESC", [ [ "max", [ [ "-PAREN", [ [ "-LITERAL", [ "y" ] ] ] ] ], ] ] ], [ "-LITERAL", [ "x" ] ], [ "-LITERAL", [ "z" ] ] ] ] ] ] ] ] ] ] ], 'Deliberately malformed SQL parsed "correctly"'); # test for recursion warnings on huge selectors my @lst = ('AA' .. 'zz'); #@lst = ('AAA' .. 'zzz'); # if you really want to wait a while warnings_are { my $sql = sprintf 'SELECT %s FROM foo', join (', ', (map { qq|( "$_" )| } @lst), (map { qq|"$_"| } @lst), (map { qq|"$_", ( "$_" )| } @lst) ); my $tree = $sqlat->parse($sql); is_deeply( $tree, [ [ "SELECT", [ [ "-LIST", [ (map { [ -PAREN => [ [ -LITERAL => [ qq|"$_"| ] ] ] ] } @lst), (map { [ -LITERAL => [ qq|"$_"| ] ] } @lst), (map { [ -LITERAL => [ qq|"$_"| ] ], [ -PAREN => [ [ -LITERAL => [ qq|"$_"| ] ] ] ] } @lst), ] ] ] ], [ "FROM", [ [ "-LITERAL", [ "foo" ] ] ] ] ], 'long list parsed correctly'); is( $sqlat->unparse($tree), $sql, 'roundtrip ok'); } [], 'no recursion warnings on insane SQL'; done_testing; SQL-Abstract-2.000001/t/00new.t0000644000000000000000000000732114002362432015512 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use SQL::Abstract::Test import => [ qw(is_same_sql dumper) ]; use SQL::Abstract; my @handle_tests = ( #1 { args => {logic => 'OR'}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #2 { args => {}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #3 { args => {case => "upper"}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #4 { args => {case => "upper", cmp => "="}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #5 { args => {cmp => "=", logic => 'or'}, stmt => 'SELECT * FROM test WHERE ( a = ? AND b = ? )' }, #6 { args => {cmp => "like"}, stmt => 'SELECT * FROM test WHERE ( a LIKE ? AND b LIKE ? )' }, #7 { args => {logic => "or", cmp => "like"}, stmt => 'SELECT * FROM test WHERE ( a LIKE ? AND b LIKE ? )' }, #8 { args => {case => "lower"}, stmt => 'select * from test where ( a = ? and b = ? )' }, #9 { args => {case => "lower", cmp => "="}, stmt => 'select * from test where ( a = ? and b = ? )' }, #10 { args => {case => "lower", cmp => "like"}, stmt => 'select * from test where ( a like ? and b like ? )' }, #11 { args => {case => "lower", convert => "lower", cmp => "like"}, stmt => 'select * from test where ( lower(a) like lower(?) and lower(b) like lower(?) )' }, #12 { args => {convert => "Round"}, stmt => 'SELECT * FROM test WHERE ( ROUND(a) = ROUND(?) AND ROUND(b) = ROUND(?) )', }, #13 { args => {convert => "lower"}, stmt => 'SELECT * FROM test WHERE ( ( LOWER(ticket) = LOWER(?) ) OR ( LOWER(hostname) = LOWER(?) ) OR ( LOWER(taco) = LOWER(?) ) OR ( LOWER(salami) = LOWER(?) ) )', where => [ { ticket => 11 }, { hostname => 11 }, { taco => 'salad' }, { salami => 'punch' } ], }, #14 { args => {convert => "upper"}, stmt => 'SELECT * FROM test WHERE ( ( UPPER(hostname) IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) AND ( ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) OR ( UPPER(ticket) = UPPER(?) ) ) ) OR ( UPPER(tack) BETWEEN UPPER(?) AND UPPER(?) ) OR ( ( ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) OR ( UPPER(a) = UPPER(?) ) ) AND ( ( UPPER(e) != UPPER(?) ) OR ( UPPER(e) != UPPER(?) ) ) AND UPPER(q) NOT IN ( UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?), UPPER(?) ) ) )', where => [ { ticket => [11, 12, 13], hostname => { in => ['ntf', 'avd', 'bvd', '123'] } }, { tack => { between => [qw/tick tock/] } }, { a => [qw/b c d/], e => { '!=', [qw(f g)] }, q => { 'not in', [14..20] } } ], warns => qr/\QA multi-element arrayref as an argument to the inequality op '!=' is technically equivalent to an always-true 1=1/, }, ); for (@handle_tests) { my $sqla = SQL::Abstract->new($_->{args}); my $stmt; lives_ok(sub { (warnings_exist { $stmt = $sqla->select( 'test', '*', $_->{where} || { a => 4, b => 0} ); } $_->{warns} || []) || diag dumper($_); }) or diag dumper({ %$_, threw => $@ }); is_same_sql($stmt, $_->{stmt}); } done_testing; SQL-Abstract-2.000001/t/dbic/0000755000000000000000000000000014002747454015305 5ustar00rootroot00000000000000SQL-Abstract-2.000001/t/dbic/bulk-insert.t0000644000000000000000000000165013340604277017732 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; BEGIN { # ask for a recent DBIC version to skip the 5.6 testing as well plan skip_all => 'Test temporarily requires DBIx::Class' unless eval { require DBIx::Class::Storage::Statistics; DBIx::Class->VERSION('0.08124') }; plan skip_all => 'Test does not properly work with the pre-0.082800 DBIC trials' if DBIx::Class->VERSION =~ /^0.082700\d\d/; } use DBIx::Class::Storage::Debug::PrettyPrint; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => 'none', fill_in_placeholders => 1, placeholder_surround => [qw(' ')], show_progress => 0, }); $pp->debugfh($fh); $pp->query_start('INSERT INTO self_ref_alias (alias, self_ref) VALUES ( ?, ? )', qw('__BULK_INSERT__' '1')); is( $cap, qq{INSERT INTO self_ref_alias( alias, self_ref ) VALUES( ?, ? ) : '__BULK_INSERT__', '1'\n}, 'SQL Logged' ); done_testing; SQL-Abstract-2.000001/t/dbic/no-repeats.t0000644000000000000000000000312513340604277017547 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; BEGIN { # ask for a recent DBIC version to skip the 5.6 tests as well plan skip_all => 'Test temporarily requires DBIx::Class' unless eval { require DBIx::Class::Storage::Statistics; DBIx::Class->VERSION('0.08124') }; plan skip_all => 'Test does not properly work with the pre-0.082800 DBIC trials' if DBIx::Class->VERSION =~ /^0.082700\d\d/; } use DBIx::Class::Storage::Debug::PrettyPrint; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => 'none', squash_repeats => 1, fill_in_placeholders => 1, placeholder_surround => ['', ''], show_progress => 0, }); $pp->debugfh($fh); $pp->query_start('SELECT * FROM frew WHERE id = ?', q('1')); is( $cap, qq(SELECT * FROM frew WHERE id = '1'\n), 'SQL Logged' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('2')); is( $cap, qq(... : '2'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('3')); is( $cap, qq(... : '3'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('4')); is( $cap, qq(... : '4'\n), 'Repeated SQL ellided' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM bar WHERE id = ?', q('4')); is( $cap, qq(SELECT * FROM bar WHERE id = '4'\n), 'New SQL Logged' ); open $fh, '>', \$cap; $pp->query_start('SELECT * FROM frew WHERE id = ?', q('1')); is( $cap, qq(SELECT * FROM frew WHERE id = '1'\n), 'New SQL Logged' ); done_testing; SQL-Abstract-2.000001/t/dbic/show-progress.t0000644000000000000000000000165513340604277020322 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; BEGIN { # ask for a recent DBIC version to skip the 5.6 tests as well plan skip_all => 'Test temporarily requires DBIx::Class' unless eval { require DBIx::Class::Storage::Statistics; DBIx::Class->VERSION('0.08124') }; plan skip_all => 'Test does not properly work with the pre-0.082800 DBIC trials' if DBIx::Class->VERSION =~ /^0.082700\d\d/; } use DBIx::Class::Storage::Debug::PrettyPrint; my $cap; open my $fh, '>', \$cap; my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ show_progress => 1, clear_line => 'CLEAR', executing => 'GOGOGO', }); $pp->debugfh($fh); $pp->query_start('SELECT * FROM frew WHERE id = 1'); is( $cap, qq(SELECT * FROM frew WHERE id = 1 : \nGOGOGO), 'SQL Logged' ); $pp->query_end('SELECT * FROM frew WHERE id = 1'); is( $cap, qq(SELECT * FROM frew WHERE id = 1 : \nGOGOGOCLEAR), 'SQL Logged' ); done_testing; SQL-Abstract-2.000001/t/20injection_guard.t0000644000000000000000000000210611603625623020073 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract; my $sqla = SQL::Abstract->new; my $sqla_q = SQL::Abstract->new(quote_char => '"'); throws_ok( sub { $sqla->select( 'foo', [ 'bar' ], { 'bobby; tables' => 'bar' }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on unquoted column' ); my ($sql, @bind) = $sqla_q->select( 'foo', [ 'bar' ], { 'bobby; tables' => 'bar' }, ); is_same_sql_bind ( $sql, \@bind, 'SELECT "bar" FROM "foo" WHERE ( "bobby; tables" = ? )', [ 'bar' ], 'Correct sql with quotes on' ); for ($sqla, $sqla_q) { throws_ok( sub { $_->select( 'foo', [ 'bar' ], { x => { 'bobby; tables' => 'y' } }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on top level op'); throws_ok( sub { $_->select( 'foo', [ 'bar' ], { x => { '<' => { "-go\ndo some harm" => 'y' } } }, ); }, qr/Possible SQL injection attempt/, 'Injection thwarted on chained functions'); } done_testing; SQL-Abstract-2.000001/t/03values.t0000644000000000000000000000576713340604277016251 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Test import => [qw/is_same_sql_bind is_same_bind/]; use SQL::Abstract; my @data = ( { user => 'nwiger', name => 'Nathan Wiger', phone => '123-456-7890', addr => 'Yeah, right', city => 'Milwalkee', state => 'Minnesota', }, { user => 'jimbo', name => 'Jimbo Bobson', phone => '321-456-0987', addr => 'Yo Momma', city => 'Yo City', state => 'Minnesota', }, { user => 'mr.hat', name => 'Mr. Garrison', phone => '123-456-7890', addr => undef, city => 'South Park', state => 'CO', }, { user => 'kennyg', name => undef, phone => '1-800-Sucky-Sucky', addr => 'Mr. Garrison', city => undef, state => 'CO', }, { user => 'barbara_streisand', name => 'MechaStreisand!', phone => 0, addr => -9230992340, city => 42, state => 'CO', }, ); # test insert() and values() for reentrancy my($insert_hash, $insert_array, $numfields); my $a_sql = SQL::Abstract->new; my $h_sql = SQL::Abstract->new; for my $record (@data) { my $values = [ map { $record->{$_} } sort keys %$record ]; my ($h_stmt, @h_bind) = $h_sql->insert('h_table', $record); my ($a_stmt, @a_bind) = $a_sql->insert('a_table', $values ); # init from first run, should not change afterwards $insert_hash ||= $h_stmt; $insert_array ||= $a_stmt; $numfields ||= @$values; is ( $a_stmt, $insert_array, 'Array-based insert statement unchanged' ); is ( $h_stmt, $insert_hash, 'Hash-based insert statement unchanged' ); is_deeply ( \@a_bind, \@h_bind, 'Bind values match after both insert() calls' ); is_deeply ( [$h_sql->values($record)] , \@h_bind, 'values() output matches bind values after insert()' ); is ( scalar @h_bind, $numfields, 'Number of fields unchanged' ); } # test values() with literal sql # # NOTE: # The example is deliberately complicated by the addition of a literal ? in xfunc # This is an intentional test making sure literal ? remains untouched. # It is rather impractical in the field, as the user will have to insert # a bindvalue for the literal position(s) in the correct offset of \@bind { my $sql = SQL::Abstract->new; my $data = { event => 'rapture', stuff => 'fluff', time => \ 'now()', xfunc => \ 'xfunc(?)', yfunc => ['yfunc(?)', 'ystuff' ], zfunc => \['zfunc(?)', 'zstuff' ], zzlast => 'zzstuff', }; my ($stmt, @bind) = $sql->insert('table', $data); is_same_sql_bind ( $stmt, \@bind, 'INSERT INTO table ( event, stuff, time, xfunc, yfunc, zfunc, zzlast) VALUES ( ?, ?, now(), xfunc (?), yfunc(?), zfunc(?), ? )', [qw/rapture fluff ystuff zstuff zzstuff/], # event < stuff ); is_same_bind ( [$sql->values($data)], [@bind], 'values() output matches that of initial bind' ) || diag "Corresponding SQL statement: $stmt"; } done_testing; SQL-Abstract-2.000001/t/10test.t0000644000000000000000000010216513340604277015715 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Test import => [qw( eq_sql_bind eq_sql eq_bind is_same_sql_bind dumper $sql_differ )]; my @sql_tests = ( # WHERE condition - equal { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1/, q/SELECT foo FROM bar WHERE a=1/, q/SELECT foo FROM bar WHERE (a = 1)/, q/SELECT foo FROM bar WHERE (a=1)/, q/SELECT foo FROM bar WHERE ( a = 1 )/, q/ SELECT foo FROM bar WHERE a = 1 /, q/ SELECT foo FROM bar WHERE (a = 1) /, q/ SELECT foo FROM bar WHERE ( a = 1 ) /, q/SELECT foo FROM bar WHERE ((a = 1))/, q/SELECT foo FROM bar WHERE ( (a = 1) )/, q/SELECT foo FROM bar WHERE ( ( a = 1 ) )/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1/, q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1)/, q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 1))/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1)/, q/SELECT foo FROM bar WHERE ((a = 1 AND b = 1))/, q/SELECT foo FROM bar WHERE (((a = 1) AND (b = 1)))/, q/ SELECT foo FROM bar WHERE a = 1 AND b = 1 /, q/ SELECT foo FROM bar WHERE (a = 1 AND b = 1) /, q/ SELECT foo FROM bar WHERE (a = 1) AND (b = 1) /, q/ SELECT foo FROM bar WHERE ((a = 1) AND (b = 1)) /, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 OR c = 1/, q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) OR c = 1/, q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 OR c = 1)/, q/SELECT foo FROM bar WHERE a = 1 OR ((b = 1 OR (c = 1)))/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/, q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE (a) AND (b = 2)/, q/SELECT foo FROM bar WHERE (a AND b = 2)/, q/SELECT foo FROM bar WHERE (a AND (b = 2))/, q/SELECT foo FROM bar WHERE a AND (b = 2)/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar WHERE ((NOT a) AND b = 2)/, q/SELECT foo FROM bar WHERE (NOT a) AND (b = 2)/, q/SELECT foo FROM bar WHERE (NOT (a)) AND b = 2/, ], }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE NOT a AND (b = 2)/, q/SELECT foo FROM bar WHERE (NOT a) AND (b = 2)/, ] }, { equal => 0, opts => { parenthesis_significant => 1 }, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND c = 1/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) AND c = 1/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 AND c = 1)/, q/SELECT foo FROM bar WHERE ((((a = 1))) AND (b = 1 AND c = 1))/, ] }, { equal => 0, opts => { parenthesis_significant => 1 }, statements => [ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 OR c = 1/, q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) OR c = 1/, q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 OR c = 1)/, q/SELECT foo FROM bar WHERE a = 1 OR ((b = 1 OR (c = 1)))/, ] }, { equal => 0, opts => { parenthesis_significant => 1 }, statements => [ q/SELECT foo FROM bar WHERE (a = 1) AND (b = 1 OR c = 1 OR d = 1) AND (e = 1 AND f = 1)/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1 OR d = 1) AND e = 1 AND (f = 1)/, q/SELECT foo FROM bar WHERE ( ((a = 1) AND ( b = 1 OR (c = 1 OR d = 1) )) AND ((e = 1)) AND f = 1) /, ] }, # WHERE condition - different { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1/, q/SELECT quux FROM bar WHERE a = 1/, q/SELECT foo FROM quux WHERE a = 1/, q/FOOBAR foo FROM bar WHERE a = 1/, q/SELECT foo FROM bar WHERE a = 2/, q/SELECT foo FROM bar WHERE a < 1/, q/SELECT foo FROM bar WHERE b = 1/, q/SELECT foo FROM bar WHERE (c = 1)/, q/SELECT foo FROM bar WHERE (d = 1)/, q/SELECT foo FROM bar WHERE a = 1 AND quux/, q/SELECT foo FROM bar WHERE a = 1 GROUP BY foo/, q/SELECT foo FROM bar WHERE a = 1 ORDER BY foo/, q/SELECT foo FROM bar WHERE a = 1 LIMIT 1/, q/SELECT foo FROM bar WHERE a = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux WHERE a = 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE a = 1/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1/, q/SELECT quux FROM bar WHERE a = 1 AND b = 1/, q/SELECT foo FROM quux WHERE a = 1 AND b = 1/, q/FOOBAR foo FROM bar WHERE a = 1 AND b = 1/, q/SELECT foo FROM bar WHERE a = 2 AND b = 1/, q/SELECT foo FROM bar WHERE a = 3 AND (b = 1)/, q/SELECT foo FROM bar WHERE (a = 4) AND b = 1/, q/SELECT foo FROM bar WHERE (a = 5) AND (b = 1)/, q/SELECT foo FROM bar WHERE ((a = 6) AND (b = 1))/, q/SELECT foo FROM bar WHERE ((a = 7) AND (b = 1))/, q/SELECT foo FROM bar WHERE a = 1 AND b = 2/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 3)/, q/SELECT foo FROM bar WHERE (a = 1) AND b = 4/, q/SELECT foo FROM bar WHERE (a = 1) AND (b = 5)/, q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 6))/, q/SELECT foo FROM bar WHERE ((a = 1) AND (b = 7))/, q/SELECT foo FROM bar WHERE a < 1 AND b = 1/, q/SELECT foo FROM bar WHERE b = 1 AND b = 1/, q/SELECT foo FROM bar WHERE (c = 1) AND b = 1/, q/SELECT foo FROM bar WHERE (d = 1) AND b = 1/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 AND quux/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 GROUP BY foo/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 ORDER BY foo/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 LIMIT 1/, q/SELECT foo FROM bar WHERE a = 1 AND b = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux WHERE a = 1 AND b = 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE a = 1 AND b = 1/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1 AND b = 1 OR c = 1/, q/SELECT foo FROM bar WHERE (a = 1 AND b = 1) OR c = 1/, q/SELECT foo FROM bar WHERE a = 1 AND (b = 1 OR c = 1)/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a = 1 OR b = 1 AND c = 1/, q/SELECT foo FROM bar WHERE (a = 1 OR b = 1) AND c = 1/, q/SELECT foo FROM bar WHERE a = 1 OR (b = 1 AND c = 1)/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar WHERE a IN (1,3,2)/, q/SELECT foo FROM bar WHERE a IN 1,2,3/, q/SELECT foo FROM bar WHERE a IN (1,2,3)/, q/SELECT foo FROM bar WHERE a IN ((1,2,3))/, ] }, { equal => 0, statements => [ # BETWEEN with/without parenthesis around itself/RHS is a sticky business # if I made a mistake here, simply rewrite the special BETWEEN handling in # _recurse_parse() # # by RIBASUSHI q/SELECT foo FROM bar WHERE ( completion_date BETWEEN ? AND ? AND status = ? )/, q/SELECT foo FROM bar WHERE completion_date BETWEEN (? AND ?) AND status = ?/, q/SELECT foo FROM bar WHERE ( (completion_date BETWEEN (? AND ?) ) AND status = ? )/, q/SELECT foo FROM bar WHERE ( (completion_date BETWEEN (? AND ? AND status = ?) ) )/, ] }, # IS NULL (special LHS-only op) { equal => 1, statements => [ q/WHERE a IS NOT NULL AND b IS NULL/, q/WHERE (a IS NOT NULL) AND b IS NULL/, q/WHERE a IS NOT NULL AND (b IS NULL)/, q/WHERE (a IS NOT NULL) AND ((b IS NULL))/, ], }, # JOIN condition - equal { equal => 1, statements => [ q/SELECT foo FROM bar JOIN baz ON a = 1 WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON a=1 WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a = 1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a=1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ( a = 1 ) WHERE x = 1/, q/ SELECT foo FROM bar JOIN baz ON a = 1 WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON (a = 1) WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON ( a = 1 ) WHERE x = 1 /, q/SELECT foo FROM bar JOIN baz ON ((a = 1)) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ( (a = 1) ) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ( ( a = 1 ) ) WHERE x = 1/, ] }, { equal => 1, statements => [ q/SELECT foo FROM bar JOIN baz ON a = 1 AND b = 1 WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a = 1) AND (b = 1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ((a = 1) AND (b = 1)) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (a = 1 AND b = 1) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON ((a = 1 AND b = 1)) WHERE x = 1/, q/SELECT foo FROM bar JOIN baz ON (((a = 1) AND (b = 1))) WHERE x = 1/, q/ SELECT foo FROM bar JOIN baz ON a = 1 AND b = 1 WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON (a = 1 AND b = 1) WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON (a = 1) AND (b = 1) WHERE x = 1 /, q/ SELECT foo FROM bar JOIN baz ON ((a = 1) AND (b = 1)) WHERE x = 1 /, ] }, # JOIN condition - different { equal => 0, statements => [ q/SELECT foo FROM bar JOIN quux ON a = 1 WHERE quuux/, q/SELECT quux FROM bar JOIN quux ON a = 1 WHERE quuux/, q/SELECT foo FROM quux JOIN quux ON a = 1 WHERE quuux/, q/FOOBAR foo FROM bar JOIN quux ON a = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 2 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a < 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (c = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (d = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 GROUP BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 ORDER BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 LIMIT 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux ON a = 1/, ] }, { equal => 0, statements => [ q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/SELECT quux FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM quux JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/FOOBAR foo FROM bar JOIN quux ON a = 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 2 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 3 AND (b = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 4) AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 5) AND (b = 1) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 6) AND (b = 1)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 7) AND (b = 1)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 2 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND (b = 3) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 1) AND b = 4 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (a = 1) AND (b = 5) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 1) AND (b = 6)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON ((a = 1) AND (b = 7)) WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a < 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON b = 1 AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (c = 1) AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON (d = 1) AND b = 1 WHERE quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 AND quuux/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 GROUP BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 ORDER BY foo/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 LIMIT 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 AND b = 1 OFFSET 1/, q/SELECT foo FROM bar JOIN quux JOIN quuux ON a = 1 AND b = 1/, q/SELECT foo FROM bar JOIN quux ON a = 1 JOIN quuux ON a = 1 AND b = 1/, ] }, # DISTINCT ON (...) not confused with JOIN ON (...) { equal => 1, statements => [ q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a = 1/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a=1/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a = 1)/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a=1)/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( a = 1 )/, q/ SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE a = 1 /, q/ SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE (a = 1) /, q/ SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( a = 1 ) /, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ((a = 1))/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( (a = 1) )/, q/SELECT DISTINCT ON (foo, quux) foo, quux FROM bar WHERE ( ( a = 1 ) )/, ] }, # subselects - equal { equal => 1, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE (a = 1)/, ] }, { equal => 1, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 1)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 1)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 1))) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 1)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 1) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 1)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 1))) AS foo WHERE (a = 1)/, ] }, # subselects - different { equal => 0, statements => [ q/DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM (SELECT * FROM cd me WHERE ( year != ? ) GROUP BY me.cdid) me WHERE ( year != ? ) ) )/, q/DELETE FROM cd WHERE ( cdid IN ( SELECT me.cdid FROM cd me WHERE ( year != ? ) GROUP BY me.cdid ) )/, ], }, { equal => 0, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1) AS foo WHERE (a = 3)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE a = 4/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1)) AS foo WHERE (a = 5)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 2) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 3) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 4)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 5)) AS foo WHERE (a = 1)/, ] }, { equal => 0, statements => [ q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 2) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 3)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 4)) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 5))) AS foo WHERE a = 1/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 6) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 7) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 1)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 1) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 2) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 3)) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 4)) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 5))) AS foo WHERE a = 2/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND c = 6) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND c = 7) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE b = 1 AND (c = 8)) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE (b = 1) AND (c = 9)) AS foo WHERE (a = 2)/, q/SELECT * FROM (SELECT * FROM bar WHERE ((b = 1) AND (c = 10))) AS foo WHERE (a = 2)/, ] }, # order by { equal => 1, statements => [ q/SELECT * FROM foo ORDER BY bar/, q/SELECT * FROM foo ORDER BY bar ASC/, q/SELECT * FROM foo ORDER BY bar asc/, ], }, { equal => 1, statements => [ q/SELECT * FROM foo ORDER BY bar, baz ASC/, q/SELECT * FROM foo ORDER BY bar ASC, baz/, q/SELECT * FROM foo ORDER BY bar asc, baz ASC/, q/SELECT * FROM foo ORDER BY bar, baz/, ], }, { equal => 1, statements => [ q/ORDER BY colA, colB LIKE ? DESC, colC LIKE ?/, q/ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC/, ], }, { equal => 1, statements => [ q/ORDER BY name + ?, [me].[id]/, q/ORDER BY name + ? ASC, [me].[id]/, ], }, { equal => 0, opts => { order_by_asc_significant => 1 }, statements => [ q/SELECT * FROM foo ORDER BY bar/, q/SELECT * FROM foo ORDER BY bar ASC/, q/SELECT * FROM foo ORDER BY bar desc/, ], }, # list permutations { equal => 0, statements => [ 'SELECT a,b,c FROM foo', 'SELECT a,c,b FROM foo', 'SELECT b,a,c FROM foo', 'SELECT b,c,a FROM foo', 'SELECT c,a,b FROM foo', 'SELECT c,b,a FROM foo', ], }, { equal => 0, statements => [ 'SELECT * FROM foo WHERE a IN (1,2,3)', 'SELECT * FROM foo WHERE a IN (1,3,2)', 'SELECT * FROM foo WHERE a IN (2,1,3)', 'SELECT * FROM foo WHERE a IN (2,3,1)', 'SELECT * FROM foo WHERE a IN (3,1,2)', 'SELECT * FROM foo WHERE a IN (3,2,1)', ] }, # list consistency { equal => 0, statements => [ 'SELECT a,b FROM foo', 'SELECT a,,b FROM foo', 'SELECT a,b, FROM foo', 'SELECT ,a,b, FROM foo', 'SELECT ,a,,b, FROM foo', ], }, # misc func { equal => 0, statements => [ 'SELECT count(*) FROM foo', 'SELECT count(*) AS bar FROM foo', 'SELECT count(*) AS "bar" FROM foo', 'SELECT count(a) FROM foo', 'SELECT count(1) FROM foo', ] }, { equal => 1, statements => [ 'SELECT foo() bar FROM baz', 'SELECT foo ( )bar FROM baz', 'SELECT foo (())bar FROM baz', 'SELECT foo(( ) ) bar FROM baz', ] }, { equal => 0, statements => [ 'SELECT foo() FROM bar', 'SELECT foo FROM bar', 'SELECT foo FROM bar ()', ] }, { equal => 0, statements => [ 'SELECT COUNT * FROM foo', 'SELECT COUNT( * ) FROM foo', ] }, # single ? of unknown funcs do not unroll unless # explicitly allowed (e.g. Like) { equal => 0, statements => [ 'SELECT foo FROM bar WHERE bar > foo ?', 'SELECT foo FROM bar WHERE bar > foo( ? )', ] }, { equal => 1, statements => [ 'SELECT foo FROM bar WHERE bar LIKE ?', 'SELECT foo FROM bar WHERE bar LiKe (?)', 'SELECT foo FROM bar WHERE bar lIkE( (?))', ] }, # test multival { equal => 0, statements => [ 'SELECT foo FROM bar WHERE foo IN (?, ?)', 'SELECT foo FROM bar WHERE foo IN ?, ?', ] }, # math { equal => 0, statements => [ 'SELECT * FROM foo WHERE 1 = ( a > b)', 'SELECT * FROM foo WHERE 1 = a > b', 'SELECT * FROM foo WHERE (1 = a) > b', ] }, { equal => 1, statements => [ 'SELECT * FROM foo WHERE bar = baz(buzz)', 'SELECT * FROM foo WHERE bar = (baz( buzz ))', ] }, # oddballs { equal => 1, statements => [ 'WHERE ( foo GLOB ? )', 'WHERE foo GLOB ?', ], }, { equal => 1, statements => [ 'SELECT FIRST ? SKIP ? [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( (EXISTS ( SELECT FIRST ? SKIP ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) )) AND [source] = ? ) )', 'SELECT FIRST ? SKIP ? [me].[id], [me].[owner] FROM [books] [me] WHERE ( ( EXISTS ( SELECT FIRST ? SKIP ? [owner].[id] FROM [owners] [owner] WHERE ( [books].[owner] = [owner].[id] ) ) AND [source] = ? ) )', ], }, { equal => 1, statements => [ 'WHERE foo = ? FETCH FIRST 1 ROWS ONLY', 'WHERE ( foo = ? ) FETCH FIRST 1 ROWS ONLY', 'WHERE (( foo = ? )) FETCH FIRST 1 ROWS ONLY', ], }, ); my @bind_tests = ( # scalar - equal { equal => 1, bindvals => [ undef, undef, ] }, { equal => 1, bindvals => [ 'foo', 'foo', ] }, { equal => 1, bindvals => [ 42, 42, '42', ] }, # scalarref - equal { equal => 1, bindvals => [ \'foo', \'foo', ] }, { equal => 1, bindvals => [ \42, \42, \'42', ] }, # arrayref - equal { equal => 1, bindvals => [ [], [] ] }, { equal => 1, bindvals => [ [42], [42], ['42'], ] }, { equal => 1, bindvals => [ [1, 42], [1, 42], ['1', 42], [1, '42'], ['1', '42'], ] }, # hashref - equal { equal => 1, bindvals => [ { foo => 42 }, { foo => 42 }, { foo => '42' }, ] }, { equal => 1, bindvals => [ { foo => 42, bar => 1 }, { foo => 42, bar => 1 }, { foo => '42', bar => 1 }, ] }, # blessed object - equal { equal => 1, bindvals => [ bless(\(local $_ = 42), 'Life::Universe::Everything'), bless(\(local $_ = 42), 'Life::Universe::Everything'), ] }, { equal => 1, bindvals => [ bless([42], 'Life::Universe::Everything'), bless([42], 'Life::Universe::Everything'), ] }, { equal => 1, bindvals => [ bless({ answer => 42 }, 'Life::Universe::Everything'), bless({ answer => 42 }, 'Life::Universe::Everything'), ] }, # complex data structure - equal { equal => 1, bindvals => [ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], ] }, # scalar - different { equal => 0, bindvals => [ undef, 'foo', 42, ] }, # scalarref - different { equal => 0, bindvals => [ \undef, \'foo', \42, ] }, # arrayref - different { equal => 0, bindvals => [ [undef], ['foo'], [42], ] }, # hashref - different { equal => 0, bindvals => [ { foo => undef }, { foo => 'bar' }, { foo => 42 }, ] }, # different types { equal => 0, bindvals => [ 'foo', \'foo', ['foo'], { foo => 'bar' }, ] }, # complex data structure - different { equal => 0, bindvals => [ [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [43, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'baz', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { bar => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quuux => [1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [0, 1, 2, \3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, 3, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \4, { quux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quuux => [4, 5] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5, 6] } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => 4 } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5], quuux => 1 } ] }, 8 ], [42, { foo => 'bar', quux => [1, 2, \3, { quux => [4, 5] } ] }, 8, 9 ], ] }, ); for my $test (@sql_tests) { # this does not work on 5.8.8 and earlier :( #local @{*SQL::Abstract::Test::}{keys %{$test->{opts}}} = map { \$_ } values %{$test->{opts}} # if $test->{opts}; my %restore_globals; for (keys %{$test->{opts} || {} }) { $restore_globals{$_} = ${${*SQL::Abstract::Test::}{$_}}; ${*SQL::Abstract::Test::}{$_} = \ do { my $cp = $test->{opts}{$_} }; } my $statements = $test->{statements}; while (@$statements) { my $sql1 = shift @$statements; foreach my $sql2 (@$statements) { my $equal = eq_sql($sql1, $sql2); TODO: { local $TODO = $test->{todo} if $test->{todo}; if ($test->{equal}) { ok($equal, "equal SQL expressions should have been considered equal"); } else { ok(!$equal, "different SQL expressions should have been considered not equal"); } if ($equal ^ $test->{equal}) { my ($ast1, $ast2) = map { SQL::Abstract::Test::parse ($_) } ($sql1, $sql2); $_ = dumper($_) for ($ast1, $ast2); diag "sql1: $sql1"; diag "sql2: $sql2"; note $sql_differ || 'No differences found'; note "ast1: $ast1"; note "ast2: $ast2"; } } } } ${*SQL::Abstract::Test::}{$_} = \$restore_globals{$_} for keys %restore_globals; } for my $test (@bind_tests) { my $bindvals = $test->{bindvals}; while (@$bindvals) { my $bind1 = shift @$bindvals; foreach my $bind2 (@$bindvals) { my $equal = eq_bind($bind1, $bind2); if ($test->{equal}) { ok($equal, "equal bind values considered equal"); } else { ok(!$equal, "different bind values considered not equal"); } if ($equal ^ $test->{equal}) { diag("bind1: " . dumper($bind1)); diag("bind2: " . dumper($bind2)); } } } } ok(eq_sql_bind( "SELECT * FROM foo WHERE id = ?", [42], "SELECT * FROM foo WHERE (id = ?)", [42], ), "eq_sql_bind considers equal SQL expressions and bind values equal" ); ok(!eq_sql_bind( "SELECT * FROM foo WHERE id = ?", [42], "SELECT * FROM foo WHERE (id = ?)", [0], ), "eq_sql_bind considers equal SQL expressions and different bind values different" ); ok(!eq_sql_bind( "SELECT * FROM foo WHERE id = ?", [42], "SELECT * FROM bar WHERE (id = ?)", [42], ), "eq_sql_bind considers different SQL expressions and equal bind values different" ); # test diag string ok (! eq_sql ( 'SELECT owner_name FROM books me WHERE ( source = ? )', 'SELECT owner_name FROM books me WHERE ( sUOrce = ? )', )); like( $sql_differ, qr/\Q[ source ] != [ sUOrce ]/, 'expected debug of literal diff', ); ok (! eq_sql ( 'SELECT owner_name FROM books me ORDER BY owner_name', 'SELECT owner_name FROM books me GROUP BY owner_name', )); like( $sql_differ, qr/\QOP [ORDER BY] != [GROUP BY]/, 'expected debug of op diff', ); ok (! eq_sql ( 'SELECT owner_name FROM books WHERE ( source = ? )', 'SELECT owner_name FROM books' )); like( $sql_differ, qr|\Q[WHERE source = ?] != [N/A]|, 'expected debug of missing branch', ); ok (eq_sql_bind ( \[ 'SELECT foo FROM bar WHERE baz = ? or buzz = ?', [ {} => 1 ], 2 ], 'SELECT foo FROM bar WHERE (baz = ?) OR buzz = ?', [ [ {} => 1 ], 2 ], ), 'arrayrefref unpacks correctly' ); is_same_sql_bind( \[ 'SELECT foo FROM bar WHERE baz = ? or buzz = ?', [ {} => 1 ], 2 ], \[ 'SELECT foo FROM bar WHERE (( baz = ? OR (buzz = ?) ))', [ {} => 1 ], 2 ], 'double arrayrefref unpacks correctly' ); done_testing; SQL-Abstract-2.000001/t/13whitespace_keyword.t0000644000000000000000000000126111603625623020632 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ newline => "\n", indent_string => " ", indent_amount => 1, indentmap => { select => 0, where => 1, from => 2, join => 3, on => 4, 'group by' => 5, 'order by' => 6, }, }); for ( keys %{$sqlat->indentmap}) { my ($l, $r) = @{$sqlat->pad_keyword($_, 1)}; is($r, '', "right is empty for $_"); is($l, "\n " . ' ' x $sqlat->indentmap->{$_}, "left calculated correctly for $_" ); } is($sqlat->pad_keyword('select', 0)->[0], '', 'Select gets no newline or indent for depth 0'); done_testing; SQL-Abstract-2.000001/t/06order_by.t0000644000000000000000000001041114002362432016526 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract; use SQL::Abstract::Test import => ['is_same_sql_bind']; my @cases = ( { given => \'colA DESC', expects => ' ORDER BY colA DESC', expects_quoted => ' ORDER BY colA DESC', }, { given => 'colA', expects => ' ORDER BY colA', expects_quoted => ' ORDER BY `colA`', }, { # it may look odd, but this is the desired behaviour (mst) given => 'colA DESC', expects => ' ORDER BY colA DESC', expects_quoted => ' ORDER BY `colA DESC`', }, { given => [qw/colA colB/], expects => ' ORDER BY colA, colB', expects_quoted => ' ORDER BY `colA`, `colB`', }, { # it may look odd, but this is the desired behaviour (mst) given => ['colA ASC', 'colB DESC'], expects => ' ORDER BY colA ASC, colB DESC', expects_quoted => ' ORDER BY `colA ASC`, `colB DESC`', }, { given => {-asc => 'colA'}, expects => ' ORDER BY colA ASC', expects_quoted => ' ORDER BY `colA` ASC', }, { given => {-desc => 'colB'}, expects => ' ORDER BY colB DESC', expects_quoted => ' ORDER BY `colB` DESC', }, { given => [{-asc => 'colA'}, {-desc => 'colB'}], expects => ' ORDER BY colA ASC, colB DESC', expects_quoted => ' ORDER BY `colA` ASC, `colB` DESC', }, { given => ['colA', {-desc => 'colB'}], expects => ' ORDER BY colA, colB DESC', expects_quoted => ' ORDER BY `colA`, `colB` DESC', }, { given => undef, expects => '', expects_quoted => '', }, { given => [ {} ], expects => '', expects_quoted => '', }, { given => [{-desc => [ qw/colA colB/ ] }], expects => ' ORDER BY colA DESC, colB DESC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC', }, { given => [{-desc => [ qw/colA colB/ ] }, {-asc => 'colC'}], expects => ' ORDER BY colA DESC, colB DESC, colC ASC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` ASC', }, { given => [{-desc => [ qw/colA colB/ ] }, {-asc => [ qw/colC colD/ ] }], expects => ' ORDER BY colA DESC, colB DESC, colC ASC, colD ASC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` ASC, `colD` ASC', }, { given => [{-desc => [ qw/colA colB/ ] }, {-desc => 'colC' }], expects => ' ORDER BY colA DESC, colB DESC, colC DESC', expects_quoted => ' ORDER BY `colA` DESC, `colB` DESC, `colC` DESC', }, { given => [{ -asc => 'colA' }, { -desc => [qw/colB/] }, { -asc => [qw/colC colD/] }], expects => ' ORDER BY colA ASC, colB DESC, colC ASC, colD ASC', expects_quoted => ' ORDER BY `colA` ASC, `colB` DESC, `colC` ASC, `colD` ASC', }, { given => { -desc => \['colA LIKE ?', 'test'] }, expects => ' ORDER BY colA LIKE ? DESC', expects_quoted => ' ORDER BY colA LIKE ? DESC', bind => ['test'], }, { given => \['colA LIKE ? DESC', 'test'], expects => ' ORDER BY colA LIKE ? DESC', expects_quoted => ' ORDER BY colA LIKE ? DESC', bind => ['test'], }, { given => [ { -asc => \['colA'] }, { -desc => \['colB LIKE ?', 'test'] }, { -asc => \['colC LIKE ?', 'tost'] }], expects => ' ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC', expects_quoted => ' ORDER BY colA ASC, colB LIKE ? DESC, colC LIKE ? ASC', bind => [qw/test tost/], }, ); my $sql = SQL::Abstract->new; my $sqlq = SQL::Abstract->new({quote_char => '`'}); for my $case (@cases) { my ($stat, @bind); ($stat, @bind) = $sql->where(undef, $case->{given}); is_same_sql_bind ( $stat, \@bind, $case->{expects}, $case->{bind} || [], ); ($stat, @bind) = $sqlq->where(undef, $case->{given}); is_same_sql_bind ( $stat, \@bind, $case->{expects_quoted}, $case->{bind} || [], ); } throws_ok ( sub { $sql->_order_by({-desc => 'colA', -asc => 'colB' }) }, qr/hash passed .+ must have exactly one key/, 'Undeterministic order exception', ); throws_ok ( sub { $sql->_order_by([ {-desc => 'colA', -asc => 'colB' } ]) }, qr/hash passed .+ must have exactly one key/, 'Undeterministic order exception', ); throws_ok ( sub { $sql->_order_by({-desc => [ qw/colA colB/ ], -asc => [ qw/colC colD/ ] }) }, qr/hash passed .+ must have exactly one key/, 'Undeterministic order exception', ); done_testing; SQL-Abstract-2.000001/t/24order_by_chunks.t0000644000000000000000000004670114002362432020114 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Exception; use Data::Dumper::Concise; use SQL::Abstract; use SQL::Abstract::Test import => ['is_same_sql_bind']; my @cases = ( [ undef, [ \"colA DESC" ], [ "colA DESC" ] ], [ "`", [ \"colA DESC" ], [ "colA DESC" ] ], [ undef, [ "colA" ], [ "colA" ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ undef, [ "colA DESC" ], [ "colA DESC" ] ], [ "`", [ "colA DESC" ], [ "`colA DESC`" ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ [ "colA", "colB" ] ], [ "colA", "colB" ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ [ "colA", "colB" ] ], [ "`colA`", "`colB`" ] ], [ undef, [ "colA ASC" ], [ "colA ASC" ] ], [ undef, [ "colB DESC" ], [ "colB DESC" ] ], [ undef, [ [ "colA ASC", "colB DESC" ] ], [ "colA ASC", "colB DESC" ] ], [ "`", [ "colA ASC" ], [ "`colA ASC`" ] ], [ "`", [ "colB DESC" ], [ "`colB DESC`" ] ], [ "`", [ [ "colA ASC", "colB DESC" ] ], [ "`colA ASC`", "`colB DESC`" ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ { "-asc" => "colA" } ], [ [ "colA ASC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ { "-asc" => "colA" } ], [ [ "`colA` ASC" ] ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ { "-desc" => "colB" } ], [ [ "colB DESC" ] ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ { "-desc" => "colB" } ], [ [ "`colB` DESC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ { "-asc" => "colA" } ], [ [ "colA ASC" ] ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ { "-desc" => "colB" } ], [ [ "colB DESC" ] ] ], [ undef, [ [ { "-asc" => "colA" }, { "-desc" => "colB" } ] ], [ [ "colA ASC" ], [ "colB DESC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ { "-asc" => "colA" } ], [ [ "`colA` ASC" ] ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ { "-desc" => "colB" } ], [ [ "`colB` DESC" ] ] ], [ "`", [ [ { "-asc" => "colA" }, { "-desc" => "colB" } ] ], [ [ "`colA` ASC" ], [ "`colB` DESC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ { "-desc" => "colB" } ], [ [ "colB DESC" ] ] ], [ undef, [ [ "colA", { "-desc" => "colB" } ] ], [ "colA", [ "colB DESC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ { "-desc" => "colB" } ], [ [ "`colB` DESC" ] ] ], [ "`", [ [ "colA", { "-desc" => "colB" } ] ], [ "`colA`", [ "`colB` DESC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ [ "colA", "colB" ] ], [ "colA", "colB" ] ], [ undef, [ { "-desc" => [ "colA", "colB" ] } ], [ [ "colA DESC" ], [ "colB DESC" ] ] ], [ undef, [ [ { "-desc" => [ "colA", "colB" ] } ] ], [ [ "colA DESC" ], [ "colB DESC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ [ "colA", "colB" ] ], [ "`colA`", "`colB`" ] ], [ "`", [ { "-desc" => [ "colA", "colB" ] } ], [ [ "`colA` DESC" ], [ "`colB` DESC" ] ] ], [ "`", [ [ { "-desc" => [ "colA", "colB" ] } ] ], [ [ "`colA` DESC" ], [ "`colB` DESC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ [ "colA", "colB" ] ], [ "colA", "colB" ] ], [ undef, [ { "-desc" => [ "colA", "colB" ] } ], [ [ "colA DESC" ], [ "colB DESC" ] ] ], [ undef, [ "colC" ], [ "colC" ] ], [ undef, [ { "-asc" => "colC" } ], [ [ "colC ASC" ] ] ], [ undef, [ [ { "-desc" => [ "colA", "colB" ] }, { "-asc" => "colC" } ] ], [ [ "colA DESC" ], [ "colB DESC" ], [ "colC ASC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ [ "colA", "colB" ] ], [ "`colA`", "`colB`" ] ], [ "`", [ { "-desc" => [ "colA", "colB" ] } ], [ [ "`colA` DESC" ], [ "`colB` DESC" ] ] ], [ "`", [ "colC" ], [ "`colC`" ] ], [ "`", [ { "-asc" => "colC" } ], [ [ "`colC` ASC" ] ] ], [ "`", [ [ { "-desc" => [ "colA", "colB" ] }, { "-asc" => "colC" } ] ], [ [ "`colA` DESC" ], [ "`colB` DESC" ], [ "`colC` ASC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ [ "colA", "colB" ] ], [ "colA", "colB" ] ], [ undef, [ { "-desc" => [ "colA", "colB" ] } ], [ [ "colA DESC" ], [ "colB DESC" ] ] ], [ undef, [ "colC" ], [ "colC" ] ], [ undef, [ "colD" ], [ "colD" ] ], [ undef, [ [ "colC", "colD" ] ], [ "colC", "colD" ] ], [ undef, [ { "-asc" => [ "colC", "colD" ] } ], [ [ "colC ASC" ], [ "colD ASC" ] ] ], [ undef, [ [ { "-desc" => [ "colA", "colB" ] }, { "-asc" => [ "colC", "colD" ] } ] ], [ [ "colA DESC" ], [ "colB DESC" ], [ "colC ASC" ], [ "colD ASC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ [ "colA", "colB" ] ], [ "`colA`", "`colB`" ] ], [ "`", [ { "-desc" => [ "colA", "colB" ] } ], [ [ "`colA` DESC" ], [ "`colB` DESC" ] ] ], [ "`", [ "colC" ], [ "`colC`" ] ], [ "`", [ "colD" ], [ "`colD`" ] ], [ "`", [ [ "colC", "colD" ] ], [ "`colC`", "`colD`" ] ], [ "`", [ { "-asc" => [ "colC", "colD" ] } ], [ [ "`colC` ASC" ], [ "`colD` ASC" ] ] ], [ "`", [ [ { "-desc" => [ "colA", "colB" ] }, { "-asc" => [ "colC", "colD" ] } ] ], [ [ "`colA` DESC" ], [ "`colB` DESC" ], [ "`colC` ASC" ], [ "`colD` ASC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ [ "colA", "colB" ] ], [ "colA", "colB" ] ], [ undef, [ { "-desc" => [ "colA", "colB" ] } ], [ [ "colA DESC" ], [ "colB DESC" ] ] ], [ undef, [ "colC" ], [ "colC" ] ], [ undef, [ { "-desc" => "colC" } ], [ [ "colC DESC" ] ] ], [ undef, [ [ { "-desc" => [ "colA", "colB" ] }, { "-desc" => "colC" } ] ], [ [ "colA DESC" ], [ "colB DESC" ], [ "colC DESC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ [ "colA", "colB" ] ], [ "`colA`", "`colB`" ] ], [ "`", [ { "-desc" => [ "colA", "colB" ] } ], [ [ "`colA` DESC" ], [ "`colB` DESC" ] ] ], [ "`", [ "colC" ], [ "`colC`" ] ], [ "`", [ { "-desc" => "colC" } ], [ [ "`colC` DESC" ] ] ], [ "`", [ [ { "-desc" => [ "colA", "colB" ] }, { "-desc" => "colC" } ] ], [ [ "`colA` DESC" ], [ "`colB` DESC" ], [ "`colC` DESC" ] ] ], [ undef, [ "colA" ], [ "colA" ] ], [ undef, [ { "-asc" => "colA" } ], [ [ "colA ASC" ] ] ], [ undef, [ "colB" ], [ "colB" ] ], [ undef, [ [ "colB" ] ], [ "colB" ] ], [ undef, [ { "-desc" => [ "colB" ] } ], [ [ "colB DESC" ] ] ], [ undef, [ "colC" ], [ "colC" ] ], [ undef, [ "colD" ], [ "colD" ] ], [ undef, [ [ "colC", "colD" ] ], [ "colC", "colD" ] ], [ undef, [ { "-asc" => [ "colC", "colD" ] } ], [ [ "colC ASC" ], [ "colD ASC" ] ] ], [ undef, [ [ { "-asc" => "colA" }, { "-desc" => [ "colB" ] }, { "-asc" => [ "colC", "colD" ] } ] ], [ [ "colA ASC" ], [ "colB DESC" ], [ "colC ASC" ], [ "colD ASC" ] ] ], [ "`", [ "colA" ], [ "`colA`" ] ], [ "`", [ { "-asc" => "colA" } ], [ [ "`colA` ASC" ] ] ], [ "`", [ "colB" ], [ "`colB`" ] ], [ "`", [ [ "colB" ] ], [ "`colB`" ] ], [ "`", [ { "-desc" => [ "colB" ] } ], [ [ "`colB` DESC" ] ] ], [ "`", [ "colC" ], [ "`colC`" ] ], [ "`", [ "colD" ], [ "`colD`" ] ], [ "`", [ [ "colC", "colD" ] ], [ "`colC`", "`colD`" ] ], [ "`", [ { "-asc" => [ "colC", "colD" ] } ], [ [ "`colC` ASC" ], [ "`colD` ASC" ] ] ], [ "`", [ [ { "-asc" => "colA" }, { "-desc" => [ "colB" ] }, { "-asc" => [ "colC", "colD" ] } ] ], [ [ "`colA` ASC" ], [ "`colB` DESC" ], [ "`colC` ASC" ], [ "`colD` ASC" ] ] ], [ undef, [ \[ "colA LIKE ?", "test" ] ], [ [ "colA LIKE ?", "test" ] ] ], [ undef, [ { "-desc" => \[ "colA LIKE ?", "test" ] } ], [ [ "colA LIKE ? DESC", "test" ] ] ], [ "`", [ \[ "colA LIKE ?", "test" ] ], [ [ "colA LIKE ?", "test" ] ] ], [ "`", [ { "-desc" => \[ "colA LIKE ?", "test" ] } ], [ [ "colA LIKE ? DESC", "test" ] ] ], [ undef, [ \[ "colA LIKE ? DESC", "test" ] ], [ [ "colA LIKE ? DESC", "test" ] ] ], [ "`", [ \[ "colA LIKE ? DESC", "test" ] ], [ [ "colA LIKE ? DESC", "test" ] ] ], [ undef, [ \[ "colA" ] ], [ [ "colA" ] ] ], [ undef, [ { "-asc" => \[ "colA" ] } ], [ [ "colA ASC" ] ] ], [ undef, [ \[ "colB LIKE ?", "test" ] ], [ [ "colB LIKE ?", "test" ] ] ], [ undef, [ { "-desc" => \[ "colB LIKE ?", "test" ] } ], [ [ "colB LIKE ? DESC", "test" ] ] ], [ undef, [ \[ "colC LIKE ?", "tost" ] ], [ [ "colC LIKE ?", "tost" ] ] ], [ undef, [ { "-asc" => \[ "colC LIKE ?", "tost" ] } ], [ [ "colC LIKE ? ASC", "tost" ] ] ], [ undef, [ [ { "-asc" => \[ "colA" ] }, { "-desc" => \[ "colB LIKE ?", "test" ] }, { "-asc" => \[ "colC LIKE ?", "tost" ] } ] ], [ [ "colA ASC" ], [ "colB LIKE ? DESC", "test" ], [ "colC LIKE ? ASC", "tost" ] ] ], [ "`", [ \[ "colA" ] ], [ [ "colA" ] ] ], [ "`", [ { "-asc" => \[ "colA" ] } ], [ [ "colA ASC" ] ] ], [ "`", [ \[ "colB LIKE ?", "test" ] ], [ [ "colB LIKE ?", "test" ] ] ], [ "`", [ { "-desc" => \[ "colB LIKE ?", "test" ] } ], [ [ "colB LIKE ? DESC", "test" ] ] ], [ "`", [ \[ "colC LIKE ?", "tost" ] ], [ [ "colC LIKE ?", "tost" ] ] ], [ "`", [ { "-asc" => \[ "colC LIKE ?", "tost" ] } ], [ [ "colC LIKE ? ASC", "tost" ] ] ], [ "`", [ [ { "-asc" => \[ "colA" ] }, { "-desc" => \[ "colB LIKE ?", "test" ] }, { "-asc" => \[ "colC LIKE ?", "tost" ] } ] ], [ [ "colA ASC" ], [ "colB LIKE ? DESC", "test" ], [ "colC LIKE ? ASC", "tost" ] ], ], [ undef, [{}], [], ], ); for my $case (@cases) { my ($quote, $expr, $out) = @$case; my $sqla = SQL::Abstract->new({ quote_char => $quote }); if ( @$expr == 1 and ref($expr->[0]) eq 'REF' and ref(${$expr->[0]}) eq 'ARRAY' and @${$expr->[0]} == 1 ) { # \[ 'foo' ] is exactly equivalent to \'foo' and the new code knows that $out = $out->[0]; } my @chunks = $sqla->_order_by_chunks($expr); unless (is(Dumper(\@chunks), Dumper($out))) { diag("Above failure from expr: ".Dumper($expr)); } } done_testing; SQL-Abstract-2.000001/t/15placeholders.t0000644000000000000000000000170311633246437017407 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Tree; { my $sqlat = SQL::Abstract::Tree->new({ fill_in_placeholders => 1, placeholder_surround => [qw(; -)], }); is($sqlat->fill_in_placeholder(['lolz']), q(;lolz-), 'placeholders are populated correctly' ); } { my $sqlat = SQL::Abstract::Tree->new({ fill_in_placeholders => 1, placeholder_surround => [qw(< >)], }); is($sqlat->fill_in_placeholder(['station']), q(), 'placeholders are populated correctly and in order' ); } { my $sqlat = SQL::Abstract::Tree->new({ fill_in_placeholders => 1, placeholder_surround => [qw(' ')], }); is $sqlat->format('SELECT ? AS x, ? AS y FROM Foo WHERE t > ? and z IN (?, ?, ?) ', [qw/frew ribasushi 2008-12-12 1 2 3/]), q[SELECT 'frew' AS x, 'ribasushi' AS y FROM Foo WHERE t > '2008-12-12' AND z IN ( '1', '2', '3' )], 'Complex placeholders work'; } done_testing; SQL-Abstract-2.000001/t/12format_keyword.t0000644000000000000000000000101513340604110017746 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new({ colormap => { select => ['s(', ')s'], where => ['w(', ')w'], from => ['f(', ')f'], join => ['j(', ')f'], on => ['o(', ')o'], 'group by' => ['gb(',')gb'], 'order by' => ['ob(',')ob'], }, }); for ( keys %{$sqlat->colormap}) { my ($l, $r) = @{$sqlat->colormap->{$_}}; is($sqlat->format_keyword($_), "$l$_$r", "$_ 'colored' correctly"); } done_testing; SQL-Abstract-2.000001/t/05in_between.t0000644000000000000000000003226514002362432017052 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where dumper)]; use SQL::Abstract; my @in_between_tests = ( { where => { x => { -between => [1, 2] } }, stmt => 'WHERE (x BETWEEN ? AND ?)', bind => [qw/1 2/], test => '-between with two placeholders', }, { where => { x => { -between => [\"1", 2] } }, stmt => 'WHERE (x BETWEEN 1 AND ?)', bind => [qw/2/], test => '-between with one literal sql arg and one placeholder', }, { where => { x => { -between => [1, \"2"] } }, stmt => 'WHERE (x BETWEEN ? AND 2)', bind => [qw/1/], test => '-between with one placeholder and one literal sql arg', }, { where => { x => { -between => [\'current_date - 1', \'current_date - 0'] } }, stmt => 'WHERE (x BETWEEN current_date - 1 AND current_date - 0)', bind => [], test => '-between with two literal sql arguments', }, { where => { x => { -between => [ \['current_date - ?', 1], \['current_date - ?', 0] ] } }, stmt => 'WHERE (x BETWEEN current_date - ? AND current_date - ?)', bind => [1, 0], test => '-between with two literal sql arguments with bind', }, { where => { x => { -between => \['? AND ?', 1, 2] } }, stmt => 'WHERE (x BETWEEN ? AND ?)', bind => [1,2], test => '-between with literal sql with placeholders (\["? AND ?", scalar, scalar])', }, { where => { x => { -between => \["'something' AND ?", 2] } }, stmt => "WHERE (x BETWEEN 'something' AND ?)", bind => [2], test => '-between with literal sql with one literal arg and one placeholder (\["\'something\' AND ?", scalar])', }, { where => { x => { -between => \["? AND 'something'", 1] } }, stmt => "WHERE (x BETWEEN ? AND 'something')", bind => [1], test => '-between with literal sql with one placeholder and one literal arg (\["? AND \'something\'", scalar])', }, { where => { x => { -between => \"'this' AND 'that'" } }, stmt => "WHERE (x BETWEEN 'this' AND 'that')", bind => [], test => '-between with literal sql with a literal (\"\'this\' AND \'that\'")', }, # generate a set of invalid -between tests ( map { { where => { x => { -between => $_ } }, test => 'invalid -between args', throws => qr|Operator 'BETWEEN' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref|, } } ( [ 1, 2, 3 ], [ 1, undef, 3 ], [ undef, 2, 3 ], [ 1, 2, undef ], [ 1, undef ], [ undef, 2 ], [ undef, undef ], [ 1 ], [ undef ], [], 1, undef, )), { where => { start0 => { -between => [ 1, { -upper => 2 } ] }, start1 => { -between => \["? AND ?", 1, 2] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", 'stuff' ], ] }, }, stmt => "WHERE ( ( start0 BETWEEN ? AND UPPER(?) ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )", bind => [1, 2, 1, 2, 'stuff'], test => '-between POD test', }, { args => { restore_old_unop_handling => 1 }, where => { start0 => { -between => [ 1, { -upper => 2 } ] }, start1 => { -between => \["? AND ?", 1, 2] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", 'stuff' ], ] }, }, stmt => "WHERE ( ( start0 BETWEEN ? AND UPPER ? ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )", bind => [1, 2, 1, 2, 'stuff'], test => '-between POD test', }, { args => { bindtype => 'columns' }, where => { start0 => { -between => [ 1, { -upper => 2 } ] }, start1 => { -between => \["? AND ?", [ start1 => 1], [start1 => 2] ] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", [ start3 => 'stuff'] ], ] }, }, stmt => "WHERE ( ( start0 BETWEEN ? AND UPPER(?) ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )", bind => [ [ start0 => 1 ], [ start0 => 2 ], [ start1 => 1 ], [ start1 => 2 ], [ start3 => 'stuff' ], ], test => '-between POD test', }, { args => { restore_old_unop_handling => 1, bindtype => 'columns' }, where => { start0 => { -between => [ 1, { -upper => 2 } ] }, start1 => { -between => \["? AND ?", [ start1 => 1], [start1 => 2] ] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", [ start3 => 'stuff'] ], ] }, }, stmt => "WHERE ( ( start0 BETWEEN ? AND UPPER ? ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )", bind => [ [ start0 => 1 ], [ start0 => 2 ], [ start1 => 1 ], [ start1 => 2 ], [ start3 => 'stuff' ], ], test => '-between POD test', }, { where => { 'test1.a' => { 'In', ['boom', 'bang'] } }, stmt => ' WHERE ( test1.a IN ( ?, ? ) )', bind => ['boom', 'bang'], test => 'In (no dash, initial cap) with qualified column', }, { where => { a => { 'between', ['boom', 'bang'] } }, stmt => ' WHERE ( a BETWEEN ? AND ? )', bind => ['boom', 'bang'], test => 'between (no dash) with two placeholders', }, { where => { x => { -in => [ 1 .. 3] } }, stmt => "WHERE x IN (?, ?, ?)", bind => [ 1 .. 3 ], test => '-in with an array of scalars', }, { where => { x => { -in => [] } }, stmt => "WHERE 0=1", bind => [], test => '-in with an empty array', }, { where => { x => { -in => \'( 1,2,lower(y) )' } }, stmt => "WHERE x IN ( 1,2,lower(y) )", bind => [], test => '-in with a literal scalarref', }, # note that outer parens are opened even though literal was requested below { where => { x => { -in => \['( ( ?,?,lower(y) ) )', 1, 2] } }, stmt => "WHERE x IN ( ?,?,lower(y) )", bind => [1, 2], test => '-in with a literal arrayrefref', }, { where => { status => { -in => \"(SELECT status_codes\nFROM states)" }, }, stmt => " WHERE status IN ( SELECT status_codes FROM states )", bind => [], test => '-in multi-line subquery test', }, # check that the outer paren opener is not too agressive # note: this syntax *is not legal* on SQLite (maybe others) # see end of https://rt.cpan.org/Ticket/Display.html?id=99503 { where => { foo => { -in => \ '(SELECT 1) UNION (SELECT 2)' } }, stmt => 'WHERE foo IN ( (SELECT 1) UNION (SELECT 2) )', bind => [], test => '-in paren-opening works on balanced pairs only', }, { where => { customer => { -in => \[ 'SELECT cust_id FROM cust WHERE balance > ?', 2000, ]}, status => { -in => \'SELECT status_codes FROM states' }, }, stmt => " WHERE customer IN ( SELECT cust_id FROM cust WHERE balance > ? ) AND status IN ( SELECT status_codes FROM states ) ", bind => [2000], test => '-in POD test', }, { where => { x => { -in => [ \['LOWER(?)', 'A' ], \'LOWER(b)', { -lower => 'c' } ] } }, stmt => " WHERE ( x IN ( LOWER(?), LOWER(b), LOWER(?) ) )", bind => [qw/A c/], test => '-in with an array of function array refs with args', }, { args => { restore_old_unop_handling => 1 }, where => { x => { -in => [ \['LOWER(?)', 'A' ], \'LOWER(b)', { -lower => 'c' } ] } }, stmt => " WHERE ( x IN ( LOWER(?), LOWER(b), LOWER ? ) )", bind => [qw/A c/], test => '-in with an array of function array refs with args', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { x => { -in => [ 1, undef ] } }, stmt => " WHERE ( x IN ( ? ) OR x IS NULL )", bind => [ 1 ], test => '-in with undef as an element', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { x => { -in => [ 1, undef, 2, 3, undef ] } }, stmt => " WHERE ( x IN ( ?, ?, ? ) OR x IS NULL )", bind => [ 1, 2, 3 ], test => '-in with multiple undef elements', }, { where => { a => { -in => 42 }, b => { -not_in => 42 } }, stmt => ' WHERE a IN ( ? ) AND b NOT IN ( ? )', bind => [ 42, 42 ], test => '-in, -not_in with scalar', }, { where => { a => { -in => [] }, b => { -not_in => [] } }, stmt => ' WHERE ( 0=1 AND 1=1 )', bind => [], test => '-in, -not_in with empty arrays', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { a => { -in => [42, undef] }, b => { -not_in => [42, undef] } }, stmt => ' WHERE ( ( a IN ( ? ) OR a IS NULL ) AND b NOT IN ( ? ) AND b IS NOT NULL )', bind => [ 42, 42 ], test => '-in, -not_in with undef among elements', }, { throws => qr/ \QSQL::Abstract before v1.75 used to generate incorrect SQL \E \Qwhen the -IN operator was given an undef-containing list: \E \Q!!!AUDIT YOUR CODE AND DATA!!! (the upcoming Data::Query-based \E \Qversion of SQL::Abstract will emit the logically correct SQL \E \Qinstead of raising this exception)\E /x, where => { a => { -in => [undef] }, b => { -not_in => [undef] } }, stmt => ' WHERE ( a IS NULL AND b IS NOT NULL )', bind => [], test => '-in, -not_in with just undef element', }, { where => { a => { -in => undef } }, throws => qr/Argument passed to the 'IN' operator can not be undefined/, test => '-in with undef argument', }, { where => { -in => [ 'bob', 4, 2 ] }, stmt => ' WHERE (bob IN (?, ?))', bind => [ 4, 2 ], test => 'Top level -in', }, # This works but then SQL::Abstract::Tree breaks - something for a later commit # { # where => { -in => [ { -list => [ qw(x y) ] }, { -list => [ 1, 3 ] }, { -list => [ 2, 4 ] } ] }, # stmt => ' WHERE ((x, y) IN ((?, ?), (?, ?))', # bind => [ 1, 3, 2, 4 ], # test => 'Top level -in with list args', # }, { where => { -between => [42, 69] }, throws => qr/Fatal: Operator 'BETWEEN' requires/, test => 'Top level -between with broken args', }, { where => { -between => [ { -op => [ '+', { -ident => 'foo' }, 2 ] }, 3, 4 ], }, stmt => ' WHERE (foo + ? BETWEEN ? AND ?)', bind => [ 2, 3, 4 ], test => 'Top level -between with useful LHS', }, { where => { -in => [ { -row => [ 'x', 'y' ] }, { -row => [ 1, 2 ] }, { -row => [ 3, 4 ] }, ], }, stmt => ' WHERE (x, y) IN ((?, ?), (?, ?))', bind => [ 1..4 ], test => 'Complex top-level -in', }, { where => { -is => [ 'bob', undef ] }, stmt => ' WHERE bob IS NULL', bind => [], test => 'Top level -is ok', }, { where => { -op => [ in => x => 1, 2, 3 ] }, stmt => ' WHERE x IN (?, ?, ?)', bind => [ 1, 2, 3 ], test => 'Raw -op passes through correctly' }, ); for my $case (@in_between_tests) { TODO: { local $TODO = $case->{todo} if $case->{todo}; local $SQL::Abstract::Test::parenthesis_significant = $case->{parenthesis_significant}; my $label = $case->{test} || 'in-between test'; my $sql = SQL::Abstract->new($case->{args} || {}); if (my $e = $case->{throws}) { my $stmt; throws_ok { ($stmt) = $sql->where($case->{where}) } $e, "$label throws correctly" or diag dumper ({ where => $case->{where}, result => $stmt }); } else { my ($stmt, @bind); lives_ok { warnings_are { ($stmt, @bind) = $sql->where($case->{where}); } [], "$label gives no warnings"; is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind}, "$label generates correct SQL and bind", ) || diag dumper ({ where => $case->{where}, exp => $sql->_expand_expr($case->{where}) }); } || diag dumper ({ where => $case->{where}, exp => $sql->_expand_expr($case->{where}) }); } } } done_testing; SQL-Abstract-2.000001/t/04modifiers.t0000644000000000000000000003207714002362432016714 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Exception; use Test::Warn; use SQL::Abstract::Test import => [qw(is_same_sql_bind diag_where)]; use SQL::Abstract; use Storable 'dclone'; #### WARNING #### # # -nest has been undocumented on purpose, but is still supported for the # foreseable future. Do not rip out the -nest tests before speaking to # someone on the DBIC mailing list or in irc.perl.org#dbix-class # ################# =begin Test -and -or and -nest modifiers, assuming the following: * Modifiers are respected in both hashrefs and arrayrefs (with the obvious limitation of one modifier type per hahsref) * When in condition context i.e. where => { -or => { a = 1 } }, each modifier affects only the immediate element following it. * When in column multi-condition context i.e. where => { x => { '!=', [-and => [qw/1 2 3/]] } }, a modifier affects the OUTER ARRAYREF if and only if it is the first element of said ARRAYREF =cut # no warnings (the -or/-and => { } warning is silly, there is nothing wrong with such usage) my $and_or_args = { and => { stmt => 'WHERE a = ? AND b = ?', bind => [qw/1 2/] }, or => { stmt => 'WHERE a = ? OR b = ?', bind => [qw/1 2/] }, or_and => { stmt => 'WHERE ( foo = ? OR bar = ? ) AND baz = ? ', bind => [qw/1 2 3/] }, or_or => { stmt => 'WHERE foo = ? OR bar = ? OR baz = ?', bind => [qw/1 2 3/] }, and_or => { stmt => 'WHERE ( foo = ? AND bar = ? ) OR baz = ?', bind => [qw/1 2 3/] }, }; my @and_or_tests = ( # basic tests { where => { -and => [a => 1, b => 2] }, %{$and_or_args->{and}}, }, { where => [ -and => [a => 1, b => 2] ], %{$and_or_args->{and}}, }, { where => { -or => [a => 1, b => 2] }, %{$and_or_args->{or}}, }, { where => [ -or => [a => 1, b => 2] ], %{$and_or_args->{or}}, }, { where => { -and => {a => 1, b => 2} }, %{$and_or_args->{and}}, }, { where => [ -and => {a => 1, b => 2} ], %{$and_or_args->{and}}, }, { where => { -or => {a => 1, b => 2} }, %{$and_or_args->{or}}, }, { where => [ -or => {a => 1, b => 2} ], %{$and_or_args->{or}}, }, # test modifiers within hashrefs { where => { -or => [ [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{or_or}}, }, { where => { -and => [ [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{or_and}}, }, # test modifiers within arrayrefs { where => [ -or => [ [ foo => 1, bar => 2 ], baz => 3, ]], %{$and_or_args->{or_or}}, }, { where => [ -and => [ [ foo => 1, bar => 2 ], baz => 3, ]], %{$and_or_args->{or_and}}, }, # test ambiguous modifiers within hashrefs (op extends to to immediate RHS only) { where => { -and => [ -or => [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{or_and}}, }, { where => { -or => [ -and => [ foo => 1, bar => 2 ], baz => 3, ]}, %{$and_or_args->{and_or}}, }, # test ambiguous modifiers within arrayrefs (op extends to to immediate RHS only) { where => [ -and => [ -or => [ foo => 1, bar => 2 ], baz => 3, ]], %{$and_or_args->{or_and}}, }, { where => [ -or => [ -and => [ foo => 1, bar => 2 ], baz => 3 ]], %{$and_or_args->{and_or}}, }, # test column multi-cond in arrayref (useless example) { where => { x => [ -and => (1 .. 3) ] }, stmt => 'WHERE x = ? AND x = ? AND x = ?', bind => [1..3], }, # test column multi-cond in arrayref (more useful) { where => { x => [ -and => {'!=' => 1}, {'!=' => 2}, {'!=' => 3} ] }, stmt => 'WHERE x != ? AND x != ? AND x != ?', bind => [1..3], }, # test column multi-cond in arrayref (even more useful) { where => { x => { '!=' => [ -and => (1 .. 3) ] } }, stmt => 'WHERE x != ? AND x != ? AND x != ?', bind => [1..3], }, # the -or should affect only the inner hashref, as we are not in an outer arrayref { where => { x => { -or => { '!=', 1, '>=', 2 }, -like => 'x%' }}, stmt => 'WHERE x LIKE ? AND ( x != ? OR x >= ? )', bind => [qw/x% 1 2/], }, # the -and should affect the OUTER arrayref, while the internal structures remain intact { where => { x => [ -and => [ 1, 2 ], { -like => 'x%' } ]}, stmt => 'WHERE (x = ? OR x = ?) AND x LIKE ?', bind => [qw/1 2 x%/], }, { where => { -and => [a => 1, b => 2], x => 9, -or => { c => 3, d => 4 } }, stmt => 'WHERE a = ? AND b = ? AND ( c = ? OR d = ? ) AND x = ?', bind => [qw/1 2 3 4 9/], }, { where => { -and => [a => 1, b => 2, k => [11, 12] ], x => 9, -or => { c => 3, d => 4, l => { '=' => [21, 22] } } }, stmt => 'WHERE a = ? AND b = ? AND (k = ? OR k = ?) AND (c = ? OR d = ? OR (l = ? OR l = ?) ) AND x = ?', bind => [qw/1 2 11 12 3 4 21 22 9/], }, { where => { -or => [a => 1, b => 2, k => [11, 12] ], x => 9, -and => { c => 3, d => 4, l => { '=' => [21, 22] } } }, stmt => 'WHERE c = ? AND d = ? AND ( l = ? OR l = ?) AND (a = ? OR b = ? OR k = ? OR k = ?) AND x = ?', bind => [qw/3 4 21 22 1 2 11 12 9/], }, { where => [ -or => [a => 1, b => 2], -or => { c => 3, d => 4}, e => 5, -and => [ f => 6, g => 7], [ h => 8, i => 9, -and => [ k => 10, l => 11] ], { m => 12, n => 13 }], stmt => 'WHERE a = ? OR b = ? OR c = ? OR d = ? OR e = ? OR ( f = ? AND g = ?) OR h = ? OR i = ? OR ( k = ? AND l = ? ) OR (m = ? AND n = ?)', bind => [1 .. 13], }, { # explicit OR logic in arrays should leave everything intact args => { logic => 'or' }, where => { -and => [a => 1, b => 2, k => [11, 12] ], x => 9, -or => { c => 3, d => 4, l => { '=' => [21, 22] } } }, stmt => 'WHERE a = ? AND b = ? AND (k = ? OR k = ?) AND ( c = ? OR d = ? OR l = ? OR l = ? ) AND x = ? ', bind => [qw/1 2 11 12 3 4 21 22 9/], }, { # flip logic in arrays except where excplicitly requested otherwise args => { logic => 'and' }, where => [ -or => [a => 1, b => 2], -or => { c => 3, d => 4}, e => 5, -and => [ f => 6, g => 7], [ h => 8, i => 9, -and => [ k => 10, l => 11] ], { m => 12, n => 13 }], stmt => 'WHERE (a = ? OR b = ?) AND (c = ? OR d = ?) AND e = ? AND f = ? AND g = ? AND h = ? AND i = ? AND k = ? AND l = ? AND m = ? AND n = ?', bind => [1 .. 13], }, # 1st -and is in column mode, thus flips the entire array, whereas the # 2nd one is just a condition modifier { where => [ col => [ -and => {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], -and => [ col2 => [ -or => { -like => 'crap' }, { -like => 'crop' } ], col3 => [ -and => { -like => 'chap' }, { -like => 'chop' } ], ], ], stmt => 'WHERE (col < ? AND col > ? AND col != ?) OR ( ( col2 LIKE ? OR col2 LIKE ? ) AND ( col3 LIKE ? AND col3 LIKE ? ) ) ', bind => [qw/123 456 789 crap crop chap chop/], }, ########## # some corner cases by ldami (some produce useless SQL, just for clarification on 1.5 direction) # { where => { foo => [ -and => [ { -like => 'foo%'}, {'>' => 'moo'} ], { -like => '%bar', '<' => 'baz'}, [ {-like => '%alpha'}, {-like => '%beta'} ], [ {'!=' => 'toto', '=' => 'koko'} ], ] }, stmt => 'WHERE (foo LIKE ? OR foo > ?) AND (foo LIKE ? AND foo < ?) AND (foo LIKE ? OR foo LIKE ?) AND (foo != ? AND foo = ?)', bind => [qw/foo% moo %bar baz %alpha %beta toto koko/], }, { where => [ -and => [a => 1, b => 2], -or => [c => 3, d => 4], e => [-and => {-like => 'foo%'}, {-like => '%bar'} ], ], stmt => 'WHERE (a = ? AND b = ?) OR c = ? OR d = ? OR (e LIKE ? AND e LIKE ?)', bind => [qw/1 2 3 4 foo% %bar/], }, # -or has nothing to flip { where => [-and => [{foo => 1}, {bar => 2}, -or => {baz => 3}] ], stmt => 'WHERE foo = ? AND bar = ? AND baz = ?', bind => [1 .. 3], }, { where => [-and => [{foo => 1}, {bar => 2}, -or => {baz => 3, woz => 4} ] ], stmt => 'WHERE foo = ? AND bar = ? AND (baz = ? OR woz = ?)', bind => [1 .. 4], }, # -and has only 1 following element, thus all still ORed { where => { col => [ -and => [{'<' => 123}, {'>' => 456 }, {'!=' => 789}] ] }, stmt => 'WHERE col < ? OR col > ? OR col != ?', bind => [qw/123 456 789/], }, # flipping array logic affects both column value and condition arrays { args => { logic => 'and' }, where => [ col => [ {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], col2 => 0 ], stmt => 'WHERE col < ? AND col > ? AND col != ? AND col2 = ?', bind => [qw/123 456 789 0/], }, # flipping array logic with explicit -and works { args => { logic => 'and' }, where => [ col => [ -and => {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], col2 => 0 ], stmt => 'WHERE col < ? AND col > ? AND col != ? AND col2 = ?', bind => [qw/123 456 789 0/], }, # flipping array logic with explicit -or flipping it back { args => { logic => 'and' }, where => [ col => [ -or => {'<' => 123}, {'>' => 456 }, {'!=' => 789} ], col2 => 0 ], stmt => 'WHERE (col < ? OR col > ? OR col != ?) AND col2 = ?', bind => [qw/123 456 789 0/], }, ); # modN and mod_N were a bad design decision - they go away in SQLA2, warn now my @numbered_mods = ( { backcompat => { -and => [a => 10, b => 11], -and2 => [ c => 20, d => 21 ], -nest => [ x => 1 ], -nest2 => [ y => 2 ], -or => { m => 7, n => 8 }, -or2 => { m => 17, n => 18 }, }, correct => { -and => [ -and => [a => 10, b => 11], -and => [ c => 20, d => 21 ], -nest => [ x => 1 ], -nest => [ y => 2 ], -or => { m => 7, n => 8 }, -or => { m => 17, n => 18 }, ] }, }, { backcompat => { -and2 => [a => 10, b => 11], -and_3 => [ c => 20, d => 21 ], -nest2 => [ x => 1 ], -nest_3 => [ y => 2 ], -or2 => { m => 7, n => 8 }, -or_3 => { m => 17, n => 18 }, }, correct => [ -and => [ -and => [a => 10, b => 11], -and => [ c => 20, d => 21 ], -nest => [ x => 1 ], -nest => [ y => 2 ], -or => { m => 7, n => 8 }, -or => { m => 17, n => 18 }, ] ], }, ); my @nest_tests = ( { where => {a => 1, -nest => [b => 2, c => 3]}, stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -nest => {b => 2, c => 3}}, stmt => 'WHERE ( ( (b = ? AND c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -or => {-nest => {b => 2, c => 3}}}, stmt => 'WHERE ( ( (b = ? AND c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -or => {-nest => [b => 2, c => 3]}}, stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => {a => 1, -nest => {-or => {b => 2, c => 3}}}, stmt => 'WHERE ( ( (b = ? OR c = ?) AND a = ? ) )', bind => [qw/2 3 1/], }, { where => [a => 1, -nest => {b => 2, c => 3}, -nest => [d => 4, e => 5]], stmt => 'WHERE ( ( a = ? OR ( b = ? AND c = ? ) OR ( d = ? OR e = ? ) ) )', bind => [qw/1 2 3 4 5/], }, ); for my $case (@and_or_tests) { TODO: { local $TODO = $case->{todo} if $case->{todo}; my $sql = SQL::Abstract->new($case->{args} || {}); my $where_copy = dclone($case->{where}); warnings_are { lives_ok { my ($stmt, @bind) = $sql->where($case->{where}); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind}, ) || (diag_where ( $case->{where} ), diag dumper ([ EXP => $sql->_expand_expr($case->{where}) ])); } || (diag_where ( $case->{where} ), diag dumper ([ EXP => $sql->_expand_expr($case->{where}) ])); } [], 'No warnings within and-or tests'; is_deeply ($case->{where}, $where_copy, 'Where conditions unchanged'); } } for my $case (@nest_tests) { TODO: { local $TODO = $case->{todo} if $case->{todo}; local $SQL::Abstract::Test::parenthesis_significant = 1; my $sql = SQL::Abstract->new($case->{args} || {}); lives_ok (sub { my ($stmt, @bind) = $sql->where($case->{where}); is_same_sql_bind( $stmt, \@bind, $case->{stmt}, $case->{bind}, ) || (diag_where ( $case->{where} ), diag dumper ([ EXP => $sql->_expand_expr($case->{where}) ])); }); } } for my $case (@numbered_mods) { TODO: { local $TODO = $case->{todo} if $case->{todo}; # not using Test::Warn here - variable amount of warnings my @w; local $SIG{__WARN__} = sub { push @w, @_ }; my $sql = SQL::Abstract->new($case->{args} || {}); lives_ok { my ($old_s, @old_b) = $sql->where($case->{backcompat}); my ($new_s, @new_b) = $sql->where($case->{correct}); is_same_sql_bind( $old_s, \@old_b, $new_s, \@new_b, 'Backcompat and the correct(tm) syntax result in identical statements', ) || diag_where ( { backcompat => $case->{backcompat}, correct => $case->{correct}, }); }; ok ( (grep { $_ =~ qr/\QUse of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0/ } @w ), 'Warnings were emitted about a mod_N construct'); } } done_testing; SQL-Abstract-2.000001/t/22op_value.t0000644000000000000000000000353113340604277016550 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract; use SQL::Abstract::Test import => [qw/is_same_sql_bind/]; for my $q ('', '"') { for my $col_btype (0,1) { my $sql_maker = SQL::Abstract->new( quote_char => $q, name_sep => $q ? '.' : '', $col_btype ? (bindtype => 'columns') : (), ); my ($sql, @bind) = $sql_maker->select('artist', '*', { arr1 => { -value => [1,2] }, arr2 => { '>', { -value => [3,4] } }, field => [5,6] } ); is_same_sql_bind ( $sql, \@bind, "SELECT * FROM ${q}artist${q} WHERE ${q}arr1${q} = ? AND ${q}arr2${q} > ? AND ( ${q}field${q} = ? OR ${q}field${q} = ? ) ", [ $col_btype ? ( [ arr1 => [ 1, 2 ] ], [ arr2 => [ 3, 4 ] ], [ field => 5 ], [ field => 6 ], ) : ( [ 1, 2 ], [ 3, 4 ], 5, 6, ) ], ); { local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /Supplying an undefined argument to '(?:NOT )?LIKE'/ }; ($sql, @bind) = $sql_maker->where({ c1 => undef, c2 => { -value => undef }, c3 => { '=' => { -value => undef } }, c4 => { '!=' => { -value => undef } }, c5 => { '<>' => { -value => undef } }, c6 => { '-like' => { -value => undef } }, c7 => { '-not_like' => { -value => undef } }, c8 => { 'is' => { -value => undef } }, c9 => { 'is not' => { -value => undef } }, }); is_same_sql_bind ( $sql, \@bind, "WHERE ${q}c1${q} IS NULL AND ${q}c2${q} IS NULL AND ${q}c3${q} IS NULL AND ${q}c4${q} IS NOT NULL AND ${q}c5${q} IS NOT NULL AND ${q}c6${q} IS NULL AND ${q}c7${q} IS NOT NULL AND ${q}c8${q} IS NULL AND ${q}c9${q} IS NOT NULL ", [], ); } }} done_testing; SQL-Abstract-2.000001/t/21op_ident.t0000644000000000000000000000327314002362432016527 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use Test::Exception; use SQL::Abstract; use SQL::Abstract::Test import => [qw/is_same_sql_bind/]; for my $q ('', '"') { my $sql_maker = SQL::Abstract->new( quote_char => $q, name_sep => $q ? '.' : '', ); throws_ok { $sql_maker->where({ foo => { -ident => undef } }) } qr/-ident requires a single plain scalar argument/; throws_ok { local $sql_maker->{disable_old_special_ops} = 1; $sql_maker->where({'-or' => [{'-ident' => 'foo'},'foo']}) } qr/Illegal.*top-level/; throws_ok { local $sql_maker->{disable_old_special_ops} = 1; $sql_maker->where({'-or' => [{'-ident' => 'foo'},{'=' => \'bozz'}]}) } qr/Illegal.*top-level/; my ($sql, @bind) = $sql_maker->select('artist', '*', { 'artist.name' => { -ident => 'artist.pseudonym' } } ); is_same_sql_bind ( $sql, \@bind, "SELECT * FROM ${q}artist${q} WHERE ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q} ", [], ); ($sql, @bind) = $sql_maker->update('artist', { 'artist.name' => { -ident => 'artist.pseudonym' } }, { 'artist.name' => { '!=' => { -ident => 'artist.pseudonym' } } }, ); is_same_sql_bind ( $sql, \@bind, "UPDATE ${q}artist${q} SET ${q}artist${q}.${q}name${q} = ${q}artist${q}.${q}pseudonym${q} WHERE ${q}artist${q}.${q}name${q} != ${q}artist${q}.${q}pseudonym${q} ", [], ); ($sql) = $sql_maker->select( \(my $from = 'foo JOIN bar ON foo.bar_id = bar.id'), [ { -ident => [ 'foo', 'name' ] }, { -ident => [ 'bar', '*' ] } ] ); is_same_sql_bind( $sql, undef, "SELECT ${q}foo${q}.${q}name${q}, ${q}bar${q}.* FROM $from" ); } done_testing; SQL-Abstract-2.000001/t/09refkind.t0000644000000000000000000000167513340604277016374 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract; my $obj = bless {}, "Foo::Bar"; is(SQL::Abstract->_refkind(undef), 'UNDEF', 'UNDEF'); is(SQL::Abstract->_refkind({}), 'HASHREF', 'HASHREF'); is(SQL::Abstract->_refkind([]), 'ARRAYREF', 'ARRAYREF'); is(SQL::Abstract->_refkind(\{}), 'HASHREFREF', 'HASHREFREF'); is(SQL::Abstract->_refkind(\[]), 'ARRAYREFREF', 'ARRAYREFREF'); is(SQL::Abstract->_refkind(\\{}), 'HASHREFREFREF', 'HASHREFREFREF'); is(SQL::Abstract->_refkind(\\[]), 'ARRAYREFREFREF', 'ARRAYREFREFREF'); is(SQL::Abstract->_refkind("foo"), 'SCALAR', 'SCALAR'); is(SQL::Abstract->_refkind(\"foo"), 'SCALARREF', 'SCALARREF'); is(SQL::Abstract->_refkind(\\"foo"), 'SCALARREFREF', 'SCALARREFREF'); # objects are treated like scalars is(SQL::Abstract->_refkind($obj), 'SCALAR', 'SCALAR'); is(SQL::Abstract->_refkind(\$obj), 'SCALARREF', 'SCALARREF'); is(SQL::Abstract->_refkind(\\$obj), 'SCALARREFREF', 'SCALARREFREF'); done_testing; SQL-Abstract-2.000001/t/14roundtrippin.t0000644000000000000000000001070113340604277017471 0ustar00rootroot00000000000000use warnings; use strict; use Test::More; use Test::Exception; use SQL::Abstract::Test import => [qw(is_same_sql dumper)]; use SQL::Abstract::Tree; my $sqlat = SQL::Abstract::Tree->new; my @sql = ( "INSERT INTO artist DEFAULT VALUES", "INSERT INTO artist VALUES ()", "SELECT a, b, c FROM foo WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT COUNT( * ) FROM foo", "SELECT COUNT( * ), SUM( blah ) FROM foo", "SELECT * FROM (SELECT * FROM foobar) WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT * FROM lolz WHERE ( foo.a = 1 ) and foo.b LIKE 'station'", "SELECT [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype] FROM [users_roles] [me] JOIN [roles] [role] ON [role].[id] = [me].[role_id] JOIN [roles_permissions] [role_permissions] ON [role_permissions].[role_id] = [role].[id] JOIN [permissions] [permission] ON [permission].[id] = [role_permissions].[permission_id] JOIN [permissionscreens] [permission_screens] ON [permission_screens].[permission_id] = [permission].[id] JOIN [screens] [screen] ON [screen].[id] = [permission_screens].[screen_id] WHERE ( [me].[user_id] = ? ) GROUP BY [screen].[id], [screen].[name], [screen].[section_id], [screen].[xtype]", "SELECT * FROM foo WHERE NOT EXISTS (SELECT bar FROM baz)", "SELECT * FROM (SELECT SUM (CASE WHEN me.artist = 'foo' THEN 1 ELSE 0 END AS artist_sum) FROM foobar) WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT * FROM (SELECT SUM (CASE WHEN GETUTCDATE() > DATEADD(second, 4 * 60, last_checkin) THEN 1 ELSE 0 END) FROM foobar) WHERE foo.a = 1 and foo.b LIKE 'station'", "SELECT COUNT( * ) FROM foo me JOIN bar rel_bar ON rel_bar.id_bar = me.fk_bar WHERE NOT EXISTS (SELECT inner_baz.id_baz FROM baz inner_baz WHERE ( ( inner_baz.fk_a != ? AND ( fk_bar = me.fk_bar AND name = me.name ) ) ) )", "SELECT foo AS bar FROM baz ORDER BY x + ? DESC, oomph, y - ? DESC, unf, baz.g / ? ASC, buzz * 0 DESC, foo DESC, ickk ASC", "SELECT inner_forum_roles.forum_id FROM forum_roles AS inner_forum_roles LEFT JOIN user_roles AS inner_user_roles USING(user_role_type_id) WHERE inner_user_roles.user_id = users__row.user_id", "SELECT * FROM foo WHERE foo.a @@ to_tsquery('word')", "SELECT * FROM foo ORDER BY name + ?, [me].[id]", "SELECT foo AS bar FROM baz ORDER BY x + ? DESC, baz.g", "SELECT [me].[id], ROW_NUMBER() OVER (ORDER BY (SELECT 1)) AS [rno__row__index] FROM ( SELECT [me].[id] FROM [LogParents] [me]) [me]", # deliberate batshit insanity "SELECT foo FROM bar WHERE > 12", 'SELECT ilike_any_or FROM bar WHERE ( baz ILIKE ANY(?) OR bat ILIKE ANY(?) )', 'SELECT regexp_or FROM bar WHERE ( baz REGEXP ? OR bat REGEXP ? )', ); # FIXME FIXME FIXME # The formatter/unparser accumulated a ton of technical debt, # and I don't have time to fix it all :( Some of the problems: # - format() does an implicit parenthesis unroll for prettyness # which makes it hard to do exact comparisons # - there is no space preservation framework (also makes comparisons # problematic) # - there is no operator case preservation framework either # # So what we do instead is resort to some monkey patching and # lowercasing and stuff to get something we can compare to the # original SQL string # Ugly but somewhat effective for my $orig (@sql) { my $plain_formatted = $sqlat->format($orig); is_same_sql( $plain_formatted, $orig, 'Formatted string is_same_sql()-matched' ); my $ast = $sqlat->parse($orig); my $reassembled = do { no warnings 'redefine'; local *SQL::Abstract::Tree::_parenthesis_unroll = sub {}; $sqlat->unparse($ast); }; # deal with whitespace around parenthesis readjustment $_ =~ s/ \s* ( [ \(\) ] ) \s* /$1/gx for ($orig, $reassembled); is ( lc($reassembled), lc($orig), sprintf( 'roundtrip works (%s...)', substr $orig, 0, 20 ) ) or do { my ($ast1, $ast2) = map { dumper( $sqlat->parse($_) ) } ( $orig, $reassembled ); note "ast1: $ast1"; note "ast2: $ast2"; }; } # this is invalid SQL, we are just checking that the parser # does not inadvertently make it right my $sql = 'SELECT * FROM foo WHERE x IN ( ( 1 ) )'; is( $sqlat->unparse($sqlat->parse($sql)), $sql, 'Multi-parens around IN survive', ); lives_ok { $sqlat->unparse( $sqlat->parse( <<'EOS' ) ) } 'Able to parse/unparse grossly malformed sql'; SELECT ( SELECT *, * FROM EXISTS bar JOIN ON a = b NOT WHERE c !!= d ), NOT x, ( SELECT * FROM bar WHERE NOT NOT EXISTS (SELECT 1) ), WHERE NOT NOT 1 AND OR foo IN (1,2,,,3,,,), GROUP BY bar EOS done_testing; SQL-Abstract-2.000001/t/16no_sideeffects.t0000644000000000000000000000070511603625623017717 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Tree; ok my $placeholders = [100,'xxx']; ok my $sqlat = SQL::Abstract::Tree->new({profile=>'html'}); ok my $out = $sqlat->format('SELECT * FROM bar WHERE x = ?', $placeholders); is scalar(@$placeholders), 2, 'correct number of placeholders'; is $placeholders->[0], 100, 'did not mess up a placeholder'; is $placeholders->[1], 'xxx', 'did not mess up a placeholder'; done_testing; SQL-Abstract-2.000001/t/23_is_X_value.t0000644000000000000000000001352213340604277017175 0ustar00rootroot00000000000000use warnings; use strict; use Test::More; use Test::Exception; use Scalar::Util 'refaddr'; use Storable 'nfreeze'; BEGIN { $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} = 0 } use SQL::Abstract qw(is_plain_value is_literal_value); # fallback setting is inheriting starting p5 50853fa9 (run up to 5.17.0) use constant OVERLOAD_FALLBACK_INHERITS => ( ($] < 5.017) ? 0 : 1 ); use constant STRINGIFIER_CAN_RETURN_IVS => ( ($] < 5.008) ? 0 : 1 ); { package # hideee SQLATest::SillyBool; use overload # *DELIBERATELY* unspecified #fallback => 1, bool => sub { ${$_[0]} }, ; package # hideee SQLATest::SillyBool::Subclass; our @ISA = 'SQLATest::SillyBool'; } { package # hideee SQLATest::SillyInt; use overload # *DELIBERATELY* unspecified #fallback => 1, '0+' => sub { ${$_[0]} }, ; package # hideee SQLATest::SillyInt::Subclass; our @ISA = 'SQLATest::SillyInt'; } { package # hideee SQLATest::SillierInt; use overload fallback => 0, ; package # hideee SQLATest::SillierInt::Subclass; use overload '0+' => sub { ${$_[0]} }, '+' => sub { ${$_[0]} + $_[1] }, ; our @ISA = 'SQLATest::SillierInt'; } { package # hideee SQLATest::AnalInt; use overload fallback => 0, '0+' => sub { ${$_[0]} }, ; package # hideee SQLATest::AnalInt::Subclass; use overload '0+' => sub { ${$_[0]} }, ; our @ISA = 'SQLATest::AnalInt'; } { package # hidee SQLATest::ReasonableInt; # make it match JSON::PP::Boolean use overload '0+' => sub { ${$_[0]} }, '++' => sub { $_[0] = ${$_[0]} + 1 }, '--' => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1, ; package # hideee SQLATest::ReasonableInt::Subclass; our @ISA = 'SQLATest::ReasonableInt'; } { package # hidee SQLATest::ReasonableString; # somewhat like DateTime use overload 'fallback' => 1, '""' => sub { "${$_[0]}" }, '-' => sub { ${$_[0]} - $_[1] }, '+' => sub { ${$_[0]} + $_[1] }, ; package # hideee SQLATest::ReasonableString::Subclass; our @ISA = 'SQLATest::ReasonableString'; } for my $case ( { class => 'SQLATest::SillyBool', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillyBool::Subclass', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillyInt', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillyInt::Subclass', can_math => 0, should_str => 1 }, { class => 'SQLATest::SillierInt', can_math => 0, should_str => 0 }, { class => 'SQLATest::SillierInt::Subclass',can_math => 1, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, { class => 'SQLATest::AnalInt', can_math => 0, should_str => 0 }, { class => 'SQLATest::AnalInt::Subclass', can_math => 0, should_str => (OVERLOAD_FALLBACK_INHERITS ? 0 : 1) }, { class => 'SQLATest::ReasonableInt', can_math => 1, should_str => 1 }, { class => 'SQLATest::ReasonableInt::Subclass', can_math => 1, should_str => 1 }, { class => 'SQLATest::ReasonableString', can_math => 1, should_str => 1 }, { class => 'SQLATest::ReasonableString::Subclass',can_math => 1, should_str => 1 }, ) { my $num = bless( \do { my $foo = 42 }, $case->{class} ); my $can_str = eval { "$num" eq 42 } || 0; ok ( !($can_str xor $case->{should_str}), "should_str setting for $case->{class} matches perl behavior", ) || diag explain { %$case, can_str => $can_str }; my $can_math = eval { ($num + 1) == 43 } ? 1 : 0; ok ( !($can_math xor $case->{can_math}), "can_math setting for $case->{class} matches perl behavior", ) || diag explain { %$case, actual_can_math => $can_math }; my $can_cmp = eval { my $dum = ($num eq "nope"); 1 } || 0; for (1,2) { if ($can_str) { ok $num, 'bool ctx works'; if (STRINGIFIER_CAN_RETURN_IVS and $can_cmp) { is_deeply( is_plain_value $num, \$num, "stringification detected on $case->{class}", ) || diag explain $case; } else { # is_deeply does not do nummify/stringify cmps properly # but we can always compare the ice ok( ( nfreeze( is_plain_value $num ) eq nfreeze( \$num ) ), "stringification without cmp capability detected on $case->{class}" ) || diag explain $case; } is ( refaddr( ${is_plain_value($num)} ), refaddr $num, "Same reference (blessed object) returned", ); } else { is( is_plain_value($num), undef, "non-stringifiable $case->{class} object detected" ) || diag explain $case; } if ($case->{can_math}) { is ($num+1, 43); } } } lives_ok { my $num = bless( \do { my $foo = 23 }, 'SQLATest::ReasonableInt' ); cmp_ok(++$num, '==', 24, 'test overloaded object compares correctly'); cmp_ok(--$num, 'eq', 23, 'test overloaded object compares correctly'); is_deeply( is_plain_value $num, \23, 'fallback stringification detected' ); cmp_ok(--$num, 'eq', 22, 'test overloaded object compares correctly'); cmp_ok(++$num, '==', 23, 'test overloaded object compares correctly'); } 'overload testing lives'; is_deeply is_plain_value { -value => [] }, \[], '-value recognized' ; for ([], {}, \'') { is is_plain_value $_, undef, 'nonvalues correctly recognized' ; } for (undef, { -value => undef }) { is_deeply is_plain_value $_, \undef, 'NULL -value recognized' ; } is_deeply is_literal_value \'sql', [ 'sql' ], 'literal correctly recognized and unpacked' ; is_deeply is_literal_value \[ 'sql', 'bind1', [ {} => 'bind2' ] ], [ 'sql', 'bind1', [ {} => 'bind2' ] ], 'literal with binds correctly recognized and unpacked' ; for ([], {}, \'', undef) { is is_literal_value { -ident => $_ }, undef, 'illegal -ident does not trip up detection' ; } done_testing; SQL-Abstract-2.000001/t/07subqueries.t0000644000000000000000000000511313340604110017110 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Test import => ['is_same_sql_bind']; use SQL::Abstract; #### WARNING #### # # -nest has been undocumented on purpose, but is still supported for the # foreseable future. Do not rip out the -nest tests before speaking to # someone on the DBIC mailing list or in irc.perl.org#dbix-class # ################# my $sql = SQL::Abstract->new; my (@tests, $sub_stmt, @sub_bind, $where); #1 ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); $where = { foo => 1234, bar => \["IN ($sub_stmt)" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )", bind => [100, "foo%", 1234], }; #2 ($sub_stmt, @sub_bind) = $sql->select("t1", "c1", {c2 => {"<" => 100}, c3 => {-like => "foo%"}}); $where = { foo => 1234, bar => \["> ALL ($sub_stmt)" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE (( c2 < ? AND c3 LIKE ? )) ) AND foo = ? )", bind => [100, "foo%", 1234], }; #3 ($sub_stmt, @sub_bind) = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); $where = { foo => 1234, -nest => \["EXISTS ($sub_stmt)" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )", bind => [1, 1234], }; #4 $where = { -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"], }; push @tests, { where => $where, stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )", bind => ["apples"], }; #5 ($sub_stmt, @sub_bind) = $sql->where({age => [{"<" => 10}, {">" => 20}]}); $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause $where = { lname => {-like => '%son%'}, -nest => \["NOT ( $sub_stmt )" => @sub_bind], }; push @tests, { where => $where, stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )", bind => [10, 20, '%son%'], }; #6 ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); $where = { foo => 1234, bar => { -in => \[$sub_stmt => @sub_bind] }, }; push @tests, { where => $where, stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )", bind => [100, "foo%", 1234], }; for (@tests) { my($stmt, @bind) = $sql->where($_->{where}, $_->{order}); is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind}); } done_testing; SQL-Abstract-2.000001/t/12confmerge.t0000644000000000000000000000111511603625623016674 0ustar00rootroot00000000000000use strict; use warnings; use Test::More; use SQL::Abstract::Tree; my $tree = SQL::Abstract::Tree->new({ profile => 'console', colormap => { select => undef, 'group by' => ['yo', 'seph'] , }, }); is $tree->newline, "\n", 'console profile appears to have been used'; ok !defined $tree->colormap->{select}, 'select correctly got undefined from colormap'; ok eq_array($tree->colormap->{'group by'}, [qw(yo seph)]), 'group by correctly got overridden'; ok ref $tree->colormap->{'order by'}, 'but the rest of the colormap does not get blown away'; done_testing; SQL-Abstract-2.000001/xt/0000755000000000000000000000000014002747454014574 5ustar00rootroot00000000000000SQL-Abstract-2.000001/xt/90pod.t0000644000000000000000000000012413340604277015710 0ustar00rootroot00000000000000use warnings; use strict; use Test::More; use Test::Pod 1.14; all_pod_files_ok(); SQL-Abstract-2.000001/xt/92whitespace.t0000644000000000000000000000254113340604277017271 0ustar00rootroot00000000000000use warnings; use strict; use Test::More; use File::Glob 'bsd_glob'; use Test::EOL 1.0 (); use Test::NoTabs 0.9 (); # FIXME - temporary workaround for RT#82032, RT#82033 # also add all scripts (no extension) and some extra extensions # we want to check { no warnings 'redefine'; my $is_pm = sub { $_[0] !~ /\./ || $_[0] =~ /\.(?:pm|pod|skip|bash|sql|json|proto)$/i || $_[0] =~ /::/; }; *Test::EOL::_is_perl_module = $is_pm; *Test::NoTabs::_is_perl_module = $is_pm; } my @pl_targets = qw/t lib examples/; Test::EOL::all_perl_files_ok({ trailing_whitespace => 1 }, @pl_targets); Test::NoTabs::all_perl_files_ok(@pl_targets); # check some non-"perl files" in the root separately # use .gitignore as a guide of what to skip # (or do not test at all if no .gitignore is found) if (open(my $gi, '<', '.gitignore')) { my $skipnames; while (my $ln = <$gi>) { next if $ln =~ /^\s*$/; chomp $ln; $skipnames->{$_}++ for bsd_glob($ln); } # that we want to check anyway delete $skipnames->{'META.yml'}; for my $fn (bsd_glob('*')) { next if $skipnames->{$fn}; next unless -f $fn; Test::EOL::eol_unix_ok($fn, { trailing_whitespace => 1 }); Test::NoTabs::notabs_ok($fn); } } # FIXME - Test::NoTabs and Test::EOL declare 'no_plan' which conflicts with done_testing # https://github.com/schwern/test-more/issues/14 #done_testing; SQL-Abstract-2.000001/xt/91podcoverage.t0000644000000000000000000000306014002362432017415 0ustar00rootroot00000000000000use warnings; use strict; use Test::More; use Pod::Coverage 0.19; use Test::Pod::Coverage 1.04; my @modules = sort { $a cmp $b } ( Test::Pod::Coverage::all_modules() ); # Since this is about checking documentation, a little documentation # of what this is doing might be in order... # The exceptions structure below is a hash keyed by the module # name. The value for each is a hash, which contains one or more # (although currently more than one makes no sense) of the following # things:- # skip => a true value means this module is not checked # ignore => array ref containing list of methods which # do not need to be documented. my $exceptions = { 'SQL::Abstract' => { ignore => [qw( belch puke DETECT_AUTOGENERATED_STRINGIFICATION )]}, 'SQL::Abstract::Tree' => { ignore => [qw(BUILDARGS)] }, 'SQL::Abstract::Test' => { skip => 1 }, 'SQL::Abstract::Formatter' => { skip => 1 }, 'SQL::Abstract::Parts' => { skip => 1 }, 'DBIx::Class::Storage::Debug::PrettyPrint' => { skip => 1 }, }; foreach my $module (@modules) { SKIP: { skip "$module - No user visible methods", 1 if ( $exceptions->{$module}{skip} ); # build parms up from ignore list my $parms = {}; $parms->{trustme} = [ map { qr/^$_$/ } @{ $exceptions->{$module}{ignore} } ] if exists( $exceptions->{$module}{ignore} ); # run the test with the potentially modified parm set pod_coverage_ok( $module, $parms, "$module POD coverage" ); } } done_testing; SQL-Abstract-2.000001/README0000644000000000000000000015774114002747454015040 0ustar00rootroot00000000000000NAME SQL::Abstract - Generate SQL from Perl data structures SYNOPSIS use SQL::Abstract; my $sql = SQL::Abstract->new; my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order); my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values); my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where); my($stmt, @bind) = $sql->delete($table, \%where); # Then, use these in your DBI statements my $sth = $dbh->prepare($stmt); $sth->execute(@bind); # Just generate the WHERE clause my($stmt, @bind) = $sql->where(\%where, $order); # Return values in the same order, for hashed queries # See PERFORMANCE section for more details my @bind = $sql->values(\%fieldvals); DESCRIPTION This module was inspired by the excellent DBIx::Abstract. However, in using that module I found that what I really wanted to do was generate SQL, but still retain complete control over my statement handles and use the DBI interface. So, I set out to create an abstract SQL generation module. While based on the concepts used by DBIx::Abstract, there are several important differences, especially when it comes to WHERE clauses. I have modified the concepts used to make the SQL easier to generate from Perl data structures and, IMO, more intuitive. The underlying idea is for this module to do what you mean, based on the data structures you provide it. The big advantage is that you don't have to modify your code every time your data changes, as this module figures it out. To begin with, an SQL INSERT is as easy as just specifying a hash of "key=value" pairs: my %data = ( name => 'Jimbo Bobson', phone => '123-456-7890', address => '42 Sister Lane', city => 'St. Louis', state => 'Louisiana', ); The SQL can then be generated with this: my($stmt, @bind) = $sql->insert('people', \%data); Which would give you something like this: $stmt = "INSERT INTO people (address, city, name, phone, state) VALUES (?, ?, ?, ?, ?)"; @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson', '123-456-7890', 'Louisiana'); These are then used directly in your DBI code: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); Inserting and Updating Arrays If your database has array types (like for example Postgres), activate the special option "array_datatypes => 1" when creating the "SQL::Abstract" object. Then you may use an arrayref to insert and update database array types: my $sql = SQL::Abstract->new(array_datatypes => 1); my %data = ( planets => [qw/Mercury Venus Earth Mars/] ); my($stmt, @bind) = $sql->insert('solar_system', \%data); This results in: $stmt = "INSERT INTO solar_system (planets) VALUES (?)" @bind = (['Mercury', 'Venus', 'Earth', 'Mars']); Inserting and Updating SQL In order to apply SQL functions to elements of your %data you may specify a reference to an arrayref for the given hash value. For example, if you need to execute the Oracle "to_date" function on a value, you can say something like this: my %data = ( name => 'Bill', date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ], ); The first value in the array is the actual SQL. Any other values are optional and would be included in the bind values array. This gives you: my($stmt, @bind) = $sql->insert('people', \%data); $stmt = "INSERT INTO people (name, date_entered) VALUES (?, to_date(?,'MM/DD/YYYY'))"; @bind = ('Bill', '03/02/2003'); An UPDATE is just as easy, all you change is the name of the function: my($stmt, @bind) = $sql->update('people', \%data); Notice that your %data isn't touched; the module will generate the appropriately quirky SQL for you automatically. Usually you'll want to specify a WHERE clause for your UPDATE, though, which is where handling %where hashes comes in handy... Complex where statements This module can generate pretty complicated WHERE statements easily. For example, simple "key=value" pairs are taken to mean equality, and if you want to see if a field is within a set of values, you can use an arrayref. Let's say we wanted to SELECT some data based on this criteria: my %where = ( requestor => 'inna', worker => ['nwiger', 'rcwe', 'sfz'], status => { '!=', 'completed' } ); my($stmt, @bind) = $sql->select('tickets', '*', \%where); The above would give you something like this: $stmt = "SELECT * FROM tickets WHERE ( requestor = ? ) AND ( status != ? ) AND ( worker = ? OR worker = ? OR worker = ? )"; @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz'); Which you could then use in DBI code like so: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); Easy, eh? METHODS The methods are simple. There's one for every major SQL operation, and a constructor you use first. The arguments are specified in a similar order for each method (table, then fields, then a where clause) to try and simplify things. new(option => 'value') The "new()" function takes a list of options and values, and returns a new SQL::Abstract object which can then be used to generate SQL through the methods below. The options accepted are: case If set to 'lower', then SQL will be generated in all lowercase. By default SQL is generated in "textbook" case meaning something like: SELECT a_field FROM a_table WHERE some_field LIKE '%someval%' Any setting other than 'lower' is ignored. cmp This determines what the default comparison operator is. By default it is "=", meaning that a hash like this: %where = (name => 'nwiger', email => 'nate@wiger.org'); Will generate SQL like this: WHERE name = 'nwiger' AND email = 'nate@wiger.org' However, you may want loose comparisons by default, so if you set "cmp" to "like" you would get SQL such as: WHERE name like 'nwiger' AND email like 'nate@wiger.org' You can also override the comparison on an individual basis - see the huge section on "WHERE CLAUSES" at the bottom. sqltrue, sqlfalse Expressions for inserting boolean values within SQL statements. By default these are "1=1" and "1=0". They are used by the special operators "-in" and "-not_in" for generating correct SQL even when the argument is an empty array (see below). logic This determines the default logical operator for multiple WHERE statements in arrays or hashes. If absent, the default logic is "or" for arrays, and "and" for hashes. This means that a WHERE array of the form: @where = ( event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'}, ); will generate SQL like this: WHERE event_date >= '2/13/99' OR event_date <= '4/24/03' This is probably not what you want given this query, though (look at the dates). To change the "OR" to an "AND", simply specify: my $sql = SQL::Abstract->new(logic => 'and'); Which will change the above "WHERE" to: WHERE event_date >= '2/13/99' AND event_date <= '4/24/03' The logic can also be changed locally by inserting a modifier in front of an arrayref: @where = (-and => [event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'} ]); See the "WHERE CLAUSES" section for explanations. convert This will automatically convert comparisons using the specified SQL function for both column and value. This is mostly used with an argument of "upper" or "lower", so that the SQL will have the effect of case-insensitive "searches". For example, this: $sql = SQL::Abstract->new(convert => 'upper'); %where = (keywords => 'MaKe iT CAse inSeNSItive'); Will turn out the following SQL: WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive') The conversion can be "upper()", "lower()", or any other SQL function that can be applied symmetrically to fields (actually SQL::Abstract does not validate this option; it will just pass through what you specify verbatim). bindtype This is a kludge because many databases suck. For example, you can't just bind values using DBI's "execute()" for Oracle "CLOB" or "BLOB" fields. Instead, you have to use "bind_param()": $sth->bind_param(1, 'reg data'); $sth->bind_param(2, $lots, {ora_type => ORA_CLOB}); The problem is, SQL::Abstract will normally just return a @bind array, which loses track of which field each slot refers to. Fear not. If you specify "bindtype" in new, you can determine how @bind is returned. Currently, you can specify either "normal" (default) or "columns". If you specify "columns", you will get an array that looks like this: my $sql = SQL::Abstract->new(bindtype => 'columns'); my($stmt, @bind) = $sql->insert(...); @bind = ( [ 'column1', 'value1' ], [ 'column2', 'value2' ], [ 'column3', 'value3' ], ); You can then iterate through this manually, using DBI's "bind_param()". $sth->prepare($stmt); my $i = 1; for (@bind) { my($col, $data) = @$_; if ($col eq 'details' || $col eq 'comments') { $sth->bind_param($i, $data, {ora_type => ORA_CLOB}); } elsif ($col eq 'image') { $sth->bind_param($i, $data, {ora_type => ORA_BLOB}); } else { $sth->bind_param($i, $data); } $i++; } $sth->execute; # execute without @bind now Now, why would you still use SQL::Abstract if you have to do this crap? Basically, the advantage is still that you don't have to care which fields are or are not included. You could wrap that above "for" loop in a simple sub called "bind_fields()" or something and reuse it repeatedly. You still get a layer of abstraction over manual SQL specification. Note that if you set "bindtype" to "columns", the "\[ $sql, @bind ]" construct (see "Literal SQL with placeholders and bind values (subqueries)") will expect the bind values in this format. quote_char This is the character that a table or column name will be quoted with. By default this is an empty string, but you could set it to the character "`", to generate SQL like this: SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%' Alternatively, you can supply an array ref of two items, the first being the left hand quote character, and the second the right hand quote character. For example, you could supply "['[',']']" for SQL Server 2000 compliant quotes that generates SQL like this: SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%' Quoting is useful if you have tables or columns names that are reserved words in your database's SQL dialect. escape_char This is the character that will be used to escape "quote_char"s appearing in an identifier before it has been quoted. The parameter default in case of a single "quote_char" character is the quote character itself. When opening-closing-style quoting is used ("quote_char" is an arrayref) this parameter defaults to the closing (right) "quote_char". Occurrences of the opening (left) "quote_char" within the identifier are currently left untouched. The default for opening-closing-style quotes may change in future versions, thus you are strongly encouraged to specify the escape character explicitly. name_sep This is the character that separates a table and column name. It is necessary to specify this when the "quote_char" option is selected, so that tables and column names can be individually quoted like this: SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1 injection_guard A regular expression "qr/.../" that is applied to any "-function" and unquoted column name specified in a query structure. This is a safety mechanism to avoid injection attacks when mishandling user input e.g.: my %condition_as_column_value_pairs = get_values_from_user(); $sqla->select( ... , \%condition_as_column_value_pairs ); If the expression matches an exception is thrown. Note that literal SQL supplied via "\'...'" or "\['...']" is not checked in any way. Defaults to checking for ";" and the "GO" keyword (TransactSQL) array_datatypes When this option is true, arrayrefs in INSERT or UPDATE are interpreted as array datatypes and are passed directly to the DBI layer. When this option is false, arrayrefs are interpreted as literal SQL, just like refs to arrayrefs (but this behavior is for backwards compatibility; when writing new queries, use the "reference to arrayref" syntax for literal SQL). special_ops Takes a reference to a list of "special operators" to extend the syntax understood by SQL::Abstract. See section "SPECIAL OPERATORS" for details. unary_ops Takes a reference to a list of "unary operators" to extend the syntax understood by SQL::Abstract. See section "UNARY OPERATORS" for details. insert($table, \@values || \%fieldvals, \%options) This is the simplest function. You simply give it a table name and either an arrayref of values or hashref of field/value pairs. It returns an SQL INSERT statement and a list of bind values. See the sections on "Inserting and Updating Arrays" and "Inserting and Updating SQL" for information on how to insert with those data types. The optional "\%options" hash reference may contain additional options to generate the insert SQL. Currently supported options are: returning Takes either a scalar of raw SQL fields, or an array reference of field names, and adds on an SQL "RETURNING" statement at the end. This allows you to return data generated by the insert statement (such as row IDs) without performing another "SELECT" statement. Note, however, this is not part of the SQL standard and may not be supported by all database engines. update($table, \%fieldvals, \%where, \%options) This takes a table, hashref of field/value pairs, and an optional hashref WHERE clause. It returns an SQL UPDATE function and a list of bind values. See the sections on "Inserting and Updating Arrays" and "Inserting and Updating SQL" for information on how to insert with those data types. The optional "\%options" hash reference may contain additional options to generate the update SQL. Currently supported options are: returning See the "returning" option to insert. select($source, $fields, $where, $order) This returns a SQL SELECT statement and associated list of bind values, as specified by the arguments: $source Specification of the 'FROM' part of the statement. The argument can be either a plain scalar (interpreted as a table name, will be quoted), or an arrayref (interpreted as a list of table names, joined by commas, quoted), or a scalarref (literal SQL, not quoted). $fields Specification of the list of fields to retrieve from the source. The argument can be either an arrayref (interpreted as a list of field names, will be joined by commas and quoted), or a plain scalar (literal SQL, not quoted). Please observe that this API is not as flexible as that of the first argument $source, for backwards compatibility reasons. $where Optional argument to specify the WHERE part of the query. The argument is most often a hashref, but can also be an arrayref or plain scalar -- see section WHERE clause for details. $order Optional argument to specify the ORDER BY part of the query. The argument can be a scalar, a hashref or an arrayref -- see section ORDER BY clause for details. delete($table, \%where, \%options) This takes a table name and optional hashref WHERE clause. It returns an SQL DELETE statement and list of bind values. The optional "\%options" hash reference may contain additional options to generate the delete SQL. Currently supported options are: returning See the "returning" option to insert. where(\%where, $order) This is used to generate just the WHERE clause. For example, if you have an arbitrary data structure and know what the rest of your SQL is going to look like, but want an easy way to produce a WHERE clause, use this. It returns an SQL WHERE clause and list of bind values. values(\%data) This just returns the values from the hash %data, in the same order that would be returned from any of the other above queries. Using this allows you to markedly speed up your queries if you are affecting lots of rows. See below under the "PERFORMANCE" section. generate($any, 'number', $of, \@data, $struct, \%types) Warning: This is an experimental method and subject to change. This returns arbitrarily generated SQL. It's a really basic shortcut. It will return two different things, depending on return context: my($stmt, @bind) = $sql->generate('create table', \$table, \@fields); my $stmt_and_val = $sql->generate('create table', \$table, \@fields); These would return the following: # First calling form $stmt = "CREATE TABLE test (?, ?)"; @bind = (field1, field2); # Second calling form $stmt_and_val = "CREATE TABLE test (field1, field2)"; Depending on what you're trying to do, it's up to you to choose the correct format. In this example, the second form is what you would want. By the same token: $sql->generate('alter session', { nls_date_format => 'MM/YY' }); Might give you: ALTER SESSION SET nls_date_format = 'MM/YY' You get the idea. Strings get their case twiddled, but everything else remains verbatim. EXPORTABLE FUNCTIONS is_plain_value Determines if the supplied argument is a plain value as understood by this module: * The value is "undef" * The value is a non-reference * The value is an object with stringification overloading * The value is of the form "{ -value => $anything }" On failure returns "undef", on success returns a scalar reference to the original supplied argument. * Note The stringification overloading detection is rather advanced: it takes into consideration not only the presence of a "" overload, but if that fails also checks for enabled autogenerated versions of "", based on either "0+" or "bool". Unfortunately testing in the field indicates that this detection may tickle a latent bug in perl versions before 5.018, but only when very large numbers of stringifying objects are involved. At the time of writing ( Sep 2014 ) there is no clear explanation of the direct cause, nor is there a manageably small test case that reliably reproduces the problem. If you encounter any of the following exceptions in random places within your application stack - this module may be to blame: Operation "ne": no method found, left argument in overloaded package , right argument in overloaded package or perhaps even Stub found while resolving method "???" overloading """" in package If you fall victim to the above - please attempt to reduce the problem to something that could be sent to the SQL::Abstract developers (either publicly or privately). As a workaround in the meantime you can set $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} to a true value, which will most likely eliminate your problem (at the expense of not being able to properly detect exotic forms of stringification). This notice and environment variable will be removed in a future version, as soon as the underlying problem is found and a reliable workaround is devised. is_literal_value Determines if the supplied argument is a literal value as understood by this module: * "\$sql_string" * "\[ $sql_string, @bind_values ]" On failure returns "undef", on success returns an array reference containing the unpacked version of the supplied literal SQL and bind values. is_undef_value Tests for undef, whether expanded or not. WHERE CLAUSES Introduction This module uses a variation on the idea from DBIx::Abstract. It is NOT, repeat *not* 100% compatible. The main logic of this module is that things in arrays are OR'ed, and things in hashes are AND'ed. The easiest way to explain is to show lots of examples. After each %where hash shown, it is assumed you used: my($stmt, @bind) = $sql->where(\%where); However, note that the %where hash can be used directly in any of the other functions as well, as described above. Key-value pairs So, let's get started. To begin, a simple hash: my %where = ( user => 'nwiger', status => 'completed' ); Is converted to SQL "key = val" statements: $stmt = "WHERE user = ? AND status = ?"; @bind = ('nwiger', 'completed'); One common thing I end up doing is having a list of values that a field can be in. To do this, simply specify a list inside of an arrayref: my %where = ( user => 'nwiger', status => ['assigned', 'in-progress', 'pending']; ); This simple code will create the following: $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )"; @bind = ('nwiger', 'assigned', 'in-progress', 'pending'); A field associated to an empty arrayref will be considered a logical false and will generate 0=1. Tests for NULL values If the value part is "undef" then this is converted to SQL my %where = ( user => 'nwiger', status => undef, ); becomes: $stmt = "WHERE user = ? AND status IS NULL"; @bind = ('nwiger'); To test if a column IS NOT NULL: my %where = ( user => 'nwiger', status => { '!=', undef }, ); Specific comparison operators If you want to specify a different type of operator for your comparison, you can use a hashref for a given column: my %where = ( user => 'nwiger', status => { '!=', 'completed' } ); Which would generate: $stmt = "WHERE user = ? AND status != ?"; @bind = ('nwiger', 'completed'); To test against multiple values, just enclose the values in an arrayref: status => { '=', ['assigned', 'in-progress', 'pending'] }; Which would give you: "WHERE status = ? OR status = ? OR status = ?" The hashref can also contain multiple pairs, in which case it is expanded into an "AND" of its elements: my %where = ( user => 'nwiger', status => { '!=', 'completed', -not_like => 'pending%' } ); # Or more dynamically, like from a form $where{user} = 'nwiger'; $where{status}{'!='} = 'completed'; $where{status}{'-not_like'} = 'pending%'; # Both generate this $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?"; @bind = ('nwiger', 'completed', 'pending%'); To get an OR instead, you can combine it with the arrayref idea: my %where => ( user => 'nwiger', priority => [ { '=', 2 }, { '>', 5 } ] ); Which would generate: $stmt = "WHERE ( priority = ? OR priority > ? ) AND user = ?"; @bind = ('2', '5', 'nwiger'); If you want to include literal SQL (with or without bind values), just use a scalar reference or reference to an arrayref as the value: my %where = ( date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] }, date_expires => { '<' => \"now()" } ); Which would generate: $stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()"; @bind = ('11/26/2008'); Logic and nesting operators In the example above, there is a subtle trap if you want to say something like this (notice the "AND"): WHERE priority != ? AND priority != ? Because, in Perl you *can't* do this: priority => { '!=' => 2, '!=' => 1 } As the second "!=" key will obliterate the first. The solution is to use the special "-modifier" form inside an arrayref: priority => [ -and => {'!=', 2}, {'!=', 1} ] Normally, these would be joined by "OR", but the modifier tells it to use "AND" instead. (Hint: You can use this in conjunction with the "logic" option to "new()" in order to change the way your queries work by default.) Important: Note that the "-modifier" goes INSIDE the arrayref, as an extra first element. This will NOT do what you think it might: priority => -and => [{'!=', 2}, {'!=', 1}] # WRONG! Here is a quick list of equivalencies, since there is some overlap: # Same status => {'!=', 'completed', 'not like', 'pending%' } status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}] # Same status => {'=', ['assigned', 'in-progress']} status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}] status => [ {'=', 'assigned'}, {'=', 'in-progress'} ] Special operators: IN, BETWEEN, etc. You can also use the hashref format to compare a list of fields using the "IN" comparison operator, by specifying the list as an arrayref: my %where = ( status => 'completed', reportid => { -in => [567, 2335, 2] } ); Which would generate: $stmt = "WHERE status = ? AND reportid IN (?,?,?)"; @bind = ('completed', '567', '2335', '2'); The reverse operator "-not_in" generates SQL "NOT IN" and is used in the same way. If the argument to "-in" is an empty array, 'sqlfalse' is generated (by default: "1=0"). Similarly, "-not_in => []" generates 'sqltrue' (by default: "1=1"). In addition to the array you can supply a chunk of literal sql or literal sql with bind: my %where = { customer => { -in => \[ 'SELECT cust_id FROM cust WHERE balance > ?', 2000, ], status => { -in => \'SELECT status_codes FROM states' }, }; would generate: $stmt = "WHERE ( customer IN ( SELECT cust_id FROM cust WHERE balance > ? ) AND status IN ( SELECT status_codes FROM states ) )"; @bind = ('2000'); Finally, if the argument to "-in" is not a reference, it will be treated as a single-element array. Another pair of operators is "-between" and "-not_between", used with an arrayref of two values: my %where = ( user => 'nwiger', completion_date => { -not_between => ['2002-10-01', '2003-02-06'] } ); Would give you: WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? ) Just like with "-in" all plausible combinations of literal SQL are possible: my %where = { start0 => { -between => [ 1, 2 ] }, start1 => { -between => \["? AND ?", 1, 2] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", 'stuff' ], ] }, }; Would give you: $stmt = "WHERE ( ( start0 BETWEEN ? AND ? ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )"; @bind = (1, 2, 1, 2, 'stuff'); These are the two builtin "special operators"; but the list can be expanded: see section "SPECIAL OPERATORS" below. Unary operators: bool If you wish to test against boolean columns or functions within your database you can use the "-bool" and "-not_bool" operators. For example to test the column "is_user" being true and the column "is_enabled" being false you would use:- my %where = ( -bool => 'is_user', -not_bool => 'is_enabled', ); Would give you: WHERE is_user AND NOT is_enabled If a more complex combination is required, testing more conditions, then you should use the and/or operators:- my %where = ( -and => [ -bool => 'one', -not_bool => { two=> { -rlike => 'bar' } }, -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] }, ], ); Would give you: WHERE one AND (NOT two RLIKE ?) AND (NOT ( three = ? OR three > ? )) Nested conditions, -and/-or prefixes So far, we've seen how multiple conditions are joined with a top-level "AND". We can change this by putting the different conditions we want in hashes and then putting those hashes in an array. For example: my @where = ( { user => 'nwiger', status => { -like => ['pending%', 'dispatched'] }, }, { user => 'robot', status => 'unassigned', } ); This data structure would create the following: $stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) ) OR ( user = ? AND status = ? ) )"; @bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned'); Clauses in hashrefs or arrayrefs can be prefixed with an "-and" or "-or" to change the logic inside: my @where = ( -and => [ user => 'nwiger', [ -and => [ workhrs => {'>', 20}, geo => 'ASIA' ], -or => { workhrs => {'<', 50}, geo => 'EURO' }, ], ], ); That would yield: $stmt = "WHERE ( user = ? AND ( ( workhrs > ? AND geo = ? ) OR ( workhrs < ? OR geo = ? ) ) )"; @bind = ('nwiger', '20', 'ASIA', '50', 'EURO'); Algebraic inconsistency, for historical reasons "Important note": when connecting several conditions, the "-and-"|"-or" operator goes "outside" of the nested structure; whereas when connecting several constraints on one column, the "-and" operator goes "inside" the arrayref. Here is an example combining both features: my @where = ( -and => [a => 1, b => 2], -or => [c => 3, d => 4], e => [-and => {-like => 'foo%'}, {-like => '%bar'} ] ) yielding WHERE ( ( ( a = ? AND b = ? ) OR ( c = ? OR d = ? ) OR ( e LIKE ? AND e LIKE ? ) ) ) This difference in syntax is unfortunate but must be preserved for historical reasons. So be careful: the two examples below would seem algebraically equivalent, but they are not { col => [ -and => { -like => 'foo%' }, { -like => '%bar' }, ] } # yields: WHERE ( ( col LIKE ? AND col LIKE ? ) ) [ -and => { col => { -like => 'foo%' } }, { col => { -like => '%bar' } }, ] # yields: WHERE ( ( col LIKE ? OR col LIKE ? ) ) Literal SQL and value type operators The basic premise of SQL::Abstract is that in WHERE specifications the "left side" is a column name and the "right side" is a value (normally rendered as a placeholder). This holds true for both hashrefs and arrayref pairs as you see in the "WHERE CLAUSES" examples above. Sometimes it is necessary to alter this behavior. There are several ways of doing so. -ident This is a virtual operator that signals the string to its right side is an identifier (a column name) and not a value. For example to compare two columns you would write: my %where = ( priority => { '<', 2 }, requestor => { -ident => 'submitter' }, ); which creates: $stmt = "WHERE priority < ? AND requestor = submitter"; @bind = ('2'); If you are maintaining legacy code you may see a different construct as described in "Deprecated usage of Literal SQL", please use "-ident" in new code. -value This is a virtual operator that signals that the construct to its right side is a value to be passed to DBI. This is for example necessary when you want to write a where clause against an array (for RDBMS that support such datatypes). For example: my %where = ( array => { -value => [1, 2, 3] } ); will result in: $stmt = 'WHERE array = ?'; @bind = ([1, 2, 3]); Note that if you were to simply say: my %where = ( array => [1, 2, 3] ); the result would probably not be what you wanted: $stmt = 'WHERE array = ? OR array = ? OR array = ?'; @bind = (1, 2, 3); Literal SQL Finally, sometimes only literal SQL will do. To include a random snippet of SQL verbatim, you specify it as a scalar reference. Consider this only as a last resort. Usually there is a better way. For example: my %where = ( priority => { '<', 2 }, requestor => { -in => \'(SELECT name FROM hitmen)' }, ); Would create: $stmt = "WHERE priority < ? AND requestor IN (SELECT name FROM hitmen)" @bind = (2); Note that in this example, you only get one bind parameter back, since the verbatim SQL is passed as part of the statement. CAVEAT Never use untrusted input as a literal SQL argument - this is a massive security risk (there is no way to check literal snippets for SQL injections and other nastyness). If you need to deal with untrusted input use literal SQL with placeholders as described next. Literal SQL with placeholders and bind values (subqueries) If the literal SQL to be inserted has placeholders and bind values, use a reference to an arrayref (yes this is a double reference -- not so common, but perfectly legal Perl). For example, to find a date in Postgres you can use something like this: my %where = ( date_column => \[ "= date '2008-09-30' - ?::integer", 10 ] ) This would create: $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )" @bind = ('10'); Note that you must pass the bind values in the same format as they are returned by where. This means that if you set "bindtype" to "columns", you must provide the bind values in the "[ column_meta => value ]" format, where "column_meta" is an opaque scalar value; most commonly the column name, but you can use any scalar value (including references and blessed references), SQL::Abstract will simply pass it through intact. So if "bindtype" is set to "columns" the above example will look like: my %where = ( date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ] ) Literal SQL is especially useful for nesting parenthesized clauses in the main SQL query. Here is a first example: my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); my %where = ( foo => 1234, bar => \["IN ($sub_stmt)" => @sub_bind], ); This yields: $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?))"; @bind = (1234, 100, "foo%"); Other subquery operators, like for example "> ALL" or "NOT IN", are expressed in the same way. Of course the $sub_stmt and its associated bind values can be generated through a former call to "select()" : my ($sub_stmt, @sub_bind) = $sql->select("t1", "c1", {c2 => {"<" => 100}, c3 => {-like => "foo%"}}); my %where = ( foo => 1234, bar => \["> ALL ($sub_stmt)" => @sub_bind], ); In the examples above, the subquery was used as an operator on a column; but the same principle also applies for a clause within the main %where hash, like an EXISTS subquery: my ($sub_stmt, @sub_bind) = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); my %where = ( -and => [ foo => 1234, \["EXISTS ($sub_stmt)" => @sub_bind], ]); which yields $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1 WHERE c1 = ? AND c2 > t0.c0))"; @bind = (1234, 1); Observe that the condition on "c2" in the subquery refers to column "t0.c0" of the main query: this is *not* a bind value, so we have to express it through a scalar ref. Writing "c2 => {">" => "t0.c0"}" would have generated "c2 > ?" with bind value "t0.c0" ... not exactly what we wanted here. Finally, here is an example where a subquery is used for expressing unary negation: my ($sub_stmt, @sub_bind) = $sql->where({age => [{"<" => 10}, {">" => 20}]}); $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause my %where = ( lname => {like => '%son%'}, \["NOT ($sub_stmt)" => @sub_bind], ); This yields $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )" @bind = ('%son%', 10, 20) Deprecated usage of Literal SQL Below are some examples of archaic use of literal SQL. It is shown only as reference for those who deal with legacy code. Each example has a much better, cleaner and safer alternative that users should opt for in new code. * my %where = ( requestor => \'IS NOT NULL' ) $stmt = "WHERE requestor IS NOT NULL" This used to be the way of generating NULL comparisons, before the handling of "undef" got formalized. For new code please use the superior syntax as described in "Tests for NULL values". * my %where = ( requestor => \'= submitter' ) $stmt = "WHERE requestor = submitter" This used to be the only way to compare columns. Use the superior "-ident" method for all new code. For example an identifier declared in such a way will be properly quoted if "quote_char" is properly set, while the legacy form will remain as supplied. * my %where = ( is_ready => \"", completed => { '>', '2012-12-21' } ) $stmt = "WHERE completed > ? AND is_ready" @bind = ('2012-12-21') Using an empty string literal used to be the only way to express a boolean. For all new code please use the much more readable -bool operator. Conclusion These pages could go on for a while, since the nesting of the data structures this module can handle are pretty much unlimited (the module implements the "WHERE" expansion as a recursive function internally). Your best bet is to "play around" with the module a little to see how the data structures behave, and choose the best format for your data based on that. And of course, all the values above will probably be replaced with variables gotten from forms or the command line. After all, if you knew everything ahead of time, you wouldn't have to worry about dynamically-generating SQL and could just hardwire it into your script. ORDER BY CLAUSES Some functions take an order by clause. This can either be a scalar (just a column name), a hashref of "{ -desc => 'col' }" or "{ -asc => 'col' }", a scalarref, an arrayref-ref, or an arrayref of any of the previous forms. Examples: Given | Will Generate --------------------------------------------------------------- | 'colA' | ORDER BY colA | [qw/colA colB/] | ORDER BY colA, colB | {-asc => 'colA'} | ORDER BY colA ASC | {-desc => 'colB'} | ORDER BY colB DESC | ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC | { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC | \'colA DESC' | ORDER BY colA DESC | \[ 'FUNC(colA, ?)', $x ] | ORDER BY FUNC(colA, ?) | /* ...with $x bound to ? */ | [ | ORDER BY { -asc => 'colA' }, | colA ASC, { -desc => [qw/colB/] }, | colB DESC, { -asc => [qw/colC colD/] },| colC ASC, colD ASC, \'colE DESC', | colE DESC, \[ 'FUNC(colF, ?)', $x ], | FUNC(colF, ?) ] | /* ...with $x bound to ? */ =============================================================== OLD EXTENSION SYSTEM SPECIAL OPERATORS my $sqlmaker = SQL::Abstract->new(special_ops => [ { regex => qr/.../, handler => sub { my ($self, $field, $op, $arg) = @_; ... }, }, { regex => qr/.../, handler => 'method_name', }, ]); A "special operator" is a SQL syntactic clause that can be applied to a field, instead of a usual binary operator. For example: WHERE field IN (?, ?, ?) WHERE field BETWEEN ? AND ? WHERE MATCH(field) AGAINST (?, ?) Special operators IN and BETWEEN are fairly standard and therefore are builtin within "SQL::Abstract" (as the overridable methods "_where_field_IN" and "_where_field_BETWEEN"). For other operators, like the MATCH .. AGAINST example above which is specific to MySQL, you can write your own operator handlers - supply a "special_ops" argument to the "new" method. That argument takes an arrayref of operator definitions; each operator definition is a hashref with two entries: regex the regular expression to match the operator handler Either a coderef or a plain scalar method name. In both cases the expected return is "($sql, @bind)". When supplied with a method name, it is simply called on the SQL::Abstract object as: $self->$method_name($field, $op, $arg) Where: $field is the LHS of the operator $op is the part that matched the handler regex $arg is the RHS When supplied with a coderef, it is called as: $coderef->($self, $field, $op, $arg) For example, here is an implementation of the MATCH .. AGAINST syntax for MySQL my $sqlmaker = SQL::Abstract->new(special_ops => [ # special op for MySql MATCH (field) AGAINST(word1, word2, ...) {regex => qr/^match$/i, handler => sub { my ($self, $field, $op, $arg) = @_; $arg = [$arg] if not ref $arg; my $label = $self->_quote($field); my ($placeholder) = $self->_convert('?'); my $placeholders = join ", ", (($placeholder) x @$arg); my $sql = $self->_sqlcase('match') . " ($label) " . $self->_sqlcase('against') . " ($placeholders) "; my @bind = $self->_bindtype($field, @$arg); return ($sql, @bind); } }, ]); UNARY OPERATORS my $sqlmaker = SQL::Abstract->new(unary_ops => [ { regex => qr/.../, handler => sub { my ($self, $op, $arg) = @_; ... }, }, { regex => qr/.../, handler => 'method_name', }, ]); A "unary operator" is a SQL syntactic clause that can be applied to a field - the operator goes before the field You can write your own operator handlers - supply a "unary_ops" argument to the "new" method. That argument takes an arrayref of operator definitions; each operator definition is a hashref with two entries: regex the regular expression to match the operator handler Either a coderef or a plain scalar method name. In both cases the expected return is $sql. When supplied with a method name, it is simply called on the SQL::Abstract object as: $self->$method_name($op, $arg) Where: $op is the part that matched the handler regex $arg is the RHS or argument of the operator When supplied with a coderef, it is called as: $coderef->($self, $op, $arg) NEW METHODS (EXPERIMENTAL) See SQL::Abstract::Reference for the "expr" versus "aqt" concept and an explanation of what the below extensions are extending. plugin $sqla->plugin('+Foo'); Enables plugin SQL::Abstract::Plugin::Foo. render_expr my ($sql, @bind) = $sqla->render_expr($expr); render_statement Use this if you may be rendering a top level statement so e.g. a SELECT query doesn't get wrapped in parens my ($sql, @bind) = $sqla->render_statement($expr); expand_expr Expression expansion with optional default for scalars. my $aqt = $self->expand_expr($expr); my $aqt = $self->expand_expr($expr, -ident); render_aqt Top level means avoid parens on statement AQT. my $res = $self->render_aqt($aqt, $top_level); my ($sql, @bind) = @$res; join_query_parts Similar to join() but will render hashrefs as nodes for both join and parts, and treats arrayref as a nested "[ $join, @parts ]" structure. my $part = $self->join_query_parts($join, @parts); NEW EXTENSION SYSTEM clone my $sqla2 = $sqla->clone; Performs a semi-shallow copy such that extension methods won't leak state but excessive depth is avoided. expander expanders op_expander op_expanders clause_expander clause_expanders $sqla->expander('name' => sub { ... }); $sqla->expanders('name1' => sub { ... }, 'name2' => sub { ... }); expander_list op_expander_list clause_expander_list my @names = $sqla->expander_list; wrap_expander wrap_expanders wrap_op_expander wrap_op_expanders wrap_clause_expander wrap_clause_expanders $sqla->wrap_expander('name' => sub { my ($orig) = @_; sub { ... } }); $sqla->wrap_expanders( 'name1' => sub { my ($orig1) = @_; sub { ... } }, 'name2' => sub { my ($orig2) = @_; sub { ... } }, ); renderer renderers op_renderer op_renderers clause_renderer clause_renderers $sqla->renderer('name' => sub { ... }); $sqla->renderers('name1' => sub { ... }, 'name2' => sub { ... }); renderer_list op_renderer_list clause_renderer_list my @names = $sqla->renderer_list; wrap_renderer wrap_renderers wrap_op_renderer wrap_op_renderers wrap_clause_renderer wrap_clause_renderers $sqla->wrap_renderer('name' => sub { my ($orig) = @_; sub { ... } }); $sqla->wrap_renderers( 'name1' => sub { my ($orig1) = @_; sub { ... } }, 'name2' => sub { my ($orig2) = @_; sub { ... } }, ); clauses_of my @clauses = $sqla->clauses_of('select'); $sqla->clauses_of(select => \@new_clauses); $sqla->clauses_of(select => sub { my (undef, @old_clauses) = @_; ... return @new_clauses; }); statement_list my @list = $sqla->statement_list; make_unop_expander my $exp = $sqla->make_unop_expander(sub { ... }); If the op is found as a binop, assumes it wants a default comparison, so the inner expander sub can reliably operate as sub { my ($self, $name, $body) = @_; ... } make_binop_expander my $exp = $sqla->make_binop_expander(sub { ... }); If the op is found as a unop, assumes the value will be an arrayref with the LHS as the first entry, and converts that to an ident node if it's a simple scalar. So the inner expander sub looks like sub { my ($self, $name, $body, $k) = @_; { -blah => [ map $self->expand_expr($_), $k, $body ] } } unop_expander unop_expanders binop_expander binop_expanders The above methods operate exactly like the op_ versions but wrap the coderef using the appropriate make_ method first. PERFORMANCE Thanks to some benchmarking by Mark Stosberg, it turns out that this module is many orders of magnitude faster than using "DBIx::Abstract". I must admit this wasn't an intentional design issue, but it's a byproduct of the fact that you get to control your "DBI" handles yourself. To maximize performance, use a code snippet like the following: # prepare a statement handle using the first row # and then reuse it for the rest of the rows my($sth, $stmt); for my $href (@array_of_hashrefs) { $stmt ||= $sql->insert('table', $href); $sth ||= $dbh->prepare($stmt); $sth->execute($sql->values($href)); } The reason this works is because the keys in your $href are sorted internally by SQL::Abstract. Thus, as long as your data retains the same structure, you only have to generate the SQL the first time around. On subsequent queries, simply use the "values" function provided by this module to return your values in the correct order. However this depends on the values having the same type - if, for example, the values of a where clause may either have values (resulting in sql of the form "column = ?" with a single bind value), or alternatively the values might be "undef" (resulting in sql of the form "column IS NULL" with no bind value) then the caching technique suggested will not work. FORMBUILDER If you use my "CGI::FormBuilder" module at all, you'll hopefully really like this part (I do, at least). Building up a complex query can be as simple as the following: #!/usr/bin/perl use warnings; use strict; use CGI::FormBuilder; use SQL::Abstract; my $form = CGI::FormBuilder->new(...); my $sql = SQL::Abstract->new; if ($form->submitted) { my $field = $form->field; my $id = delete $field->{id}; my($stmt, @bind) = $sql->update('table', $field, {id => $id}); } Of course, you would still have to connect using "DBI" to run the query, but the point is that if you make your form look like your table, the actual query script can be extremely simplistic. If you're REALLY lazy (I am), check out "HTML::QuickTable" for a fast interface to returning and formatting data. I frequently use these three modules together to write complex database query apps in under 50 lines. HOW TO CONTRIBUTE Contributions are always welcome, in all usable forms (we especially welcome documentation improvements). The delivery methods include git- or unified-diff formatted patches, GitHub pull requests, or plain bug reports either via RT or the Mailing list. Contributors are generally granted full access to the official repository after their first several patches pass successful review. This project is maintained in a git repository. The code and related tools are accessible at the following locations: * Official repo: * Official gitweb: * GitHub mirror: * Authorized committers: CHANGES Version 1.50 was a major internal refactoring of "SQL::Abstract". Great care has been taken to preserve the *published* behavior documented in previous versions in the 1.* family; however, some features that were previously undocumented, or behaved differently from the documentation, had to be changed in order to clarify the semantics. Hence, client code that was relying on some dark areas of "SQL::Abstract" v1.* might behave differently in v1.50. The main changes are: * support for literal SQL through the "\ [ $sql, @bind ]" syntax. * support for the { operator => \"..." } construct (to embed literal SQL) * support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values) * optional support for array datatypes * defensive programming: check arguments * fixed bug with global logic, which was previously implemented through global variables yielding side-effects. Prior versions would interpret "[ {cond1, cond2}, [cond3, cond4] ]" as "(cond1 AND cond2) OR (cond3 AND cond4)". Now this is interpreted as "(cond1 AND cond2) OR (cond3 OR cond4)". * fixed semantics of _bindtype on array args * dropped the "_anoncopy" of the %where tree. No longer necessary, we just avoid shifting arrays within that tree. * dropped the "_modlogic" function ACKNOWLEDGEMENTS There are a number of individuals that have really helped out with this module. Unfortunately, most of them submitted bugs via CPAN so I have no idea who they are! But the people I do know are: Ash Berlin (order_by hash term support) Matt Trout (DBIx::Class support) Mark Stosberg (benchmarking) Chas Owens (initial "IN" operator support) Philip Collins (per-field SQL functions) Eric Kolve (hashref "AND" support) Mike Fragassi (enhancements to "BETWEEN" and "LIKE") Dan Kubb (support for "quote_char" and "name_sep") Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by) Laurent Dami (internal refactoring, extensible list of special operators, literal SQL) Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests) Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests) Oliver Charles (support for "RETURNING" after "INSERT") Thanks! SEE ALSO DBIx::Class, DBIx::Abstract, CGI::FormBuilder, HTML::QuickTable. AUTHOR Copyright (c) 2001-2007 Nathan Wiger . All Rights Reserved. This module is actively maintained by Matt Trout For support, your best bet is to try the "DBIx::Class" users mailing list. While not an official support venue, "DBIx::Class" makes heavy use of "SQL::Abstract", and as such list members there are very familiar with how to create queries. LICENSE This module is free software; you may copy this under the same terms as perl itself (either the GNU General Public License or the Artistic License) SQL-Abstract-2.000001/META.json0000644000000000000000000000444214002747454015566 0ustar00rootroot00000000000000{ "abstract" : "Generate SQL from Perl data structures", "author" : [ "Nathan Wiger " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "SQL-Abstract", "no_index" : { "directory" : [ "t", "xt", "examples" ], "package" : [ "DBIx::Class::Storage::Debug::PrettyPrint" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Pod::Coverage" : "0.19", "Test::EOL" : "1.0", "Test::NoTabs" : "0.9", "Test::Pod" : "1.14", "Test::Pod::Coverage" : "1.04" } }, "runtime" : { "requires" : { "Exporter" : "5.57", "Hash::Merge" : "0.12", "List::Util" : "0", "MRO::Compat" : "0.12", "Moo" : "2.000001", "Scalar::Util" : "0", "Sub::Quote" : "2.000001", "Test::Builder::Module" : "0.84", "Test::Deep" : "0.101", "Text::Balanced" : "2.00", "perl" : "5.006" } }, "test" : { "requires" : { "Data::Dumper::Concise" : "0", "Storable" : "0", "Test::Exception" : "0.31", "Test::More" : "0.88", "Test::Warn" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-SQL-Abstract@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=SQL-Abstract" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/dbsrgits/sql-abstract.git", "web" : "https://github.com/dbsrgits/sql-abstract" }, "x_IRC" : "irc://irc.perl.org/#dbix-class" }, "version" : "2.000001", "x_serialization_backend" : "JSON::PP version 2.27300" } SQL-Abstract-2.000001/Makefile.PL0000644000000000000000000000701014002747044016104 0ustar00rootroot00000000000000use strict; use warnings FATAL => 'all'; use 5.006; my %META = ( name => 'SQL-Abstract', license => 'perl_5', dynamic_config => 0, prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, } }, build => { requires => {} }, test => { requires => { 'Test::More' => '0.88', 'Test::Exception' => '0.31', 'Test::Warn' => '0', 'Storable' => '0', # for cloning in tests 'Data::Dumper::Concise' => '0', }, }, runtime => { requires => { 'List::Util' => '0', 'Scalar::Util' => '0', 'Exporter' => '5.57', 'MRO::Compat' => '0.12', 'Moo' => '2.000001', 'Sub::Quote' => '2.000001', 'Hash::Merge' => '0.12', 'Text::Balanced' => '2.00', 'perl' => '5.006', # Used by SQL::Abstract::Test 'Test::Deep' => '0.101', 'Test::Builder::Module' => '0.84', }, }, develop => { requires => { 'Test::Pod' => '1.14', 'Test::Pod::Coverage' => '1.04', 'Pod::Coverage' => '0.19', 'Test::EOL' => '1.0', 'Test::NoTabs' => '0.9', }, }, }, resources => { repository => { url => 'https://github.com/dbsrgits/sql-abstract.git', web => 'https://github.com/dbsrgits/sql-abstract', type => 'git', }, x_IRC => 'irc://irc.perl.org/#dbix-class', bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=SQL-Abstract', mailto => 'bug-SQL-Abstract@rt.cpan.org', }, license => [ 'http://dev.perl.org/licenses/' ], }, no_index => { package => [ 'DBIx::Class::Storage::Debug::PrettyPrint' ], directory => [ 't', 'xt', 'examples' ], }, ); my %MM_ARGS = ( test => { TESTS => 't/*.t t/*/*.t' }, ); ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); ## END BOILERPLATE ########################################################### SQL-Abstract-2.000001/MANIFEST0000644000000000000000000000267614002747454015305 0ustar00rootroot00000000000000Changes examples/bangdbic.pl examples/console.pl examples/dbic-console.pl examples/sqla-format examples/sqla2passthrough.pl lib/DBIx/Class/SQLMaker/Role/SQLA2Passthrough.pm lib/DBIx/Class/Storage/Debug/PrettyPrint.pm lib/SQL/Abstract.pm lib/SQL/Abstract/Formatter.pm lib/SQL/Abstract/Parts.pm lib/SQL/Abstract/Plugin/BangOverrides.pm lib/SQL/Abstract/Plugin/ExtraClauses.pm lib/SQL/Abstract/Reference.pm lib/SQL/Abstract/Role/Plugin.pm lib/SQL/Abstract/Test.pm lib/SQL/Abstract/Tree.pm maint/inplace maint/lib/Chunkstrumenter.pm maint/Makefile.PL.include maint/podregen maint/sqlacexpr maint/sqlaexpr Makefile.PL MANIFEST This list of files t/00new.t t/01generate.t t/02where.t t/03values.t t/04modifiers.t t/05in_between.t t/06order_by.t t/07subqueries.t t/08special_ops.t t/09refkind.t t/10test.t t/11parser.t t/12confmerge.t t/12format_keyword.t t/13whitespace_keyword.t t/14roundtrippin.t t/15placeholders.t t/16no_sideeffects.t t/20injection_guard.t t/21op_ident.t t/22op_value.t t/23_is_X_value.t t/24order_by_chunks.t t/80extra_clauses.t t/dbic/bulk-insert.t t/dbic/no-repeats.t t/dbic/show-progress.t xt/90pod.t xt/91podcoverage.t xt/92whitespace.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) LICENSE LICENSE file (added by Distar) SQL-Abstract-2.000001/META.yml0000644000000000000000000000222114002747454015407 0ustar00rootroot00000000000000--- abstract: 'Generate SQL from Perl data structures' author: - 'Nathan Wiger ' build_requires: Data::Dumper::Concise: '0' Storable: '0' Test::Exception: '0.31' Test::More: '0.88' Test::Warn: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: SQL-Abstract no_index: directory: - t - xt - examples package: - DBIx::Class::Storage::Debug::PrettyPrint requires: Exporter: '5.57' Hash::Merge: '0.12' List::Util: '0' MRO::Compat: '0.12' Moo: '2.000001' Scalar::Util: '0' Sub::Quote: '2.000001' Test::Builder::Module: '0.84' Test::Deep: '0.101' Text::Balanced: '2.00' perl: '5.006' resources: IRC: irc://irc.perl.org/#dbix-class bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=SQL-Abstract license: http://dev.perl.org/licenses/ repository: https://github.com/dbsrgits/sql-abstract.git version: '2.000001' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' SQL-Abstract-2.000001/Changes0000644000000000000000000004177314002747433015445 0ustar00rootroot00000000000000Revision history for SQL::Abstract 2.000001 - 2021-01-23 - Remove Module::Runtime requirement 2.000000 - 2021-01-21 - Collapse custom join conditions back to something DBIC might understand 1.90_03 - 2019-10-13 - Add proof of concept DBIx::Class::SQLMaker::Role::SQLA2Passthrough - _where_field_IN/BETWEEN are documented as subclassable; feature restored 1.90_02 - 2019-10-12 - fix DBIC ident op expander compat wrapper to handle call as unop 1.90_01 - 2019-10-09 - Complete overhaul of the internals, see the SQL::Abstract::Reference docs to understand the new implementation's affordances. 1.87 - 2020-06-02 - Add runtime dependency on Test::Deep and Test::Builder::Module for SQL::Abstract::Test (RT#131623) 1.86 - 2018-07-09 - Remove obsolete documentation about arrayrefref as the $source argument for ->select (removed in version 1.74) - Factor out the field list part of SELECT for subclassability (GH#13) - Do not replace literal '0' with empty string in WHERE clauses (GH#14) 1.85 - 2018-01-27 - Restore perl version requirement missed in the Distar port - Factor out the SET ... part of UPDATE for subclassability (GH#12) 1.84 - 2017-04-03 - Restore 'dynamic_config => 0' missed in the Distar port 1.83 - 2017-04-03 - Support for DELETE ... RETURNING (GH#9) - Port to Distar revision 1.82 2017-03-20 ------------------------- - Add explicit dependency on Sub::Quote (GH#8) - Fix syntax errors in ORDER BY docs (GH#7) revision 1.81_01 2017-02-28 ---------------------------- - Fix order clauses with bind parameters in ->where - Fix ->insert($table, \@values) with >26 values (RT#112684) - Teach ::Tree that ILIKE (PostgreSQL) and REGEXP (MySQL) are binary ops - Support for UPDATE ... RETURNING - Documentation improvements for ORDER BY revision 1.81 2014-10-25 ---------------------------- - Fix overly-enthusiastic parenthesis unroller (RT#99503) revision 1.80 2014-10-05 ---------------------------- - Fix erroneous behavior of is_literal_value($) wrt { -ident => ... } - Explicitly croak on top-level special ops (they didn't work anyway) revision 1.79 2014-09-25 ---------------------------- - New exportable functions: is_literal_value($) and is_plain_value($) - New attribute 'escape_char' allowing for proper escape of quote_chars present in an identifier - Deprecate { "" => \... } constructs - Treat { -value => undef } as plain undef in all cases - Explicitly throw on { -ident => undef } revision 1.78 2014-05-28 ---------------------------- - Fix parsing of binary ops to correctly take up only a single LHS element, instead of gobbling up the entire parse-to-date - Explicitly handle ROW_NUMBER() OVER as the snowflake-operator it is - Improve signatures/documentation of is_same_sql_bind / eq_sql_bind - Retire script/format-sql - the utility needs more work to be truly end-user convenient revision 1.77 2014-01-17 ---------------------------- - Reintroduce { -not => undef } column operator (regression from 1.75) revision 1.75 2013-12-27 ---------------------------- - *UPCOMING INCOMPATIBLE BUGFIX*: SQLA used to generate incorrect SQL on undef-containing lists fed to -in and -not_in. An exception will be raised for a while before properly fixing this, to avoid quiet but subtle changes to query results in production - Deprecate and warn when supplying an empty arrayref to like/not_like operators (likely to be removed before 2.0) - Warn when using an inequality operator with a multi-value array to arrive at what amounts to a 1=1 condition (no pre-2.0 plans to fix this behavior due to backwards comp concerns) - Fix false negative comparison of ORDER BY ASC - More improvements of incorrect parsing (placeholder at end of list element) - Fix typos in POD and comments (RT#87776) - Augment -not_bool example with nesting (RT#89601) revision 1.74 2013-06-04 ---------------------------- - Fix insufficient parenthesis unroll during operator comparison - 'ORDER BY foo' and 'ORDER BY foo ASC' are now considered equal by default (with a switch to reenable old behavior when necessary) - Change parser to not eagerly slurp RHS expressions it doesn't recognize revision 1.73 2012-07-10 ---------------------------- - Fix parsing of ORDER BY foo + ? - Stop filling in placeholders in `format-sql` since it does not support passing values for them anyway - Fix parsing of NOT EXISTS - Fix over-eager parenthesis unrolling - Fix deep recursion warnings while parsing obnoxiously long sql statements - Fix incorrect comparison of malformed lists - Fix incorrect reporting of mismatch-members in SQLA::Test - Migrate the -ident operator from DBIC into SQLA - Migrate the -value operator from DBIC into SQLA revision 1.72 2010-12-21 ---------------------------- - Extra checks of search arguments for possible SQL injection attacks - Remove excess parentheses in debug SQL - Fix parsing of foo.* in SQLA::Tree - Fix bindtype fail when using -between with arrayrefref literals - Add handling for NULL for -in - The -nest operator has entered semi-deprecated status and has been undocumented. Please do not use it in new code revision 1.71 2010-11-09 ---------------------------- - Add EXECUTING for clarity of long running SQL - Add "squash_repeats" option to fix it such that repeated SQL gets ellided except for placeholders - Highlight transaction keywords - Highlight HAVING - Leave quotes from DBIC in bindargs - Add error checking on "profile" for SQLA::Tree - Hide bulk inserts from DBIx::Class - Fix missing doc (RT#62587) - Format functions in MySQL-friendly manner foo( ... ) vs foo ( ... ) revision 1.69 2010-10-22 ---------------------------- - Add quotes for populated placeholders and make the background magenta instead of cyan - Color and indent pagination keywords - Fix a silly bug which broke placeholder fill-in in DBIC - Installs format-sql to format SQL passed in over STDIN - Switch the tokenizer to precompiled regexes (massive speedup) - Rudimentary handling of quotes ( 'WHERE' vs WHERE ) - Fix extended argument parsing by IN/BETWEEN - Add proper handling of lists (foo,bar,?) - Better handling of generic -function's during AST construction - Special handle IS NOT? NULL - Make sure unparse() does not destroy a passed in \@bindargs - Support ops with _'s in them (valid in Oracle) - Properly parse both types of default value inserts - Allow { -func => $val } as arguments to UPDATE revision 1.68 2010-09-16 ---------------------------- - Document methods on Tree - Add affordances for color coding placeholders - Change ::Tree::whitespace to whitespace_keyword revision 1.67_03 2010-09-11 ---------------------------- - Add docs for SQL::Abstract::Tree->new - correcty merge profile and parameters - added fill_in_placeholders option for excellent copy/pasta revision 1.67_02 2010-09-08 ---------------------------- - rename DBIx::Class::Storage::PrettyPrinter to DBIx::Class::Storage::Debug::PrettyPrint - decreased a lot of indentation from ::Tree - cleaned up handling of newlines inside of parens revision 1.67_01 2010-09-06 ---------------------------- - Add SQL::Abstract::Tree - Add unindexed DBIx::Class::Storage::PrettyPrinter - Better documentation of undef/NULL in where clause - Depend on bugfixed Module::Install (now again installs on old < 5.8.3 perls) revision 1.67 2010-05-31 14:21 (UTC) ---------------------------- - Fix SQL::Test failure when first chunk is an unrecognized literal - Generic -not operator tests - More columns-bindtype assertion checks revision 1.66 2010-04-27 02:44 (UTC) ---------------------------- - Optimized the quoting mechanism, winning nearly 10% speedup on repeatable sql generation revision 1.65 2010-04-11 19:59 (UTC) ---------------------------- - Rerelease last version to not include .svn files and grab MANIFEST.SKIP from DBIx::Class so it won't happen again revision 1.64 2010-04-11 16:58 (UTC) ---------------------------- - Fix multiple generic op handling regressions by reverting the auto-equality assumption (turned out to be a very very bad idea) revision 1.63 2010-03-24 09:56 (UTC) ---------------------------- - Add ILIKE to the core list of comparision ops revision 1.62 2010-03-15 11:06 (UTC) ---------------------------- - Fixed open outer parens for a multi-line literal - Allow recursively-nested column-functions in WHERE - Bumped minimum perl to 5.6.2 and changed tests to rely on core dependencies revision 1.61 2010-02-05 16:28 (UTC) ---------------------------- - Allow INSERT to take additional attributes - Support for INSERT ... RETURNING - Another iteration of SQL::Abstract::Test fixes and improvements revision 1.60 2009-09-22 11:03 (UTC) ---------------------------- - fix a well masked error in the sql-test tokenizer revision 1.59 2009-09-22 08:39 (UTC) ---------------------------- - fixed a couple of untrapped undefined warnings - allow -in/-between to accept literal sql in all logical variants - see POD for details - unroll multiple parenthesis around IN arguments to accomodate crappy databases revision 1.58 2009-09-04 15:20 (UTC) ---------------------------- - expanded the scope of -bool and -not_bool operators - added proper testing support revision 1.57 2009-09-03 20:18 (UTC) ---------------------------- - added -bool and -not_bool operators revision 1.56 2009-05-30 16:31 (UTC) ---------------------------- - support for \[$sql, @bind] in order_by clauses e.g.: { -desc => \['colA LIKE ?', 'somestring'] } revision 1.55 2009-05-17 22:54 (UTC) ---------------------------- - make sure that sql generation does not mutate the supplied where condition structure revision 1.54 2009-05-07 17:23 (UTC) ---------------------------- - allow special_operators to take both code refs and method names (makes it possible to properly subclass the builtin ones) revision 1.53 2009-04-30 14:58 (UTC) ---------------------------- - make sure hash keys are sorted in all search sub-conditions - switch installer from EU::MM to M::I revision 1.52 2009-04-28 23:14 (UTC) ---------------------------- - allow -between to handle [\"", \""] and \["", @bind] - allow order_by to handle -asc|desc => [qw/colA colB/] (artifact from DBIx::Class) - more tests and clearing up of some corner cases - t/10test.t does not run by default (developer only, too cpu intensive) ---------------------------- revision 1.51 2009-03-28 10:00 (UTC) - fixed behavior of [-and => ... ] depending on the current condition scope. This introduces backwards comp with 1.24 ---------------------------- revision 1.50 2009-03-10 12:30 (UTC) - fixed the problem with values() not behaving the same as the rest of the code (RT#43483) - fixed interjecting arrayrefref into a where clause - added value-only insert test with a literal SQL snippet - cleanup and enhancement of t/03values.t - better handling of borked SQL in tests - deal properly with parentheses in is_same_sql_bind() - fixed test subs (is_same_*) in SQL::Abstract::Test to return the correct test value - do not version MANIFEST Version 1.50 was a major internal refactoring of SQL::Abstract. Great care has been taken to preserve the published behavior documented in previous versions in the 1.* family; however, some features that were previously undocumented, or behaved. differently from the documentation, had to be changed in order to clarify the semantics. Hence, client code that was relying on some dark areas of SQL::Abstract v1.* might behave differently in v1.50. ---------------------------- revision 1.49_04 2009-03-03 - add support for a [\%column_meta => value] bind value format ---------------------------- revision 1.49_03 2009-02-17 - clarify syntax of \['...', @bind] when used with a bindtype of 'columns' ---------------------------- revision 1.49_02 2009-02-16 - added an AST-aware SQL::Abstract::Test library for sql syntax tests - vastly expanded test coverage - support for the { operator => \'...'|\['...', @bind] } syntax allowing to embed arbitrary operators on the LHS - fixed multiple regressions wrt DBIx::Class ---------------------------- revision 1.49_01 2009-02-11 - support for literal SQL through the [$sql, bind] syntax. - added -nest1, -nest2 or -nest_1, -nest_2, ... - optional support for array datatypes - defensive programming : check arguments to functions/methods - fixed bug with global logic of -and/-or (no side-effects any more) - changed logic for distributing an op over arrayrefs - fixed semantics of _bindtype on array args - dropped the _anoncopy of the %where tree. No longer necessary. - dropped the _modlogic function - Make col => [] and col => {$op => [] } DTRT or die instead of generating broken SQL. Added tests for this. - Added { -desc => 'column' } order by support - Tiny "$_"-related fix for { -desc => 'columns'} order by support tests + docs ---------------------------- revision 1.20 date: 2005/08/18 18:41:58; author: nwiger; state: Exp; lines: +104 -50 - added patch from Dan Kubb enabling quote_char and name_sep options - added patch from Andy Grundman to enhance _anoncopy for deep refs ---------------------------- revision 1.19 date: 2005/04/29 18:20:30; author: nwiger; state: Exp; lines: +34 -20 added _anoncopy to prevent destroying original; updated docs ---------------------------- revision 1.18 date: 2005/03/07 20:14:12; author: nwiger; state: Exp; lines: +201 -65 added support for -and, -or, and -nest; see docs for details ---------------------------- revision 1.17 date: 2004/08/25 20:11:27; author: nwiger; state: Exp; lines: +58 -46 added patch from Eric Kolve to iterate over all hashref elements ---------------------------- revision 1.16 date: 2004/06/10 17:20:01; author: nwiger; state: Exp; lines: +178 -12 added bindtype param to allow this to work with Orasuck 9+ ---------------------------- revision 1.15 date: 2003/11/05 23:40:40; author: nwiger; state: Exp; lines: +18 -6 several bugfixes, including _convert being applied wrong and the edge case field => { '!=', [qw/this that/] } not working ---------------------------- revision 1.14 date: 2003/11/04 21:20:33; author: nwiger; state: Exp; lines: +115 -34 added patch from Philip Collins, and also added 'convert' option ---------------------------- revision 1.13 date: 2003/05/21 17:22:29; author: nwiger; state: Exp; lines: +230 -74 added "IN" and "BETWEEN" operator support, as well as "NOT" modified where() to support ORDER BY, and fixed some bugs too added PERFORMANCE and FORMBUILDER doc sections fixed several bugs in _recurse_where(), it now works as expected added test suite, many thanks to Chas Owens modified all hash access to return keys sorted, to allow cached queries ---------------------------- revision 1.12 date: 2003/05/08 20:10:56; author: nwiger; state: Exp; lines: +181 -96 1.11 interim checking; major bugfixes and order_by, 1.12 will go to CPAN ---------------------------- revision 1.11 date: 2003/05/02 00:07:30; author: nwiger; state: Exp; lines: +52 -12 many minor enhancements to add querying flexibility ---------------------------- revision 1.10 date: 2002/09/27 18:06:25; author: nwiger; state: Exp; lines: +6 -2 added precatch for messed up where string ---------------------------- revision 1.9 date: 2002/08/29 18:04:35; author: nwiger; state: Exp; lines: +4 -3 CPAN ---------------------------- revision 1.8 date: 2001/11/07 22:18:12; author: nwiger; state: Exp; lines: +31 -14 added embedded SCALAR ref capability to insert() and update() ---------------------------- revision 1.7 date: 2001/11/07 01:23:28; author: nwiger; state: Exp; lines: +3 -3 damn uninit warning ---------------------------- revision 1.6 date: 2001/11/06 21:09:44; author: nwiger; state: Exp; lines: +14 -6 oops, had to actually *implement* the order by for select()! ---------------------------- revision 1.5 date: 2001/11/06 03:13:16; author: nwiger; state: Exp; lines: +43 -4 lots of docs ---------------------------- revision 1.4 date: 2001/11/06 03:07:42; author: nwiger; state: Exp; lines: +16 -7 added extra layer of ()'s to ensure correct semantics on AND ---------------------------- revision 1.3 date: 2001/11/06 01:16:31; author: nwiger; state: Exp; lines: +11 -10 updated all statements so that they use wantarray to just return SQL if asked ---------------------------- revision 1.2 date: 2001/10/26 22:23:46; author: nwiger; state: Exp; lines: +112 -15 added scalar ref for SQL verbatim in where, fixed bugs, array ref, docs ---------------------------- revision 1.1 date: 2001/10/24 00:26:43; author: nwiger; state: Exp; Initial revision SQL-Abstract-2.000001/lib/0000755000000000000000000000000014002747454014707 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/SQL/0000755000000000000000000000000014002747454015346 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/SQL/Abstract/0000755000000000000000000000000014002747454017111 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/SQL/Abstract/Tree.pm0000644000000000000000000006241413455744035020360 0ustar00rootroot00000000000000package SQL::Abstract::Tree; use Moo; no warnings 'qw'; use Carp; use Sub::Quote 'quote_sub'; my $op_look_ahead = '(?: (?= [\s\)\(\;] ) | \z)'; my $op_look_behind = '(?: (?<= [\,\s\)\(] ) | \A )'; my $quote_left = qr/[\`\'\"\[]/; my $quote_right = qr/[\`\'\"\]]/; my $placeholder_re = qr/(?: \? | \$\d+ )/x; # These SQL keywords always signal end of the current expression (except inside # of a parenthesized subexpression). # Format: A list of strings that will be compiled to extended syntax ie. # /.../x) regexes, without capturing parentheses. They will be automatically # anchored to op boundaries (excluding quotes) to match the whole token. my @expression_start_keywords = ( 'SELECT', 'UPDATE', 'SET', 'INSERT \s+ INTO', 'DELETE \s+ FROM', 'FROM', '(?: (?: (?: (?: LEFT | RIGHT | FULL ) \s+ )? (?: (?: CROSS | INNER | OUTER ) \s+ )? )? JOIN )', 'ON', 'WHERE', '(?: DEFAULT \s+ )? VALUES', 'GROUP \s+ BY', 'HAVING', 'ORDER \s+ BY', 'SKIP', 'FETCH', 'FIRST', 'LIMIT', 'OFFSET', 'FOR', 'UNION', 'INTERSECT', 'EXCEPT', 'BEGIN \s+ WORK', 'COMMIT', 'ROLLBACK \s+ TO \s+ SAVEPOINT', 'ROLLBACK', 'SAVEPOINT', 'RELEASE \s+ SAVEPOINT', 'RETURNING', ); my $expr_start_re = join ("\n\t|\n", @expression_start_keywords ); $expr_start_re = qr/ $op_look_behind (?i: $expr_start_re ) $op_look_ahead /x; # These are binary operator keywords always a single LHS and RHS # * AND/OR are handled separately as they are N-ary # * so is NOT as being unary # * BETWEEN without parentheses around the ANDed arguments (which # makes it a non-binary op) is detected and accommodated in # _recurse_parse() # * AS is not really an operator but is handled here as it's also LHS/RHS # this will be included in the $binary_op_re, the distinction is interesting during # testing as one is tighter than the other, plus alphanum cmp ops have different # look ahead/behind (e.g. "x"="y" ) my @alphanum_cmp_op_keywords = (qw/< > != <> = <= >= /); my $alphanum_cmp_op_re = join ("\n\t|\n", map { "(?: (?<= [\\w\\s] | $quote_right ) | \\A )" . quotemeta ($_) . "(?: (?= [\\w\\s] | $quote_left ) | \\z )" } @alphanum_cmp_op_keywords ); $alphanum_cmp_op_re = qr/$alphanum_cmp_op_re/x; my $binary_op_re = '(?: NOT \s+)? (?:' . join ('|', qw/IN BETWEEN [RI]?LIKE REGEXP/) . ')'; $binary_op_re = join "\n\t|\n", "$op_look_behind (?i: $binary_op_re | AS ) $op_look_ahead", $alphanum_cmp_op_re, $op_look_behind . 'IS (?:\s+ NOT)?' . "(?= \\s+ NULL \\b | $op_look_ahead )", ; $binary_op_re = qr/$binary_op_re/x; my $rno_re = qr/ROW_NUMBER \s* \( \s* \) \s+ OVER/ix; my $unary_op_re = 'NOT \s+ EXISTS | NOT | ' . $rno_re; $unary_op_re = join "\n\t|\n", "$op_look_behind (?i: $unary_op_re ) $op_look_ahead", ; $unary_op_re = qr/$unary_op_re/x; my $asc_desc_re = qr/$op_look_behind (?i: ASC | DESC ) $op_look_ahead /x; my $and_or_re = qr/$op_look_behind (?i: AND | OR ) $op_look_ahead /x; my $tokenizer_re = join("\n\t|\n", $expr_start_re, $binary_op_re, $unary_op_re, $asc_desc_re, $and_or_re, $op_look_behind . ' \* ' . $op_look_ahead, (map { quotemeta $_ } qw/, ( )/), $placeholder_re, ); # this one *is* capturing for the split below # splits on whitespace if all else fails # has to happen before the composing qr's are anchored (below) $tokenizer_re = qr/ \s* ( $tokenizer_re ) \s* | \s+ /x; # Parser states for _recurse_parse() use constant PARSE_TOP_LEVEL => 0; use constant PARSE_IN_EXPR => 1; use constant PARSE_IN_PARENS => 2; use constant PARSE_IN_FUNC => 3; use constant PARSE_RHS => 4; use constant PARSE_LIST_ELT => 5; my $expr_term_re = qr/$expr_start_re | \)/x; my $rhs_term_re = qr/ $expr_term_re | $binary_op_re | $unary_op_re | $asc_desc_re | $and_or_re | \, /x; my $all_std_keywords_re = qr/ $rhs_term_re | \( | $placeholder_re /x; # anchor everything - even though keywords are separated by the tokenizer, leakage may occur for ( $quote_left, $quote_right, $placeholder_re, $expr_start_re, $alphanum_cmp_op_re, $binary_op_re, $unary_op_re, $asc_desc_re, $and_or_re, $expr_term_re, $rhs_term_re, $all_std_keywords_re, ) { $_ = qr/ \A $_ \z /x; } # what can be bunched together under one MISC in an AST my $compressable_node_re = qr/^ \- (?: MISC | LITERAL | PLACEHOLDER ) $/x; my %indents = ( select => 0, update => 0, 'insert into' => 0, 'delete from' => 0, from => 1, where => 0, join => 1, 'left join' => 1, on => 2, having => 0, 'group by' => 0, 'order by' => 0, set => 1, into => 1, values => 1, limit => 1, offset => 1, skip => 1, first => 1, ); has [qw( newline indent_string indent_amount fill_in_placeholders placeholder_surround )] => (is => 'ro'); has [qw( indentmap colormap )] => ( is => 'ro', default => quote_sub('{}') ); # class global is in fact desired my $merger; sub BUILDARGS { my $class = shift; my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_}; if (my $p = delete $args->{profile}) { my %extra_args; if ($p eq 'console') { %extra_args = ( fill_in_placeholders => 1, placeholder_surround => ['?/', ''], indent_string => ' ', indent_amount => 2, newline => "\n", colormap => {}, indentmap => \%indents, ! ( eval { require Term::ANSIColor } ) ? () : do { my $c = \&Term::ANSIColor::color; my $red = [$c->('red') , $c->('reset')]; my $cyan = [$c->('cyan') , $c->('reset')]; my $green = [$c->('green') , $c->('reset')]; my $yellow = [$c->('yellow') , $c->('reset')]; my $blue = [$c->('blue') , $c->('reset')]; my $magenta = [$c->('magenta'), $c->('reset')]; my $b_o_w = [$c->('black on_white'), $c->('reset')]; ( placeholder_surround => [$c->('black on_magenta'), $c->('reset')], colormap => { 'begin work' => $b_o_w, commit => $b_o_w, rollback => $b_o_w, savepoint => $b_o_w, 'rollback to savepoint' => $b_o_w, 'release savepoint' => $b_o_w, select => $red, 'insert into' => $red, update => $red, 'delete from' => $red, set => $cyan, from => $cyan, where => $green, values => $yellow, join => $magenta, 'left join' => $magenta, on => $blue, 'group by' => $yellow, having => $yellow, 'order by' => $yellow, skip => $green, first => $green, limit => $green, offset => $green, } ); }, ); } elsif ($p eq 'console_monochrome') { %extra_args = ( fill_in_placeholders => 1, placeholder_surround => ['?/', ''], indent_string => ' ', indent_amount => 2, newline => "\n", indentmap => \%indents, ); } elsif ($p eq 'html') { %extra_args = ( fill_in_placeholders => 1, placeholder_surround => ['', ''], indent_string => ' ', indent_amount => 2, newline => "
\n", colormap => { map { (my $class = $_) =~ s/\s+/-/g; ( $_ => [ qq||, '' ] ) } ( keys %indents, qw(commit rollback savepoint), 'begin work', 'rollback to savepoint', 'release savepoint', ) }, indentmap => \%indents, ); } elsif ($p eq 'none') { # nada } else { croak "No such profile '$p'"; } # see if we got any duplicates and merge if needed if (scalar grep { exists $args->{$_} } keys %extra_args) { # heavy-duty merge $args = ($merger ||= do { require Hash::Merge; my $m = Hash::Merge->new; $m->specify_behavior({ SCALAR => { SCALAR => sub { $_[1] }, ARRAY => sub { [ $_[0], @{$_[1]} ] }, HASH => sub { $_[1] }, }, ARRAY => { SCALAR => sub { $_[1] }, ARRAY => sub { $_[1] }, HASH => sub { $_[1] }, }, HASH => { SCALAR => sub { $_[1] }, ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] }, HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) }, }, }, 'SQLA::Tree Behavior' ); $m; })->merge(\%extra_args, $args ); } else { $args = { %extra_args, %$args }; } } $args; } sub parse { my ($self, $s) = @_; return [] unless defined $s; # tokenize string, and remove all optional whitespace my $tokens = []; foreach my $token (split $tokenizer_re, $s) { push @$tokens, $token if ( defined $token and length $token and $token =~ /\S/ ); } return [ $self->_recurse_parse($tokens, PARSE_TOP_LEVEL) ]; } sub _recurse_parse { my ($self, $tokens, $state) = @_; my @left; while (1) { # left-associative parsing if (! @$tokens or ($state == PARSE_IN_PARENS && $tokens->[0] eq ')') or ($state == PARSE_IN_EXPR && $tokens->[0] =~ $expr_term_re ) or ($state == PARSE_RHS && $tokens->[0] =~ $rhs_term_re ) or ($state == PARSE_LIST_ELT && ( $tokens->[0] eq ',' or $tokens->[0] =~ $expr_term_re ) ) ) { return @left; } my $token = shift @$tokens; # nested expression in () if ($token eq '(' ) { my @right = $self->_recurse_parse($tokens, PARSE_IN_PARENS); $token = shift @$tokens or croak "missing closing ')' around block " . $self->unparse(\@right); $token eq ')' or croak "unexpected token '$token' terminating block " . $self->unparse(\@right); push @left, [ '-PAREN' => \@right ]; } # AND/OR elsif ($token =~ $and_or_re) { my $op = uc $token; my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); # Merge chunks if "logic" matches @left = [ $op => [ @left, (@right and $op eq $right[0][0]) ? @{ $right[0][1] } : @right ] ]; } # LIST (,) elsif ($token eq ',') { my @right = $self->_recurse_parse($tokens, PARSE_LIST_ELT); # deal with malformed lists ( foo, bar, , baz ) @right = [] unless @right; @right = [ -MISC => [ @right ] ] if @right > 1; if (!@left) { @left = [ -LIST => [ [], @right ] ]; } elsif ($left[0][0] eq '-LIST') { push @{$left[0][1]}, (@{$right[0]} and $right[0][0] eq '-LIST') ? @{$right[0][1]} : @right ; } else { @left = [ -LIST => [ @left, @right ] ]; } } # binary operator keywords elsif ($token =~ $binary_op_re) { my $op = uc $token; my @right = $self->_recurse_parse($tokens, PARSE_RHS); # A between with a simple LITERAL for a 1st RHS argument needs a # rerun of the search to (hopefully) find the proper AND construct if ($op eq 'BETWEEN' and $right[0] eq '-LITERAL') { unshift @$tokens, $right[1][0]; @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); } push @left, [$op => [ (@left ? pop @left : ''), @right ]]; } # unary op keywords elsif ($token =~ $unary_op_re) { my $op = uc $token; # normalize RNO explicitly $op = 'ROW_NUMBER() OVER' if $op =~ /^$rno_re$/; my @right = $self->_recurse_parse($tokens, PARSE_RHS); push @left, [ $op => \@right ]; } # expression terminator keywords elsif ($token =~ $expr_start_re) { my $op = uc $token; my @right = $self->_recurse_parse($tokens, PARSE_IN_EXPR); push @left, [ $op => \@right ]; } # a '?' elsif ($token =~ $placeholder_re) { push @left, [ -PLACEHOLDER => [ $token ] ]; } # check if the current token is an unknown op-start elsif (@$tokens and ($tokens->[0] eq '(' or $tokens->[0] =~ $placeholder_re ) ) { push @left, [ $token => [ $self->_recurse_parse($tokens, PARSE_RHS) ] ]; } # we're now in "unknown token" land - start eating tokens until # we see something familiar, OR in the case of RHS (binop) stop # after the first token # Also stop processing when we could end up with an unknown func else { my @lits = [ -LITERAL => [$token] ]; unshift @lits, pop @left if @left == 1; unless ( $state == PARSE_RHS ) { while ( @$tokens and $tokens->[0] !~ $all_std_keywords_re and ! (@$tokens > 1 and $tokens->[1] eq '(') ) { push @lits, [ -LITERAL => [ shift @$tokens ] ]; } } @lits = [ -MISC => [ @lits ] ] if @lits > 1; push @left, @lits; } # compress -LITERAL -MISC and -PLACEHOLDER pieces into a single # -MISC container if (@left > 1) { my $i = 0; while ($#left > $i) { if ($left[$i][0] =~ $compressable_node_re and $left[$i+1][0] =~ $compressable_node_re) { splice @left, $i, 2, [ -MISC => [ map { $_->[0] eq '-MISC' ? @{$_->[1]} : $_ } (@left[$i, $i+1]) ]]; } else { $i++; } } } return @left if $state == PARSE_RHS; # deal with post-fix operators if (@$tokens) { # asc/desc if ($tokens->[0] =~ $asc_desc_re) { @left = [ ('-' . uc (shift @$tokens)) => [ @left ] ]; } } } } sub format_keyword { my ($self, $keyword) = @_; if (my $around = $self->colormap->{lc $keyword}) { $keyword = "$around->[0]$keyword$around->[1]"; } return $keyword } my %starters = ( select => 1, update => 1, 'insert into' => 1, 'delete from' => 1, ); sub pad_keyword { my ($self, $keyword, $depth) = @_; my $before = ''; if (defined $self->indentmap->{lc $keyword}) { $before = $self->newline . $self->indent($depth + $self->indentmap->{lc $keyword}); } $before = '' if $depth == 0 and defined $starters{lc $keyword}; return [$before, '']; } sub indent { ($_[0]->indent_string||'') x ( ( $_[0]->indent_amount || 0 ) * $_[1] ) } sub _is_key { my ($self, $tree) = @_; $tree = $tree->[0] while ref $tree; defined $tree && defined $self->indentmap->{lc $tree}; } sub fill_in_placeholder { my ($self, $bindargs) = @_; if ($self->fill_in_placeholders) { my $val = shift @{$bindargs} || ''; my $quoted = $val =~ s/^(['"])(.*)\1$/$2/; my ($left, $right) = @{$self->placeholder_surround}; $val =~ s/\\/\\\\/g; $val =~ s/'/\\'/g; $val = qq('$val') if $quoted; return qq($left$val$right) } return '?' } # FIXME - terrible name for a user facing API sub unparse { my ($self, $tree, $bindargs) = @_; $self->_unparse($tree, [@{$bindargs||[]}], 0); } sub _unparse { my ($self, $tree, $bindargs, $depth) = @_; if (not $tree or not @$tree) { return ''; } # FIXME - needs a config switch to disable $self->_parenthesis_unroll($tree); my ($op, $args) = @{$tree}[0,1]; if (! defined $op or (! ref $op and ! defined $args) ) { require Data::Dumper; Carp::confess( sprintf ( "Internal error - malformed branch at depth $depth:\n%s", Data::Dumper::Dumper($tree) ) ); } if (ref $op) { return join (' ', map $self->_unparse($_, $bindargs, $depth), @$tree); } elsif ($op eq '-LITERAL') { # literal has different sig return $args->[0]; } elsif ($op eq '-PLACEHOLDER') { return $self->fill_in_placeholder($bindargs); } elsif ($op eq '-PAREN') { return sprintf ('( %s )', join (' ', map { $self->_unparse($_, $bindargs, $depth + 2) } @{$args} ) . ($self->_is_key($args) ? ( $self->newline||'' ) . $self->indent($depth + 1) : '' ) ); } elsif ($op eq 'AND' or $op eq 'OR' or $op =~ $binary_op_re ) { return join (" $op ", map $self->_unparse($_, $bindargs, $depth), @{$args}); } elsif ($op eq '-LIST' ) { return join (', ', map $self->_unparse($_, $bindargs, $depth), @{$args}); } elsif ($op eq '-MISC' ) { return join (' ', map $self->_unparse($_, $bindargs, $depth), @{$args}); } elsif ($op =~ qr/^-(ASC|DESC)$/ ) { my $dir = $1; return join (' ', (map $self->_unparse($_, $bindargs, $depth), @{$args}), $dir); } else { my ($l, $r) = @{$self->pad_keyword($op, $depth)}; my $rhs = $self->_unparse($args, $bindargs, $depth); return sprintf "$l%s$r", join( ( ref $args eq 'ARRAY' and @{$args} == 1 and $args->[0][0] eq '-PAREN' ) ? '' # mysql-- : ' ' , $self->format_keyword($op), (length $rhs ? $rhs : () ), ); } } # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics my @unrollable_ops = ( 'ON', 'WHERE', 'GROUP \s+ BY', 'HAVING', 'ORDER \s+ BY', 'I?LIKE', ); my $unrollable_ops_re = join ' | ', @unrollable_ops; $unrollable_ops_re = qr/$unrollable_ops_re/xi; sub _parenthesis_unroll { my $self = shift; my $ast = shift; return unless (ref $ast and ref $ast->[1]); my $changes; do { my @children; $changes = 0; for my $child (@{$ast->[1]}) { # the current node in this loop is *always* a PAREN if (! ref $child or ! @$child or $child->[0] ne '-PAREN') { push @children, $child; next; } my $parent_op = $ast->[0]; # unroll nested parenthesis while ( $parent_op ne 'IN' and @{$child->[1]} == 1 and $child->[1][0][0] eq '-PAREN') { $child = $child->[1][0]; $changes++; } # set to CHILD in the case of PARENT ( CHILD ) # but NOT in the case of PARENT( CHILD1, CHILD2 ) my $single_child_op = (@{$child->[1]} == 1) ? $child->[1][0][0] : ''; my $child_op_argc = $single_child_op ? scalar @{$child->[1][0][1]} : undef; my $single_grandchild_op = ( $child_op_argc||0 == 1 and ref $child->[1][0][1][0] eq 'ARRAY' ) ? $child->[1][0][1][0][0] : '' ; # if the parent operator explicitly allows it AND the child isn't a subselect # nuke the parenthesis if ($parent_op =~ $unrollable_ops_re and $single_child_op ne 'SELECT') { push @children, @{$child->[1]}; $changes++; } # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list elsif ( $single_child_op eq $parent_op and ( $parent_op eq 'AND' or $parent_op eq 'OR') ) { push @children, @{$child->[1][0][1]}; $changes++; } # only *ONE* LITERAL or placeholder element # as an AND/OR/NOT argument elsif ( ( $single_child_op eq '-LITERAL' or $single_child_op eq '-PLACEHOLDER' ) and ( $parent_op eq 'AND' or $parent_op eq 'OR' or $parent_op eq 'NOT' ) ) { push @children, @{$child->[1]}; $changes++; } # an AND/OR expression with only one binop in the parenthesis # with exactly two grandchildren # the only time when we can *not* unroll this is when both # the parent and the child are mathops (in which case we'll # break precedence) or when the child is BETWEEN (special # case) elsif ( ($parent_op eq 'AND' or $parent_op eq 'OR') and $single_child_op =~ $binary_op_re and $single_child_op ne 'BETWEEN' and $child_op_argc == 2 and ! ( $single_child_op =~ $alphanum_cmp_op_re and $parent_op =~ $alphanum_cmp_op_re ) ) { push @children, @{$child->[1]}; $changes++; } # a function binds tighter than a mathop - see if our ancestor is a # mathop, and our content is: # a single non-mathop child with a single PAREN grandchild which # would indicate mathop ( nonmathop ( ... ) ) # or a single non-mathop with a single LITERAL ( nonmathop foo ) # or a single non-mathop with a single PLACEHOLDER ( nonmathop ? ) elsif ( $single_child_op and $parent_op =~ $alphanum_cmp_op_re and $single_child_op !~ $alphanum_cmp_op_re and $child_op_argc == 1 and ( $single_grandchild_op eq '-PAREN' or $single_grandchild_op eq '-LITERAL' or $single_grandchild_op eq '-PLACEHOLDER' ) ) { push @children, @{$child->[1]}; $changes++; } # a construct of ... ( somefunc ( ... ) ) ... can safely lose the outer parens # except for the case of ( NOT ( ... ) ) which has already been handled earlier # and except for the case of RNO, where the double are explicit syntax elsif ( $parent_op ne 'ROW_NUMBER() OVER' and $single_child_op and $single_child_op ne 'NOT' and $child_op_argc == 1 and $single_grandchild_op eq '-PAREN' ) { push @children, @{$child->[1]}; $changes++; } # otherwise no more mucking for this pass else { push @children, $child; } } $ast->[1] = \@children; } while ($changes); } sub _strip_asc_from_order_by { my ($self, $ast) = @_; return $ast if ( ref $ast ne 'ARRAY' or $ast->[0] ne 'ORDER BY' ); my $to_replace; if (@{$ast->[1]} == 1 and $ast->[1][0][0] eq '-ASC') { $to_replace = [ $ast->[1][0] ]; } elsif (@{$ast->[1]} == 1 and $ast->[1][0][0] eq '-LIST') { $to_replace = [ grep { $_->[0] eq '-ASC' } @{$ast->[1][0][1]} ]; } @$_ = @{$_->[1][0]} for @$to_replace; $ast; } sub format { my $self = shift; $self->unparse($self->parse($_[0]), $_[1]) } 1; =pod =head1 NAME SQL::Abstract::Tree - Represent SQL as an AST =head1 SYNOPSIS my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' }); print $sqla_tree->format('SELECT * FROM foo WHERE foo.a > 2'); # SELECT * # FROM foo # WHERE foo.a > 2 =head1 METHODS =head2 new my $sqla_tree = SQL::Abstract::Tree->new({ profile => 'console' }); $args = { profile => 'console', # predefined profile to use (default: 'none') fill_in_placeholders => 1, # true for placeholder population placeholder_surround => # The strings that will be wrapped around [GREEN, RESET], # populated placeholders if the above is set indent_string => ' ', # the string used when indenting indent_amount => 2, # how many of above string to use for a single # indent level newline => "\n", # string for newline colormap => { select => [RED, RESET], # a pair of strings defining what to surround # the keyword with for colorization # ... }, indentmap => { select => 0, # A zero means that the keyword will start on # a new line from => 1, # Any other positive integer means that after on => 2, # said newline it will get that many indents # ... }, } Returns a new SQL::Abstract::Tree object. All arguments are optional. =head3 profiles There are four predefined profiles, C, C, C, and C. Typically a user will probably just use C or C, but if something about a profile bothers you, merely use the profile and override the parts that you don't like. =head2 format $sqlat->format('SELECT * FROM bar WHERE x = ?', [1]) Takes C<$sql> and C<\@bindargs>. Returns a formatting string based on the string passed in =head2 parse $sqlat->parse('SELECT * FROM bar WHERE x = ?') Returns a "tree" representing passed in SQL. Please do not depend on the structure of the returned tree. It may be stable at some point, but not yet. =head2 unparse $sqlat->unparse($tree_structure, \@bindargs) Transform "tree" into SQL, applying various transforms on the way. =head2 format_keyword $sqlat->format_keyword('SELECT') Currently this just takes a keyword and puts the C stuff around it. Later on it may do more and allow for coderef based transforms. =head2 pad_keyword my ($before, $after) = @{$sqlat->pad_keyword('SELECT')}; Returns whitespace to be inserted around a keyword. =head2 fill_in_placeholder my $value = $sqlat->fill_in_placeholder(\@bindargs) Removes last arg from passed arrayref and returns it, surrounded with the values in placeholder_surround, and then surrounded with single quotes. =head2 indent Returns as many indent strings as indent amounts times the first argument. =head1 ACCESSORS =head2 colormap See L =head2 fill_in_placeholders See L =head2 indent_amount See L =head2 indent_string See L =head2 indentmap See L =head2 newline See L =head2 placeholder_surround See L SQL-Abstract-2.000001/lib/SQL/Abstract/Formatter.pm0000644000000000000000000000464214002362432021405 0ustar00rootroot00000000000000package SQL::Abstract::Formatter; require SQL::Abstract::Parts; # it loads us too, don't cross the streams use Moo; has indent_by => (is => 'ro', default => ' '); has max_width => (is => 'ro', default => 78); sub _join { shift; return SQL::Abstract::Parts::stringify(\@_); } sub format { my ($self, $join, @parts) = @_; $self->_fold_sql('', '', @{$self->_simplify($join, @parts)}); } sub _simplify { my ($self, $join, @parts) = @_; return '' unless @parts; return $parts[0] if @parts == 1 and !ref($parts[0]); return $self->_simplify(@{$parts[0]}) if @parts == 1; return [ $join, map ref() ? $self->_simplify(@$_) : $_, @parts ]; } sub _fold_sql { my ($self, $indent0, $indent, $join, @parts) = @_; my @res; my $w = $self->max_width; my $join_len = 0; (s/, \z/,\n/ and $join_len = 1) or s/\a /\n/ or $_ = "\n" for my $line_join = $join; my ($nl_pre, $nl_post) = split "\n", $line_join; my $line_orig = my $line = $indent0; my $next_indent = $indent.$self->indent_by; my $line_proto = $indent.$nl_post; PART: foreach my $idx (0..$#parts) { my $p = $parts[$idx]; #::DwarnT STARTPART => $p, \@res, $line, $line_orig; my $pre = ($line ne $line_orig ? $join : ''); my $j_part = $pre.(my $j = ref($p) ? $self->_join(@$p) : $p); if (length($j_part) + length($line) + $join_len <= $w) { $line .= $j_part; next PART; } my $innerdent = @res ? $next_indent : $indent0.$self->indent_by; if (ref($p) and $p->[1] eq '(' and $p->[-1] eq ')') { my $already = !($line eq $indent0 or $line eq $line_orig); push @res, $line.($already ? $join : '').'('."\n"; my (undef, undef, $inner) = @$p; my $folded = $self->_fold_sql($innerdent, $innerdent, @$inner); $folded =~ s/\n\z//; push @res, $folded."\n"; $line_orig = $line = $indent0.')'.($idx == $#parts ? '' : $join); next PART; } if ($line ne $line_orig) { push @res, $line.($idx == $#parts ? '' : $nl_pre)."\n"; } if (length($line = $line_proto.$j) <= $w) { next PART; } my $folded = $self->_fold_sql($line_proto, $innerdent, @$p); $folded =~ s/\n\z//; push @res, $folded.($idx == $#parts ? '' : $nl_pre)."\n"; $line_orig = $line = $idx == $#parts ? '' : $line_proto; } continue { #::DwarnT ENDPART => $parts[$idx], \@res, $line, $line_orig; } return join '', @res, $line; } 1; SQL-Abstract-2.000001/lib/SQL/Abstract/Parts.pm0000644000000000000000000000127114002747171020535 0ustar00rootroot00000000000000package SQL::Abstract::Parts; use Module::Runtime (); use Scalar::Util (); use strict; use warnings; use overload '""' => 'stringify', fallback => 1; sub new { my ($proto, $join, @parts) = @_; bless([ $join, map Scalar::Util::blessed($_) ? [ @$_ ] : $_, @parts ], ref($proto) || $proto); } sub stringify { my ($self) = @_; my ($join, @parts) = @$self; return join($join, map +(ref() ? stringify($_) : $_), @parts); } sub to_array { return @{$_[0]} } sub formatter { my ($self, %opts) = @_; require SQL::Abstract::Formatter; SQL::Abstract::Formatter->new(%opts) } sub format { my ($self, %opts) = @_; $self->formatter(%opts) ->format($self->to_array); } 1; SQL-Abstract-2.000001/lib/SQL/Abstract/Role/0000755000000000000000000000000014002747454020012 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/SQL/Abstract/Role/Plugin.pm0000644000000000000000000000244714002362432021602 0ustar00rootroot00000000000000package SQL::Abstract::Role::Plugin; use Moo::Role; has sqla => ( is => 'ro', init_arg => undef, handles => [ qw( expand_expr render_aqt join_query_parts ) ], ); sub cb { my ($self, $method, @args) = @_; return sub { local $self->{sqla} = shift; $self->$method(@args, @_) }; } sub register { my ($self, @pairs) = @_; my $sqla = $self->sqla; while (my ($method, $cases) = splice(@pairs, 0, 2)) { my @cases = @$cases; while (my ($name, $case) = splice(@cases, 0, 2)) { $sqla->$method($name, $self->cb($case)); } } return $self; } sub apply_to { my ($self, $sqla) = @_; $self = $self->new unless ref($self); local $self->{sqla} = $sqla; $self->register_extensions($sqla); } requires 'register_extensions'; 1; __END__ =head1 NAME SQL::Abstract::Role::Plugin - helpful methods for plugin authors =head1 METHODS =head2 apply_to Applies the plugin to an L object. =head2 register_extensions Provided by the plugin, registers its extensions to the sqla object. =head2 cb Creates a callback to call a method on the plugin. =head2 register Calls methods on the sqla object with arguments wrapped as callbacks. =head2 sqla Available only during plugin callback executions, contains the currently active L object. =cut SQL-Abstract-2.000001/lib/SQL/Abstract/Reference.pm0000644000000000000000000005526514002362432021347 0ustar00rootroot00000000000000package SQL::Abstract::Reference; 1; __END__ =head1 NAME SQL::Abstract::Reference - Reference documentation for L =head1 TERMS =head2 Expression (expr) The DWIM structure that's passed to most methods by default is referred to as expression syntax. If you see a variable with C in the name, or a comment before a code block saying C<# expr>, this is what's being described. =head2 Abstract Query Tree (aqt) The explicit structure that an expression is converted into before it's rendered into SQL is referred to as an abstract query tree. If you see a variable with C in the name, or a comment before a code block saying C<# aqt>, this is what's being described. =head2 SQL and Bind Values (query) The final result of L rendering is generally an SQL statement plus bind values for passing to DBI, ala: my ($sql, @bind) = $sqla->some_method(@args); my @hashes = @{$dbh->do($sql, { Slice => {} }, @bind)}; If you see a comment before a code block saying C<# query>, the SQL + bind array is what's being described. =head2 Expander An expander subroutine is written as: sub { my ($sqla, $name, $value, $k) = @_; ... return $aqt; } $name is the expr node type for node expanders, the op name for op expanders, and the clause name for clause expanders. $value is the body of the thing being expanded If an op expander is being called as the binary operator in a L expression, $k will be the hash key to be used as the left hand side identifier. This can trivially be converted to an C type AQT node with: my $ident = $sqla->expand_expr({ -ident => $k }); =head2 Renderer A renderer subroutine looks like: sub { my ($sqla, $type, $value) = @_; ... $sqla->join_query_parts($join, @parts); } and can be registered on a per-type, per-op or per-clause basis. =head1 AQT node types An AQT node consists of a hashref with a single key, whose name is C<-type> where 'type' is the node type, and whose value is the data for the node. The following is an explanation of the built-in AQT type renderers; additional renderers can be registered as part of the extension system. =head2 literal # expr { -literal => [ 'SPANG(?, ?)', 1, 27 ] } # query SPANG(?, ?) [ 1, 27 ] =head2 ident # expr { -ident => 'foo' } # query foo [] # expr { -ident => [ 'foo', 'bar' ] } # query foo.bar [] =head2 bind # expr { -bind => [ 'colname', 'value' ] } # query ? [ 'value' ] =head2 row # expr { -row => [ { -bind => [ 'r', 1 ] }, { -ident => [ 'clown', 'car' ] } ] } # query (?, clown.car) [ 1 ] =head2 func # expr { -func => [ 'foo', { -ident => [ 'bar' ] }, { -bind => [ undef, 7 ] } ] } # query FOO(bar, ?) [ 7 ] =head2 op Standard binop: # expr { -op => [ '=', { -ident => [ 'bomb', 'status' ] }, { -value => 'unexploded' }, ] } # query bomb.status = ? [ 'unexploded' ] Prefix unop: # expr { -op => [ '-', { -ident => 'foo' } ] } # query - foo [] Not as special case parenthesised unop: # expr { -op => [ 'not', { -ident => 'explosive' } ] } # query (NOT explosive) [] Postfix unop: (is_null, is_not_null, asc, desc) # expr { -op => [ 'is_null', { -ident => [ 'bobby' ] } ] } # query bobby IS NULL [] AND and OR: # expr { -op => [ 'and', { -ident => 'x' }, { -ident => 'y' }, { -ident => 'z' } ] } # query ( x AND y AND z ) [] IN (and NOT IN): # expr { -op => [ 'in', { -ident => 'card' }, { -bind => [ 'card', 3 ] }, { -bind => [ 'card', 'J' ] }, ] } # query card IN ( ?, ? ) [ 3, 'J' ] BETWEEN (and NOT BETWEEN): # expr { -op => [ 'between', { -ident => 'pints' }, { -bind => [ 'pints', 2 ] }, { -bind => [ 'pints', 4 ] }, ] } # query ( pints BETWEEN ? AND ? ) [ 2, 4 ] Comma (use -row for parens): # expr { -op => [ ',', { -literal => [ 1 ] }, { -literal => [ 2 ] } ] } # query 1, 2 [] =head2 values # expr { -values => { -row => [ { -bind => [ undef, 1 ] }, { -bind => [ undef, 2 ] } ] } } # query VALUES (?, ?) [ 1, 2 ] # expr { -values => [ { -row => [ { -literal => [ 1 ] }, { -literal => [ 2 ] } ] }, { -row => [ { -literal => [ 3 ] }, { -literal => [ 4 ] } ] }, ] } # query VALUES (1, 2), (3, 4) [] =head2 keyword # expr { -keyword => 'insert_into' } # query INSERT INTO [] =head2 statement types AQT node types are also provided for C statement. Note, however, this is not part of the SQL standard and may not be supported by all database engines. =back =head2 update($table, \%fieldvals, \%where, \%options) This takes a table, hashref of field/value pairs, and an optional hashref L. It returns an SQL UPDATE function and a list of bind values. See the sections on L and L for information on how to insert with those data types. The optional C<\%options> hash reference may contain additional options to generate the update SQL. Currently supported options are: =over 4 =item returning See the C option to L. =back =head2 select($source, $fields, $where, $order) This returns a SQL SELECT statement and associated list of bind values, as specified by the arguments: =over =item $source Specification of the 'FROM' part of the statement. The argument can be either a plain scalar (interpreted as a table name, will be quoted), or an arrayref (interpreted as a list of table names, joined by commas, quoted), or a scalarref (literal SQL, not quoted). =item $fields Specification of the list of fields to retrieve from the source. The argument can be either an arrayref (interpreted as a list of field names, will be joined by commas and quoted), or a plain scalar (literal SQL, not quoted). Please observe that this API is not as flexible as that of the first argument C<$source>, for backwards compatibility reasons. =item $where Optional argument to specify the WHERE part of the query. The argument is most often a hashref, but can also be an arrayref or plain scalar -- see section L for details. =item $order Optional argument to specify the ORDER BY part of the query. The argument can be a scalar, a hashref or an arrayref -- see section L for details. =back =head2 delete($table, \%where, \%options) This takes a table name and optional hashref L. It returns an SQL DELETE statement and list of bind values. The optional C<\%options> hash reference may contain additional options to generate the delete SQL. Currently supported options are: =over 4 =item returning See the C option to L. =back =head2 where(\%where, $order) This is used to generate just the WHERE clause. For example, if you have an arbitrary data structure and know what the rest of your SQL is going to look like, but want an easy way to produce a WHERE clause, use this. It returns an SQL WHERE clause and list of bind values. =head2 values(\%data) This just returns the values from the hash C<%data>, in the same order that would be returned from any of the other above queries. Using this allows you to markedly speed up your queries if you are affecting lots of rows. See below under the L section. =head2 generate($any, 'number', $of, \@data, $struct, \%types) Warning: This is an experimental method and subject to change. This returns arbitrarily generated SQL. It's a really basic shortcut. It will return two different things, depending on return context: my($stmt, @bind) = $sql->generate('create table', \$table, \@fields); my $stmt_and_val = $sql->generate('create table', \$table, \@fields); These would return the following: # First calling form $stmt = "CREATE TABLE test (?, ?)"; @bind = (field1, field2); # Second calling form $stmt_and_val = "CREATE TABLE test (field1, field2)"; Depending on what you're trying to do, it's up to you to choose the correct format. In this example, the second form is what you would want. By the same token: $sql->generate('alter session', { nls_date_format => 'MM/YY' }); Might give you: ALTER SESSION SET nls_date_format = 'MM/YY' You get the idea. Strings get their case twiddled, but everything else remains verbatim. =head1 EXPORTABLE FUNCTIONS =head2 is_plain_value Determines if the supplied argument is a plain value as understood by this module: =over =item * The value is C =item * The value is a non-reference =item * The value is an object with stringification overloading =item * The value is of the form C<< { -value => $anything } >> =back On failure returns C, on success returns a B reference to the original supplied argument. =over =item * Note The stringification overloading detection is rather advanced: it takes into consideration not only the presence of a C<""> overload, but if that fails also checks for enabled L|overload/Magic Autogeneration>, based on either C<0+> or C. Unfortunately testing in the field indicates that this detection B<< may tickle a latent bug in perl versions before 5.018 >>, but only when very large numbers of stringifying objects are involved. At the time of writing ( Sep 2014 ) there is no clear explanation of the direct cause, nor is there a manageably small test case that reliably reproduces the problem. If you encounter any of the following exceptions in B - this module may be to blame: Operation "ne": no method found, left argument in overloaded package , right argument in overloaded package or perhaps even Stub found while resolving method "???" overloading """" in package If you fall victim to the above - please attempt to reduce the problem to something that could be sent to the L (either publicly or privately). As a workaround in the meantime you can set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true value, which will most likely eliminate your problem (at the expense of not being able to properly detect exotic forms of stringification). This notice and environment variable will be removed in a future version, as soon as the underlying problem is found and a reliable workaround is devised. =back =head2 is_literal_value Determines if the supplied argument is a literal value as understood by this module: =over =item * C<\$sql_string> =item * C<\[ $sql_string, @bind_values ]> =back On failure returns C, on success returns an B reference containing the unpacked version of the supplied literal SQL and bind values. =head2 is_undef_value Tests for undef, whether expanded or not. =head1 WHERE CLAUSES =head2 Introduction This module uses a variation on the idea from L. It is B, repeat I 100% compatible. B The easiest way to explain is to show lots of examples. After each C<%where> hash shown, it is assumed you used: my($stmt, @bind) = $sql->where(\%where); However, note that the C<%where> hash can be used directly in any of the other functions as well, as described above. =head2 Key-value pairs So, let's get started. To begin, a simple hash: my %where = ( user => 'nwiger', status => 'completed' ); Is converted to SQL C statements: $stmt = "WHERE user = ? AND status = ?"; @bind = ('nwiger', 'completed'); One common thing I end up doing is having a list of values that a field can be in. To do this, simply specify a list inside of an arrayref: my %where = ( user => 'nwiger', status => ['assigned', 'in-progress', 'pending']; ); This simple code will create the following: $stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )"; @bind = ('nwiger', 'assigned', 'in-progress', 'pending'); A field associated to an empty arrayref will be considered a logical false and will generate 0=1. =head2 Tests for NULL values If the value part is C then this is converted to SQL my %where = ( user => 'nwiger', status => undef, ); becomes: $stmt = "WHERE user = ? AND status IS NULL"; @bind = ('nwiger'); To test if a column IS NOT NULL: my %where = ( user => 'nwiger', status => { '!=', undef }, ); =head2 Specific comparison operators If you want to specify a different type of operator for your comparison, you can use a hashref for a given column: my %where = ( user => 'nwiger', status => { '!=', 'completed' } ); Which would generate: $stmt = "WHERE user = ? AND status != ?"; @bind = ('nwiger', 'completed'); To test against multiple values, just enclose the values in an arrayref: status => { '=', ['assigned', 'in-progress', 'pending'] }; Which would give you: "WHERE status = ? OR status = ? OR status = ?" The hashref can also contain multiple pairs, in which case it is expanded into an C of its elements: my %where = ( user => 'nwiger', status => { '!=', 'completed', -not_like => 'pending%' } ); # Or more dynamically, like from a form $where{user} = 'nwiger'; $where{status}{'!='} = 'completed'; $where{status}{'-not_like'} = 'pending%'; # Both generate this $stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?"; @bind = ('nwiger', 'completed', 'pending%'); To get an OR instead, you can combine it with the arrayref idea: my %where => ( user => 'nwiger', priority => [ { '=', 2 }, { '>', 5 } ] ); Which would generate: $stmt = "WHERE ( priority = ? OR priority > ? ) AND user = ?"; @bind = ('2', '5', 'nwiger'); If you want to include literal SQL (with or without bind values), just use a scalar reference or reference to an arrayref as the value: my %where = ( date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] }, date_expires => { '<' => \"now()" } ); Which would generate: $stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()"; @bind = ('11/26/2008'); =head2 Logic and nesting operators In the example above, there is a subtle trap if you want to say something like this (notice the C): WHERE priority != ? AND priority != ? Because, in Perl you I do this: priority => { '!=' => 2, '!=' => 1 } As the second C key will obliterate the first. The solution is to use the special C<-modifier> form inside an arrayref: priority => [ -and => {'!=', 2}, {'!=', 1} ] Normally, these would be joined by C, but the modifier tells it to use C instead. (Hint: You can use this in conjunction with the C option to C in order to change the way your queries work by default.) B Note that the C<-modifier> goes B the arrayref, as an extra first element. This will B do what you think it might: priority => -and => [{'!=', 2}, {'!=', 1}] # WRONG! Here is a quick list of equivalencies, since there is some overlap: # Same status => {'!=', 'completed', 'not like', 'pending%' } status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}] # Same status => {'=', ['assigned', 'in-progress']} status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}] status => [ {'=', 'assigned'}, {'=', 'in-progress'} ] =head2 Special operators: IN, BETWEEN, etc. You can also use the hashref format to compare a list of fields using the C comparison operator, by specifying the list as an arrayref: my %where = ( status => 'completed', reportid => { -in => [567, 2335, 2] } ); Which would generate: $stmt = "WHERE status = ? AND reportid IN (?,?,?)"; @bind = ('completed', '567', '2335', '2'); The reverse operator C<-not_in> generates SQL C and is used in the same way. If the argument to C<-in> is an empty array, 'sqlfalse' is generated (by default: C<1=0>). Similarly, C<< -not_in => [] >> generates 'sqltrue' (by default: C<1=1>). In addition to the array you can supply a chunk of literal sql or literal sql with bind: my %where = { customer => { -in => \[ 'SELECT cust_id FROM cust WHERE balance > ?', 2000, ], status => { -in => \'SELECT status_codes FROM states' }, }; would generate: $stmt = "WHERE ( customer IN ( SELECT cust_id FROM cust WHERE balance > ? ) AND status IN ( SELECT status_codes FROM states ) )"; @bind = ('2000'); Finally, if the argument to C<-in> is not a reference, it will be treated as a single-element array. Another pair of operators is C<-between> and C<-not_between>, used with an arrayref of two values: my %where = ( user => 'nwiger', completion_date => { -not_between => ['2002-10-01', '2003-02-06'] } ); Would give you: WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? ) Just like with C<-in> all plausible combinations of literal SQL are possible: my %where = { start0 => { -between => [ 1, 2 ] }, start1 => { -between => \["? AND ?", 1, 2] }, start2 => { -between => \"lower(x) AND upper(y)" }, start3 => { -between => [ \"lower(x)", \["upper(?)", 'stuff' ], ] }, }; Would give you: $stmt = "WHERE ( ( start0 BETWEEN ? AND ? ) AND ( start1 BETWEEN ? AND ? ) AND ( start2 BETWEEN lower(x) AND upper(y) ) AND ( start3 BETWEEN lower(x) AND upper(?) ) )"; @bind = (1, 2, 1, 2, 'stuff'); These are the two builtin "special operators"; but the list can be expanded: see section L below. =head2 Unary operators: bool If you wish to test against boolean columns or functions within your database you can use the C<-bool> and C<-not_bool> operators. For example to test the column C being true and the column C being false you would use:- my %where = ( -bool => 'is_user', -not_bool => 'is_enabled', ); Would give you: WHERE is_user AND NOT is_enabled If a more complex combination is required, testing more conditions, then you should use the and/or operators:- my %where = ( -and => [ -bool => 'one', -not_bool => { two=> { -rlike => 'bar' } }, -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] }, ], ); Would give you: WHERE one AND (NOT two RLIKE ?) AND (NOT ( three = ? OR three > ? )) =head2 Nested conditions, -and/-or prefixes So far, we've seen how multiple conditions are joined with a top-level C. We can change this by putting the different conditions we want in hashes and then putting those hashes in an array. For example: my @where = ( { user => 'nwiger', status => { -like => ['pending%', 'dispatched'] }, }, { user => 'robot', status => 'unassigned', } ); This data structure would create the following: $stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) ) OR ( user = ? AND status = ? ) )"; @bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned'); Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or> to change the logic inside: my @where = ( -and => [ user => 'nwiger', [ -and => [ workhrs => {'>', 20}, geo => 'ASIA' ], -or => { workhrs => {'<', 50}, geo => 'EURO' }, ], ], ); That would yield: $stmt = "WHERE ( user = ? AND ( ( workhrs > ? AND geo = ? ) OR ( workhrs < ? OR geo = ? ) ) )"; @bind = ('nwiger', '20', 'ASIA', '50', 'EURO'); =head3 Algebraic inconsistency, for historical reasons C: when connecting several conditions, the C<-and->|C<-or> operator goes C of the nested structure; whereas when connecting several constraints on one column, the C<-and> operator goes C the arrayref. Here is an example combining both features: my @where = ( -and => [a => 1, b => 2], -or => [c => 3, d => 4], e => [-and => {-like => 'foo%'}, {-like => '%bar'} ] ) yielding WHERE ( ( ( a = ? AND b = ? ) OR ( c = ? OR d = ? ) OR ( e LIKE ? AND e LIKE ? ) ) ) This difference in syntax is unfortunate but must be preserved for historical reasons. So be careful: the two examples below would seem algebraically equivalent, but they are not { col => [ -and => { -like => 'foo%' }, { -like => '%bar' }, ] } # yields: WHERE ( ( col LIKE ? AND col LIKE ? ) ) [ -and => { col => { -like => 'foo%' } }, { col => { -like => '%bar' } }, ] # yields: WHERE ( ( col LIKE ? OR col LIKE ? ) ) =head2 Literal SQL and value type operators The basic premise of SQL::Abstract is that in WHERE specifications the "left side" is a column name and the "right side" is a value (normally rendered as a placeholder). This holds true for both hashrefs and arrayref pairs as you see in the L examples above. Sometimes it is necessary to alter this behavior. There are several ways of doing so. =head3 -ident This is a virtual operator that signals the string to its right side is an identifier (a column name) and not a value. For example to compare two columns you would write: my %where = ( priority => { '<', 2 }, requestor => { -ident => 'submitter' }, ); which creates: $stmt = "WHERE priority < ? AND requestor = submitter"; @bind = ('2'); If you are maintaining legacy code you may see a different construct as described in L, please use C<-ident> in new code. =head3 -value This is a virtual operator that signals that the construct to its right side is a value to be passed to DBI. This is for example necessary when you want to write a where clause against an array (for RDBMS that support such datatypes). For example: my %where = ( array => { -value => [1, 2, 3] } ); will result in: $stmt = 'WHERE array = ?'; @bind = ([1, 2, 3]); Note that if you were to simply say: my %where = ( array => [1, 2, 3] ); the result would probably not be what you wanted: $stmt = 'WHERE array = ? OR array = ? OR array = ?'; @bind = (1, 2, 3); =head3 Literal SQL Finally, sometimes only literal SQL will do. To include a random snippet of SQL verbatim, you specify it as a scalar reference. Consider this only as a last resort. Usually there is a better way. For example: my %where = ( priority => { '<', 2 }, requestor => { -in => \'(SELECT name FROM hitmen)' }, ); Would create: $stmt = "WHERE priority < ? AND requestor IN (SELECT name FROM hitmen)" @bind = (2); Note that in this example, you only get one bind parameter back, since the verbatim SQL is passed as part of the statement. =head4 CAVEAT Never use untrusted input as a literal SQL argument - this is a massive security risk (there is no way to check literal snippets for SQL injections and other nastyness). If you need to deal with untrusted input use literal SQL with placeholders as described next. =head3 Literal SQL with placeholders and bind values (subqueries) If the literal SQL to be inserted has placeholders and bind values, use a reference to an arrayref (yes this is a double reference -- not so common, but perfectly legal Perl). For example, to find a date in Postgres you can use something like this: my %where = ( date_column => \[ "= date '2008-09-30' - ?::integer", 10 ] ) This would create: $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )" @bind = ('10'); Note that you must pass the bind values in the same format as they are returned by L. This means that if you set L to C, you must provide the bind values in the C<< [ column_meta => value ] >> format, where C is an opaque scalar value; most commonly the column name, but you can use any scalar value (including references and blessed references), L will simply pass it through intact. So if C is set to C the above example will look like: my %where = ( date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ] ) Literal SQL is especially useful for nesting parenthesized clauses in the main SQL query. Here is a first example: my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", 100, "foo%"); my %where = ( foo => 1234, bar => \["IN ($sub_stmt)" => @sub_bind], ); This yields: $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?))"; @bind = (1234, 100, "foo%"); Other subquery operators, like for example C<"E ALL"> or C<"NOT IN">, are expressed in the same way. Of course the C<$sub_stmt> and its associated bind values can be generated through a former call to C : my ($sub_stmt, @sub_bind) = $sql->select("t1", "c1", {c2 => {"<" => 100}, c3 => {-like => "foo%"}}); my %where = ( foo => 1234, bar => \["> ALL ($sub_stmt)" => @sub_bind], ); In the examples above, the subquery was used as an operator on a column; but the same principle also applies for a clause within the main C<%where> hash, like an EXISTS subquery: my ($sub_stmt, @sub_bind) = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); my %where = ( -and => [ foo => 1234, \["EXISTS ($sub_stmt)" => @sub_bind], ]); which yields $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1 WHERE c1 = ? AND c2 > t0.c0))"; @bind = (1234, 1); Observe that the condition on C in the subquery refers to column C of the main query: this is I a bind value, so we have to express it through a scalar ref. Writing C<< c2 => {">" => "t0.c0"} >> would have generated C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly what we wanted here. Finally, here is an example where a subquery is used for expressing unary negation: my ($sub_stmt, @sub_bind) = $sql->where({age => [{"<" => 10}, {">" => 20}]}); $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause my %where = ( lname => {like => '%son%'}, \["NOT ($sub_stmt)" => @sub_bind], ); This yields $stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )" @bind = ('%son%', 10, 20) =head3 Deprecated usage of Literal SQL Below are some examples of archaic use of literal SQL. It is shown only as reference for those who deal with legacy code. Each example has a much better, cleaner and safer alternative that users should opt for in new code. =over =item * my %where = ( requestor => \'IS NOT NULL' ) $stmt = "WHERE requestor IS NOT NULL" This used to be the way of generating NULL comparisons, before the handling of C got formalized. For new code please use the superior syntax as described in L. =item * my %where = ( requestor => \'= submitter' ) $stmt = "WHERE requestor = submitter" This used to be the only way to compare columns. Use the superior L method for all new code. For example an identifier declared in such a way will be properly quoted if L is properly set, while the legacy form will remain as supplied. =item * my %where = ( is_ready => \"", completed => { '>', '2012-12-21' } ) $stmt = "WHERE completed > ? AND is_ready" @bind = ('2012-12-21') Using an empty string literal used to be the only way to express a boolean. For all new code please use the much more readable L<-bool|/Unary operators: bool> operator. =back =head2 Conclusion These pages could go on for a while, since the nesting of the data structures this module can handle are pretty much unlimited (the module implements the C expansion as a recursive function internally). Your best bet is to "play around" with the module a little to see how the data structures behave, and choose the best format for your data based on that. And of course, all the values above will probably be replaced with variables gotten from forms or the command line. After all, if you knew everything ahead of time, you wouldn't have to worry about dynamically-generating SQL and could just hardwire it into your script. =head1 ORDER BY CLAUSES Some functions take an order by clause. This can either be a scalar (just a column name), a hashref of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>, a scalarref, an arrayref-ref, or an arrayref of any of the previous forms. Examples: Given | Will Generate --------------------------------------------------------------- | 'colA' | ORDER BY colA | [qw/colA colB/] | ORDER BY colA, colB | {-asc => 'colA'} | ORDER BY colA ASC | {-desc => 'colB'} | ORDER BY colB DESC | ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC | { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC | \'colA DESC' | ORDER BY colA DESC | \[ 'FUNC(colA, ?)', $x ] | ORDER BY FUNC(colA, ?) | /* ...with $x bound to ? */ | [ | ORDER BY { -asc => 'colA' }, | colA ASC, { -desc => [qw/colB/] }, | colB DESC, { -asc => [qw/colC colD/] },| colC ASC, colD ASC, \'colE DESC', | colE DESC, \[ 'FUNC(colF, ?)', $x ], | FUNC(colF, ?) ] | /* ...with $x bound to ? */ =============================================================== =head1 OLD EXTENSION SYSTEM =head2 SPECIAL OPERATORS my $sqlmaker = SQL::Abstract->new(special_ops => [ { regex => qr/.../, handler => sub { my ($self, $field, $op, $arg) = @_; ... }, }, { regex => qr/.../, handler => 'method_name', }, ]); A "special operator" is a SQL syntactic clause that can be applied to a field, instead of a usual binary operator. For example: WHERE field IN (?, ?, ?) WHERE field BETWEEN ? AND ? WHERE MATCH(field) AGAINST (?, ?) Special operators IN and BETWEEN are fairly standard and therefore are builtin within C (as the overridable methods C<_where_field_IN> and C<_where_field_BETWEEN>). For other operators, like the MATCH .. AGAINST example above which is specific to MySQL, you can write your own operator handlers - supply a C argument to the C method. That argument takes an arrayref of operator definitions; each operator definition is a hashref with two entries: =over =item regex the regular expression to match the operator =item handler Either a coderef or a plain scalar method name. In both cases the expected return is C<< ($sql, @bind) >>. When supplied with a method name, it is simply called on the L object as: $self->$method_name($field, $op, $arg) Where: $field is the LHS of the operator $op is the part that matched the handler regex $arg is the RHS When supplied with a coderef, it is called as: $coderef->($self, $field, $op, $arg) =back For example, here is an implementation of the MATCH .. AGAINST syntax for MySQL my $sqlmaker = SQL::Abstract->new(special_ops => [ # special op for MySql MATCH (field) AGAINST(word1, word2, ...) {regex => qr/^match$/i, handler => sub { my ($self, $field, $op, $arg) = @_; $arg = [$arg] if not ref $arg; my $label = $self->_quote($field); my ($placeholder) = $self->_convert('?'); my $placeholders = join ", ", (($placeholder) x @$arg); my $sql = $self->_sqlcase('match') . " ($label) " . $self->_sqlcase('against') . " ($placeholders) "; my @bind = $self->_bindtype($field, @$arg); return ($sql, @bind); } }, ]); =head2 UNARY OPERATORS my $sqlmaker = SQL::Abstract->new(unary_ops => [ { regex => qr/.../, handler => sub { my ($self, $op, $arg) = @_; ... }, }, { regex => qr/.../, handler => 'method_name', }, ]); A "unary operator" is a SQL syntactic clause that can be applied to a field - the operator goes before the field You can write your own operator handlers - supply a C argument to the C method. That argument takes an arrayref of operator definitions; each operator definition is a hashref with two entries: =over =item regex the regular expression to match the operator =item handler Either a coderef or a plain scalar method name. In both cases the expected return is C<< $sql >>. When supplied with a method name, it is simply called on the L object as: $self->$method_name($op, $arg) Where: $op is the part that matched the handler regex $arg is the RHS or argument of the operator When supplied with a coderef, it is called as: $coderef->($self, $op, $arg) =back =head1 NEW METHODS (EXPERIMENTAL) See L for the C versus C concept and an explanation of what the below extensions are extending. =head2 plugin $sqla->plugin('+Foo'); Enables plugin SQL::Abstract::Plugin::Foo. =head2 render_expr my ($sql, @bind) = $sqla->render_expr($expr); =head2 render_statement Use this if you may be rendering a top level statement so e.g. a SELECT query doesn't get wrapped in parens my ($sql, @bind) = $sqla->render_statement($expr); =head2 expand_expr Expression expansion with optional default for scalars. my $aqt = $self->expand_expr($expr); my $aqt = $self->expand_expr($expr, -ident); =head2 render_aqt Top level means avoid parens on statement AQT. my $res = $self->render_aqt($aqt, $top_level); my ($sql, @bind) = @$res; =head2 join_query_parts Similar to join() but will render hashrefs as nodes for both join and parts, and treats arrayref as a nested C<[ $join, @parts ]> structure. my $part = $self->join_query_parts($join, @parts); =head1 NEW EXTENSION SYSTEM =head2 clone my $sqla2 = $sqla->clone; Performs a semi-shallow copy such that extension methods won't leak state but excessive depth is avoided. =head2 expander =head2 expanders =head2 op_expander =head2 op_expanders =head2 clause_expander =head2 clause_expanders $sqla->expander('name' => sub { ... }); $sqla->expanders('name1' => sub { ... }, 'name2' => sub { ... }); =head2 expander_list =head2 op_expander_list =head2 clause_expander_list my @names = $sqla->expander_list; =head2 wrap_expander =head2 wrap_expanders =head2 wrap_op_expander =head2 wrap_op_expanders =head2 wrap_clause_expander =head2 wrap_clause_expanders $sqla->wrap_expander('name' => sub { my ($orig) = @_; sub { ... } }); $sqla->wrap_expanders( 'name1' => sub { my ($orig1) = @_; sub { ... } }, 'name2' => sub { my ($orig2) = @_; sub { ... } }, ); =head2 renderer =head2 renderers =head2 op_renderer =head2 op_renderers =head2 clause_renderer =head2 clause_renderers $sqla->renderer('name' => sub { ... }); $sqla->renderers('name1' => sub { ... }, 'name2' => sub { ... }); =head2 renderer_list =head2 op_renderer_list =head2 clause_renderer_list my @names = $sqla->renderer_list; =head2 wrap_renderer =head2 wrap_renderers =head2 wrap_op_renderer =head2 wrap_op_renderers =head2 wrap_clause_renderer =head2 wrap_clause_renderers $sqla->wrap_renderer('name' => sub { my ($orig) = @_; sub { ... } }); $sqla->wrap_renderers( 'name1' => sub { my ($orig1) = @_; sub { ... } }, 'name2' => sub { my ($orig2) = @_; sub { ... } }, ); =head2 clauses_of my @clauses = $sqla->clauses_of('select'); $sqla->clauses_of(select => \@new_clauses); $sqla->clauses_of(select => sub { my (undef, @old_clauses) = @_; ... return @new_clauses; }); =head2 statement_list my @list = $sqla->statement_list; =head2 make_unop_expander my $exp = $sqla->make_unop_expander(sub { ... }); If the op is found as a binop, assumes it wants a default comparison, so the inner expander sub can reliably operate as sub { my ($self, $name, $body) = @_; ... } =head2 make_binop_expander my $exp = $sqla->make_binop_expander(sub { ... }); If the op is found as a unop, assumes the value will be an arrayref with the LHS as the first entry, and converts that to an ident node if it's a simple scalar. So the inner expander sub looks like sub { my ($self, $name, $body, $k) = @_; { -blah => [ map $self->expand_expr($_), $k, $body ] } } =head2 unop_expander =head2 unop_expanders =head2 binop_expander =head2 binop_expanders The above methods operate exactly like the op_ versions but wrap the coderef using the appropriate make_ method first. =head1 PERFORMANCE Thanks to some benchmarking by Mark Stosberg, it turns out that this module is many orders of magnitude faster than using C. I must admit this wasn't an intentional design issue, but it's a byproduct of the fact that you get to control your C handles yourself. To maximize performance, use a code snippet like the following: # prepare a statement handle using the first row # and then reuse it for the rest of the rows my($sth, $stmt); for my $href (@array_of_hashrefs) { $stmt ||= $sql->insert('table', $href); $sth ||= $dbh->prepare($stmt); $sth->execute($sql->values($href)); } The reason this works is because the keys in your C<$href> are sorted internally by B. Thus, as long as your data retains the same structure, you only have to generate the SQL the first time around. On subsequent queries, simply use the C function provided by this module to return your values in the correct order. However this depends on the values having the same type - if, for example, the values of a where clause may either have values (resulting in sql of the form C with a single bind value), or alternatively the values might be C (resulting in sql of the form C with no bind value) then the caching technique suggested will not work. =head1 FORMBUILDER If you use my C module at all, you'll hopefully really like this part (I do, at least). Building up a complex query can be as simple as the following: #!/usr/bin/perl use warnings; use strict; use CGI::FormBuilder; use SQL::Abstract; my $form = CGI::FormBuilder->new(...); my $sql = SQL::Abstract->new; if ($form->submitted) { my $field = $form->field; my $id = delete $field->{id}; my($stmt, @bind) = $sql->update('table', $field, {id => $id}); } Of course, you would still have to connect using C to run the query, but the point is that if you make your form look like your table, the actual query script can be extremely simplistic. If you're B lazy (I am), check out C for a fast interface to returning and formatting data. I frequently use these three modules together to write complex database query apps in under 50 lines. =head1 HOW TO CONTRIBUTE Contributions are always welcome, in all usable forms (we especially welcome documentation improvements). The delivery methods include git- or unified-diff formatted patches, GitHub pull requests, or plain bug reports either via RT or the Mailing list. Contributors are generally granted full access to the official repository after their first several patches pass successful review. This project is maintained in a git repository. The code and related tools are accessible at the following locations: =over =item * Official repo: L =item * Official gitweb: L =item * GitHub mirror: L =item * Authorized committers: L =back =head1 CHANGES Version 1.50 was a major internal refactoring of C. Great care has been taken to preserve the I behavior documented in previous versions in the 1.* family; however, some features that were previously undocumented, or behaved differently from the documentation, had to be changed in order to clarify the semantics. Hence, client code that was relying on some dark areas of C v1.* B in v1.50. The main changes are: =over =item * support for literal SQL through the C<< \ [ $sql, @bind ] >> syntax. =item * support for the { operator => \"..." } construct (to embed literal SQL) =item * support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values) =item * optional support for L =item * defensive programming: check arguments =item * fixed bug with global logic, which was previously implemented through global variables yielding side-effects. Prior versions would interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >> as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>. Now this is interpreted as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>. =item * fixed semantics of _bindtype on array args =item * dropped the C<_anoncopy> of the %where tree. No longer necessary, we just avoid shifting arrays within that tree. =item * dropped the C<_modlogic> function =back =head1 ACKNOWLEDGEMENTS There are a number of individuals that have really helped out with this module. Unfortunately, most of them submitted bugs via CPAN so I have no idea who they are! But the people I do know are: Ash Berlin (order_by hash term support) Matt Trout (DBIx::Class support) Mark Stosberg (benchmarking) Chas Owens (initial "IN" operator support) Philip Collins (per-field SQL functions) Eric Kolve (hashref "AND" support) Mike Fragassi (enhancements to "BETWEEN" and "LIKE") Dan Kubb (support for "quote_char" and "name_sep") Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by) Laurent Dami (internal refactoring, extensible list of special operators, literal SQL) Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests) Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests) Oliver Charles (support for "RETURNING" after "INSERT") Thanks! =head1 SEE ALSO L, L, L, L. =head1 AUTHOR Copyright (c) 2001-2007 Nathan Wiger . All Rights Reserved. This module is actively maintained by Matt Trout For support, your best bet is to try the C users mailing list. While not an official support venue, C makes heavy use of C, and as such list members there are very familiar with how to create queries. =head1 LICENSE This module is free software; you may copy this under the same terms as perl itself (either the GNU General Public License or the Artistic License) =cut SQL-Abstract-2.000001/lib/DBIx/0000755000000000000000000000000014002747454015475 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/DBIx/Class/0000755000000000000000000000000014002747454016542 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/DBIx/Class/SQLMaker/0000755000000000000000000000000014002747454020161 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/DBIx/Class/SQLMaker/Role/0000755000000000000000000000000014002747454021062 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/DBIx/Class/SQLMaker/Role/SQLA2Passthrough.pm0000644000000000000000000001234414002362432024463 0ustar00rootroot00000000000000package DBIx::Class::SQLMaker::Role::SQLA2Passthrough; use strict; use warnings; use Exporter 'import'; our @EXPORT = qw(on); sub on (&) { my ($on) = @_; sub { my ($args) = @_; $args->{self_resultsource} ->schema->storage->sql_maker ->expand_join_condition( $on->($args), $args ); } } use Role::Tiny; around select => sub { my ($orig, $self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_; $fields = \[ $self->render_expr({ -list => [ grep defined, map +(ref($_) eq 'HASH' ? do { my %f = %$_; my $as = delete $f{-as}; my ($f, $rhs) = %f; my $func = +{ ($f =~ /^-/ ? $f : "-${f}") => $rhs }; ($as ? +{ -op => [ 'as', $func, { -ident => [ $as ] } ] } : $func) } : $_), ref($fields) eq 'ARRAY' ? @$fields : $fields ] }, -ident) ]; if (my $gb = $rs_attrs->{group_by}) { $rs_attrs = { %$rs_attrs, group_by => \[ $self->render_expr({ -list => $gb }, -ident) ] }; } $self->$orig($table, $fields, $where, $rs_attrs, $limit, $offset); }; sub expand_join_condition { my ($self, $cond, $args) = @_; my ($type, %known) = do { if (my $obj = $args->{self_result_object}) { (self => $obj->get_columns) } elsif (my $val = $args->{foreign_values}) { (foreign => %$val) } else { ('') } }; my $maybe = $type ? 1 : 0; my $outside; my $wrap = sub { my ($orig) = @_; $outside = $orig; sub { my $res = $orig->(@_); my ($name, $col) = @{$res->{-ident}}; if ($name eq 'self' or $name eq 'foreign') { if ($type eq $name) { $maybe = 0 unless exists $known{$col}; } return { -ident => [ $args->{"${name}_alias"}, $col ] }; } return $res; }; }; my $sqla = $self->clone->wrap_op_expander(ident => $wrap); my $aqt = $sqla->expand_expr($cond, -ident); return $aqt unless $maybe; my $inner_wrap = sub { my $res = $outside->(@_); my ($name, $col) = @{$res->{-ident}}; if ($name eq 'self' or $name eq 'foreign') { if ($type eq $name) { return { -bind => [ $args->{"${name}_alias"}.'.'.$col, $known{$col} ] }; } return { -ident => [ $args->{"${name}_alias"}, $col ] }; } return $res; }; $sqla->op_expander(ident => $inner_wrap); my $inner_aqt = $self->_collapsify($sqla->expand_expr($cond, -ident)); return ($aqt, $inner_aqt); } sub _collapsify { my ($self, $aqt) = @_; return $aqt unless my @opargs = @{$aqt->{-op}}; my ($logop, @args) = @opargs; return $aqt unless $logop eq 'and'; my %collapsed = map { my $q = $_; return $aqt unless my @opargs = @{$q->{-op}}; my ($op, $lhs, @rest) = @opargs; return $aqt unless my @ident = @{$lhs->{-ident}}; (join('.', @ident), { $op => \@rest }); } @args; return \%collapsed; } 1; __END__ =head1 NAME DBIx::Class::SQLMaker::Role::SQLA2Passthrough - A test of future possibilities =head1 SYNOPSIS =over 4 =item * select and group_by options are processed using the richer SQLA2 code =item * expand_join_condition is provided to more easily express rich joins =back See C for a small amount of running code. =head1 SETUP (on_connect_call => sub { my ($storage) = @_; $storage->sql_maker ->with::roles('DBIx::Class::SQLMaker::Role::SQLA2Passthrough'); }) =head2 expand_join_condition __PACKAGE__->has_many(minions => 'Blah::Person' => sub { my ($args) = @_; $args->{self_resultsource} ->schema->storage->sql_maker ->expand_join_condition( $args ); }); =head2 on __PACKAGE__->has_many(minions => 'Blah::Person' => on { { 'self.group_id' => 'foreign.group_id', 'self.rank' => { '>', 'foreign.rank' } } }); Or with ParameterizedJoinHack, __PACKAGE__->parameterized_has_many( priority_tasks => 'MySchema::Result::Task', [['min_priority'] => sub { my $args = shift; return +{ "$args->{foreign_alias}.owner_id" => { -ident => "$args->{self_alias}.id", }, "$args->{foreign_alias}.priority" => { '>=' => $_{min_priority}, }, }; }], ); becomes __PACKAGE__->parameterized_has_many( priority_tasks => 'MySchema::Result::Task', [['min_priority'] => on { { 'foreign.owner_id' => 'self.id', 'foreign.priority' => { '>=', { -value => $_{min_priority} } } } }] ); Note that foreign/self can appear in such a condition on either side, BUT if you want L to be able to use a join-less version you must ensure that the LHS is all foreign columns, i.e. on { +{ 'foreign.x' => 'self.x', 'self.y' => { -between => [ 'foreign.y1', 'foreign.y2' ] } } } is completely valid but DBIC will insist on doing a JOIN even if you have a fully populated row object to call C on - to avoid the spurious JOIN, you must specify it with explicit LHS foreign cols as: on { +{ 'foreign.x' => 'self.x', 'foreign.y1' => { '<=', 'self.y' }, 'foreign.y2' => { '>=', 'self.y' }, } } =cut SQL-Abstract-2.000001/lib/DBIx/Class/Storage/0000755000000000000000000000000014002747454020146 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/DBIx/Class/Storage/Debug/0000755000000000000000000000000014002747454021174 5ustar00rootroot00000000000000SQL-Abstract-2.000001/lib/DBIx/Class/Storage/Debug/PrettyPrint.pm0000644000000000000000000000723713455744035024052 0ustar00rootroot00000000000000package DBIx::Class::Storage::Debug::PrettyPrint; use strict; use warnings; use base 'DBIx::Class::Storage::Statistics'; use SQL::Abstract::Tree; __PACKAGE__->mk_group_accessors( simple => '_sqlat' ); __PACKAGE__->mk_group_accessors( simple => '_clear_line_str' ); __PACKAGE__->mk_group_accessors( simple => '_executing_str' ); __PACKAGE__->mk_group_accessors( simple => '_show_progress' ); __PACKAGE__->mk_group_accessors( simple => '_last_sql' ); __PACKAGE__->mk_group_accessors( simple => 'squash_repeats' ); sub new { my $class = shift; my $args = shift; my $clear_line = $args->{clear_line} || "\r\x1b[J"; my $executing = $args->{executing} || ( eval { require Term::ANSIColor } ? do { my $c = \&Term::ANSIColor::color; $c->('blink white on_black') . 'EXECUTING...' . $c->('reset'); } : 'EXECUTING...' ); my $show_progress = $args->{show_progress}; my $squash_repeats = $args->{squash_repeats}; my $sqlat = SQL::Abstract::Tree->new($args); my $self = $class->next::method(@_); $self->_clear_line_str($clear_line); $self->_executing_str($executing); $self->_show_progress($show_progress); $self->squash_repeats($squash_repeats); $self->_sqlat($sqlat); $self->_last_sql(''); return $self } sub print { my $self = shift; my $string = shift; my $bindargs = shift || []; my ($lw, $lr); ($lw, $string, $lr) = $string =~ /^(\s*)(.+?)(\s*)$/s; local $self->_sqlat->{fill_in_placeholders} = 0 if defined $bindargs && defined $bindargs->[0] && $bindargs->[0] eq q('__BULK_INSERT__'); my $use_placeholders = !!$self->_sqlat->fill_in_placeholders; my $sqlat = $self->_sqlat; my $formatted; if ($self->squash_repeats && $self->_last_sql eq $string) { my ( $l, $r ) = @{ $sqlat->placeholder_surround }; $formatted = '... : ' . join(', ', map "$l$_$r", @$bindargs) } else { $self->_last_sql($string); $formatted = $sqlat->format($string, $bindargs); $formatted = "$formatted : " . join ', ', @{$bindargs} unless $use_placeholders; } $self->next::method("$lw$formatted$lr", @_); } sub query_start { my ($self, $string, @bind) = @_; if (defined $self->callback) { $string =~ m/^(\w+)/; $self->callback->($1, "$string: ".join(', ', @bind)."\n"); return; } $string =~ s/\s+$//; $self->print("$string\n", \@bind); $self->debugfh->print($self->_executing_str) if $self->_show_progress } sub query_end { $_[0]->debugfh->print($_[0]->_clear_line_str) if $_[0]->_show_progress } 1; =pod =head1 NAME DBIx::Class::Storage::Debug::PrettyPrint - Pretty Printing DebugObj =head1 SYNOPSIS DBIC_TRACE_PROFILE=~/dbic.json perl -Ilib ./foo.pl Where dbic.json contains: { "profile":"console", "show_progress":1, "squash_repeats":1 } =head1 METHODS =head2 new my $pp = DBIx::Class::Storage::Debug::PrettyPrint->new({ show_progress => 1, # tries it's best to make it clear that a SQL # statement is still running executing => '...', # the string that is added to the end of SQL # if show_progress is on. You probably don't # need to set this clear_line => '[J', # the string used to erase the string added # to SQL if show_progress is on. Again, the # default is probably good enough. squash_repeats => 1, # set to true to make repeated SQL queries # be ellided and only show the new bind params # any other args are passed through directly to SQL::Abstract::Tree });