File Coverage

blib/lib/SQL/QueryBuilder/OO.pm
Criterion Covered Total %
statement 261 828 31.5
branch 0 236 0.0
condition 0 100 0.0
subroutine 87 204 42.6
pod n/a
total 348 1368 25.4


line stmt bran cond sub pod time code
1             package SQL::QueryBuilder::OO;
2              
3 1     1   4289 use 5.010;
  1         4  
  1         35  
4 1     1   4 use strict;
  1         1  
  1         31  
5 1     1   4 use vars qw($VERSION);
  1         5  
  1         174  
6              
7             $VERSION = '0.2.2';
8              
9             =pod
10              
11             =head1 NAME
12              
13             SQL::QueryBuilder::OO - Object oriented SQL query builder
14              
15             =head1 SYNOPSIS
16              
17             use SQL::QueryBuilder::OO;
18              
19             # Uses an existing DBI database handle
20             sqlQuery::setup(-dbh => $dbh);
21              
22             # Database handle is created when necessary via a sub-routine
23             sqlQuery::setup(-connect => sub {
24             DBI->connect(...);
25             });
26              
27             # Full syntax
28             $sql = sqlQueryBase::select(qw(id title description), {name => 'author'})
29             ->from('article')
30             ->innerJoin('users', 'userId')
31             ->leftJoin({'comments' => 'c'}, sqlCondition::EQ('userId', 'c.from'))
32             ->where(sqlCondition::AND(
33             sqlCondition::EQ('category')->bind($cat),
34             sqlCondition::NE('hidden')->bind(1)))
35             ->limit(10,20)
36             ->groupBy('title')
37             ->orderBy({'timestamp' => 'DESC'});
38              
39             $sth = sqlQuery::q($sql)->execute();
40             $row = $sth->fetchAssoc();
41             $sth->freeResource();
42              
43             # Overloaded operators
44              
45             $cond = sqlCondition::EQ('a', 'b') & !sqlCondition::IN('c')->bind([1,2,3]);
46             print "$cond";
47             # -> (`a` = `b` AND NOT(`c` IN(1,2,3)))
48              
49             =head1 DESCRIPTION
50              
51             This module provides for an object oriented way to create complex SQL queries
52             while maintaining code readability. It supports conditions construction and
53             bound query parameters. While the module is named C, this
54             name is actually not used when constructing queries. The two main packages to
55             build queries are C and C. The package to execute
56             them is C.
57              
58             The project is actually a port of PHP classes to construct queries used in one
59             of my proprietary projects (which may explain the excessive use of the scope
60             resolution operator (C<::>) in the module's sytax).
61              
62             =head2 Setting the module up
63              
64             Module set-up is I optional; you may not be executing any queries, yet, an
65             existing (or ad-hoc created) database handle is required for purposes of safely
66             quoting interpolated values.
67              
68             If at any point you're getting an "sqlQuery is not setup, yet." error, you
69             forgot to use any one of the following statements.
70              
71             =head3 Using an existing database handle
72              
73             To use an existing DBI database handle, put this in your program's prolog:
74              
75             sqlQuery::setup(-dbh => $dbh);
76              
77             =head3 Creating a database handle when needed
78              
79             To create a new database handle when it's needed (ad-hoc), supply a subroutine
80             that will be called I:
81              
82             sqlQuery::setup(-connect => sub {
83             DBI->connect(...);
84             });
85              
86             =head2 Building queries
87              
88             The package to provide builder interfaces is called C and has
89             these methods:
90              
91             =head3 SELECT queries
92              
93             =over 4
94              
95             =item select(I[, I])
96              
97             Creates a SELECT query object. Columns to select default to C<*> if none are
98             given. They are otherwise to be specified as a list of expressions that can be
99             literal column names or HASH references with column aliases.
100              
101             Column names are quoted where appropriate:
102              
103             # Build SELECT * query
104             $all = sqlQueryBase::select();
105              
106             # Build SELECT ... query
107             $sql = sqlQueryBase::select(
108             # literal column names
109             qw(id title),
110             # column alias
111             {'u.username' => 'author', timestamp => 'authored'},
112             # SELECT specific options
113             [qw(SQL_CACHE SQL_CALC_FOUND_ROWS)]);
114              
115             The references returned from the above statements are blessed into an internal
116             package. Those internal packages will not be documented here, since they may be
117             subject to change. Their methods, however, are those of a valid SQL SELECT
118             statement. When constructing queries you'll B of
119             SQL syntax. This means, that the following will be treated as an error
120             I:
121              
122             $sql = sqlQueryBase::select()
123             ->from('table')
124             ->limit(10)
125             ->where(...);
126              
127             Can't locate object method "where" via package "sqlSelectAssemble" at ...
128              
129             The correct order would have been:
130              
131             $sql = sqlQueryBase::select()
132             ->from('table')
133             ->where(...)
134             ->limit(10);
135              
136             The following methods are available to construct the query further:
137              
138             =item from(I)
139              
140             This obviously represents the "FROM" part of a select query. It accepts a list
141             of string literals as table names or table aliases:
142              
143             $sql = sqlQueryBase::select()->from('posts', {'user' => 'u'});
144              
145             =item leftJoin(I, I)
146              
147             =item innerJoin(I, I)
148              
149             =item rightJoin(I, I)
150              
151             These methods extend the "FROM" fragment with a left, inner or right table join.
152             The table name can either be a string literal or a HASH reference for aliasing
153             table names.
154              
155             The condition should either be an C object (see L):
156              
157             # SELECT * FROM `table_a` LEFT JOIN `table_b` ON(`column_a` = `column_b`)
158             $sql = sqlQueryBase::select()
159             ->from('table_a')
160             ->leftJoin('table_b', sqlCondition::EQ('column_a', 'column_b'));
161              
162             ...or a string literal of a common column name for the USING clause:
163              
164             # SELECT * FROM `table_a` LEFT JOIN `table_b` USING(`id`)
165             $sql = sqlQueryBase::select()
166             ->from('table_a')
167             ->leftJoin('table_b', 'id');
168              
169             =item where(I)
170              
171             This represents the "WHERE" part of a SELECT query. It will accept B object
172             of the C package (see L).
173              
174             =item groupBy(I)
175              
176             This represents the "GROUP BY" statement of a SELECT query.
177              
178             =item having(I)
179              
180             This represents the "HAVING" part of a SELECT query. It will accept B object
181             of the C package (see L).
182              
183             =item orderBy(I)
184              
185             This represents the "ORDER BY" statement of a SELECT query. Columns are expected
186             to be string literals or HASH references (B member only) with ordering
187             directions:
188              
189             $sql = sqlQueryBase::select()
190             ->from('table')
191             ->orderBy('id', {timestamp => 'DESC'}, 'title');
192              
193             =item limit(I[, I])
194              
195             This represents the "LIMIT" fragment of a SELECT query. It deviates from the
196             standard SQL expression, as the limit count B the first argument to
197             this method, regardless of a given offset. The first or both parameters may be
198             C to skip the LIMIT clause.
199              
200             =back
201              
202             =head3 Creating conditions
203              
204             Conditions can be used as a parameter for C, C, C,
205             C or C. They are constructed with the C package,
206             whose methods are not exported due to their generic names. Instead, the
207             "namespace" has to be mentioned for each conditional:
208              
209             $cond = sqlCondition::AND(
210             sqlCondition::EQ('id')->bind(1337),
211             sqlCondition::BETWEEN('stamp', "2013-01-06", "2014-03-31"));
212              
213             Those are all operators:
214              
215             =head4 Booleans
216              
217             To logically connect conditions, the following to methods are available:
218              
219             =over 4
220              
221             =item AND(I)
222              
223             Connect one or more conditions with a boolean AND.
224              
225             =item OR(I)
226              
227             Connect one or more conditions with a boolean OR.
228              
229             =item NOT(I)
230              
231             Negate a condition with an unary NOT.
232              
233             =back
234              
235             =head4 Relational operators
236              
237             All relational operators expect a mandatory column name as their first argument
238             and a second optional ride-hand-side column name.
239              
240             If the optional second parameter is left out, the conditional can be bound (see
241             L).
242              
243             =over 4
244              
245             =item EQ(I[, I])
246              
247             Bual to operator (C<=>).
248              
249             =item NE(I[, I])
250              
251             Bot Bqual to operator (C).
252              
253             =item LT(I[, I])
254              
255             Bess Bhan operator (C>).
256              
257             =item GT(I[, I])
258              
259             Breater Bhan operator (C>).
260              
261             =item LTE(I[, I])
262              
263             Bess Bhan or Bqual to operator (C=>).
264              
265             =item GTE(I[, I])
266              
267             Breater Bhan or Bqual to operator (C=>).
268              
269             =back
270              
271             =head4 SQL specific operators
272              
273             =over 4
274              
275             =item BETWEEN(I, I, I)
276              
277             Creates an "x BETWEEN start AND end" conditional.
278              
279             =item IN(I)
280              
281             Creates an "x IN(...)" conditional.
282              
283             B that, if bound, this method B croak if it encounters an empty
284             list. I
285             will be reduced to a "falsy" statement and a warning will be issued.>
286              
287             =item ISNULL(I)
288              
289             Creates an "x IS NULL" conditional.
290              
291             =item ISNOTNULL(I)
292              
293             Creates an "x IS NOT NULL" conditional.
294              
295             =item LIKE(I, I)
296              
297             Creates an "x LIKE pattern" conditional.
298              
299             B that the pattern is passed unmodified. Beware of the LIKE pitfalls
300             concerning the characters C<%> and C<_>.
301              
302             =item NOTIN(I)
303              
304             Creates an "x NOT IN(...)" conditional.
305              
306             Convenience for Cbind([1,2,3]))>.
307             Please refer to C for caveats.
308              
309             =back
310              
311             =head3 Binding parameters
312              
313             An SQL conditional can be bound against a parameter via its C method:
314              
315             $cond = sqlCondition::AND(
316             sqlCondition::EQ('id')->bind(1337),
317             sqlCondition::NOT(
318             sqlCondition::IN('category')->bind([1,2,3,4])));
319              
320             print $cond; # "`id` = ? AND NOT(`category` IN(?))"
321             @args = $cond->gatherBoundArgs(); # (sqlValueInt(1337),sqlValueList([1,2,3,4]))
322              
323             A special case are conditionals bound against C (which is the equivalent
324             to SQL C):
325              
326             $cat = undef;
327             $cond = sqlCondition::OR(
328             sqlCondition::EQ('author')->bind(undef),
329             sqlCondition::NE('category')->bind($cat));
330              
331             print $cond; # `author` IS NULL OR `category` IS NOT NULL
332             @args = $cond->gatherBoundArgs(); # ()
333              
334             Since C<`author` = NULL> would never be "true", the condition is replaced with
335             the correct C<`author` IS NULL> statement. (Note that the first conditional
336             could actually be written C. The substitution is
337             thus useful when binding against variables of unknown content).
338              
339             =head4 Parameter conversion
340              
341             Bound parameters are internally converted to a sub-class of C.
342             Since most scalar values are already converted automatically, a user might never
343             need to employ any of those packages listed below. If more complex queries are
344             desired, however, they just I to be used.
345              
346             =over
347              
348             =item C
349              
350             =item C
351              
352             To bind a value and use its date or date/time representation, use:
353              
354             $cond->bind(new sqlValueDate()); # use current time, return YYYY-MM-DD
355             $cond->bind(new sqlValueDateTime()); # use current time, return YYYY-MM-DD HH:MM:SS
356              
357             $tm = mktime(...);
358             $cond->bind(new sqlValueDate($tm)); # use UNIX timestamp; return YYYY-MM-DD
359             $cond->bind(new sqlValueDateTime($tm)); # use UNIX timestamp; return YYYY-MM-DD HH:MM:SS
360              
361             $str = "Wed, 6 Jan 82 02:20:00 +0100";
362             $cond->bind(new sqlValueDate($str)); # use textual representation; return YYYY-MM-DD
363             $cond->bind(new sqlValueDateTime($str)); # use textual representation; return YYYY-MM-DD HH:MM:SS
364              
365             The latter variants using textual representation use L to convert a
366             string into a UNIX timestamp. Refer to L to learn about supported
367             formats.
368              
369             =item C
370              
371             To bind a value as a floating point number (with optional precision), use:
372              
373             $cond->bind(new sqlValueFloat($number, 4)); # Precision of four; eight is the default
374              
375             B floating point numbers are I converted
376             to this package when using C.>
377              
378             =item C
379              
380             To bind a value as an integer, use:
381              
382             $cond->bind(new sqlValueInt($number));
383              
384             B (un)signed integers are I converted to
385             this package when using C.>
386              
387             =item C
388              
389             To create a safe list of values, use:
390              
391             sqlCondition::IN('column')->bind(new sqlValueList([1,2,3,4]));
392              
393             B converted to this package when
394             using C.> All elements of the list are subject to conversion as well.
395              
396             =item C
397              
398             To include a complex statement as-is, use:
399              
400             sqlCondition::EQ('a')->bind(new sqlValueLiteral('IF(`b` = `c`, 0, 1)'));
401             # -> `a` = IF(`b` = `c`, 0, 1)
402              
403             I do not abuse this to interpolate values into the query: this would
404             pose a security risk since these values aren't subject to "escaping".
405              
406             =item C
407              
408             To represent MySQL's C, use:
409              
410             $cond->bind(new sqlValueNull());
411              
412             B are I converted to this package
413             when using C.>
414              
415             =item C
416              
417             To bind a value as a string, use:
418              
419             $cond->bind(new sqlValueString($value));
420              
421             B, integers, or floats are converted to this
422             package when using C.> The value is properly escaped before query
423             interpolation.
424              
425             =back
426              
427             =head4 Named or index-based parameters
428              
429             The module supports both named or index-based parameters; just not both in a
430             mix:
431              
432             # Index-based parameters
433             $query = sqlQueryBase::select()
434             ->from('table')
435             ->where(sqlCondition::EQ('id')->bind(1337));
436             print "$query"; # -> SELECT * FROM `table` WHERE `id` = ?
437              
438             # Named parameters
439             $query = sqlQueryBase::select()
440             ->from('table')
441             ->where(sqlCondition::EQ('id', ':value'));
442             print "$query"; # -> SELECT * FROM `table` WHERE `id` = :value
443              
444             Index-based parameters can be bound to the corresponding C when
445             it's created and are later interpolated. Name based parameters make for cleaner
446             query creation statements but require an additional step prior to executing the
447             query:
448              
449             $query = sqlQueryBase::select()
450             ->from('table')
451             ->where(sqlCondition::EQ('id', ':value'));
452             $res = sqlQuery->new($query)
453             ->setParameters({value => 1337}) # assign name-value pairs here
454             ->execute();
455              
456             =head3 Conditions with overloaded operators
457              
458             To regain a little readability, the I operators C<&> and C<|> and the
459             unary C have been overloaded to substitute for C,
460             C and C respectively.
461              
462             This:
463              
464             $cond = sqlCondition::AND(
465             sqlCondition::EQ('a', 'b'),
466             sqlCondition::OR(
467             sqlCondition::NOT(sqlCondition::LIKE('d', "%PATTERN%")),
468             sqlCondition::C('UNIX_TIMESTAMP(`column`) >= DATE_SUB(NOW(), INTERVAL 7 DAY)')));
469              
470             is the same as this:
471              
472             $cond = sqlCondition::EQ('a', 'b')
473             & (!sqlCondition::LIKE('d', "%PATTERN%")
474             | 'UNIX_TIMESTAMP(`column`) >= DATE_SUB(NOW(), INTERVAL 7 DAY)');
475              
476             =head2 Executing queries
477              
478             The package to execute queries with is C. Depending on its usage, it
479             returns an C package instance:
480              
481             $query = sqlQuery->new($sql);
482             $result = $query->execute();
483             $row = $result->fetchAssoc();
484             $result->freeResource();
485              
486             =head3 Fetching results
487              
488             A query result of the C package has these methods:
489              
490             =over
491              
492             =item C
493              
494             Fetch all rows, return a list of HASHREFs.
495              
496             =item C
497              
498             Fetch one row, return the values as a list.
499              
500             =item C
501              
502             Fetch one row, return it as a C.
503              
504             =item C
505              
506             Fetch one row, return its named column C<$name> or index-based column (from
507             zero).
508              
509             =item C I<(alias)>
510              
511             Fetch one row, return it as a C.
512              
513             =back
514              
515             =head3 Other methods
516              
517             The following are other methods of C unrelated to fetching data:
518              
519             =over
520              
521             =item C
522              
523             Finishes an executed statement, freeing its resources.
524              
525             =item C
526              
527             =item C
528              
529             Return number of rows in a C
530              
531             =back
532              
533             =head1 EXAMPLES
534              
535             =head2 Execute a single statement
536              
537             =head3 Index-based parameters
538              
539             sqlQuery::exec('UPDATE `foo` SET `bar` = ?', 'splort'); # returns number of affected rows
540              
541             =head3 Named parameters
542              
543             sqlQuery::exec('UPDATE `foo` SET `bar` = :bar', {
544             bar: 'splort'
545             }); # returns number of affected rows
546              
547             =head1 TODO
548              
549             =over
550              
551             =item *
552              
553             Implement support for UPDATE, INSERT, REPLACE and DELETE statements.
554              
555             =item *
556              
557             Implement support for UNION.
558              
559             =back
560              
561             =head1 DEPENDENCIES
562              
563             L
564              
565             =head1 AUTHOR
566              
567             Oliver Schieche Eschiecheo@cpan.orgE
568              
569             http://perfect-co.de/
570              
571             $Id: OO.pm 44 2015-03-18 14:14:56Z schieche $
572              
573             =head1 COPYRIGHT
574              
575             Copyright (C) 2013-2015 Oliver Schieche.
576              
577             This software is a free library. You can modify and/or distribute it under the
578             same terms as Perl itself.
579              
580             =cut
581             ##------------------------------------------------------------------------------
582             package sqlQuery;
583              
584 1     1   4 use strict;
  1         1  
  1         26  
585 1     1   4 use warnings;
  1         1  
  1         31  
586 1     1   3110 use overload '""' => '_getInterpolatedQuery';
  1         1064  
  1         9  
587              
588 1     1   818 use Data::Dumper; # vital
  1         6981  
  1         123  
589 1     1   9 use Carp qw(croak cluck);
  1         2  
  1         56  
590 1     1   5 use Scalar::Util qw(blessed looks_like_number);
  1         1  
  1         163  
591 1     1   627 use Params::Validate qw(:all);
  1         7426  
  1         1779  
592              
593             $sqlQuery::DBI = undef;
594             %sqlQuery::params = ();
595             $sqlQuery::PARAMETER_PLACEHOLDER = '?';
596              
597             sub setup
598             {
599 0     0     my %params = validate @_, {
600             -dbh => {isa => 'DBI::db', default => undef},
601             -connect => {type => CODEREF, default => undef}
602             };
603              
604 0 0 0       if (defined($params{'-dbh'}) && defined($params{'-connect'}))
605             {
606 0           croak('Make up your mind: either use "-dbh" to pass a handle or "-connect" for ad-hoc connecting');
607             }
608              
609 0           %sqlQuery::params = %params;
610              
611 0           1
612             }
613              
614             sub dbh
615             {
616 0 0   0     unless (defined($sqlQuery::DBI)) {
617 0 0         if (defined($sqlQuery::params{'-dbh'})) {
    0          
618 0           $sqlQuery::DBI = $sqlQuery::params{'-dbh'};
619             } elsif (defined($sqlQuery::params{'-connect'})) {
620 0           $sqlQuery::DBI = eval {$sqlQuery::params{'-connect'}->()};
  0            
621 0 0         croak 'Setup failed; ad-hoc connector died: '.$@ if $@;
622             } else {
623 0           croak 'sqlQuery is not setup, yet.';
624             }
625             }
626              
627             $sqlQuery::DBI
628 0           }
629              
630             sub q
631             {
632 0     0     local $Carp::CarpLevel = $Carp::CarpLevel + 2;
633 0           __PACKAGE__->new(@_);
634             }
635              
636             sub exec
637             {
638 0     0     my $sql = shift;
639 0           my $q = __PACKAGE__->new($sql);
640 0           my $rows = $q->execute(@_);
641 0 0 0       cluck('Discarded query with results'), $rows = undef
642             if blessed($rows) && $rows->isa('sqlQueryResult');
643 0           undef($q);
644              
645 0           $rows
646             }
647              
648             sub foundRows
649             {
650 0     0     my $res = __PACKAGE__->new(q(SELECT FOUND_ROWS()))->execute;
651 0           my $rows = $res->fetchColumn(0);
652 0           $res->freeResource();
653              
654 0           $rows
655             }
656              
657             sub getLastInsertId
658             {
659 0     0     my $res = __PACKAGE__->new(q(SELECT LAST_INSERT_ID()))->execute;
660 0           my $id = $res->fetchColumn(0);
661 0           $res->freeResource();
662              
663 0           $id
664             }
665              
666             sub new
667             {
668 0 0   0     my $class = ref $_[0] ? ref shift : shift;
669 0           my $sql = shift;
670 0           my $self = {-sql => undef, -params => undef, -named => 0};
671              
672 0 0         unless (blessed($sql)) {
673 0 0 0       croak 'Not a scalar argument; query must either be a string or an instance of "sqlSelectAssemble"'
      0        
674             if !defined($sql) || ref $sql || looks_like_number $sql;
675             } else {
676 0 0         croak sprintf('Parameter is not an instance of "sqlSelectAssemble" (got "%s")', ref $sql)
677             unless $sql->isa('sqlSelectAssemble');
678 0           $self->{'-params'} = undef
679             }
680              
681 0           $self->{'-sql'} = $sql;
682 0           bless $self, $class
683             }
684              
685             sub debugQuery
686             {
687 0     0     my $self = shift;
688 0           my $sql = "$self->{-sql}";
689              
690 0           $sql =~ s/(?:\r?\n)+$//;
691 0           print "$sql\n";
692              
693 0 0         if (@_) {
    0          
694 0           $self->_populateParameters(@_);
695             } elsif (blessed $self->{'-sql'}) {
696 0           $self->_populateParameters($self->{'-sql'}->gatherBoundArgs());
697             }
698              
699 0 0         if (defined($self->{'-params'})) {
700 0           printf "%s\n%s\n%s\n", ('-'x80), Dumper($self->{'-params'}), ('-'x80);
701 0           $self->_interpolateQuery();
702 0           printf "%s\n", $self->{'-interpolated-query'};
703             }
704             }
705              
706             sub execute
707             {
708 0     0     my $self = shift;
709              
710 0 0         if (@_) {
    0          
711 0           $self->_populateParameters(@_);
712             } elsif (blessed $self->{'-sql'}) {
713 0           $self->_populateParameters($self->{'-sql'}->gatherBoundArgs());
714             }
715              
716 0           $self->_interpolateQuery();
717              
718 0           my $res = eval {$self->_query($self->{'-interpolated-query'})};
  0            
719 0           $self->{'-params'} = undef;
720 0 0         die $@ if $@;
721              
722 0           $res
723             }
724              
725             sub setParameters
726             {
727 0     0     my $self = shift;
728 0           $self->_populateParameters(@_);
729 0           $self
730             }
731              
732             sub _getInterpolatedQuery
733             {
734 0     0     my $self = shift;
735 0           $self->_interpolateQuery();
736 0           $self->{'-interpolated-query'}
737             }
738              
739             sub _populateParameters
740             {
741 0     0     my $self = shift;
742              
743 0 0         if (defined($self->{'-params'})) {
744 0           local $Carp::CarpLevel = $Carp::CarpLevel + 2;
745 0           croak 'Query parameters are already populated'
746             }
747              
748 0 0 0       if (1 == scalar @_ && 'HASH' eq ref $_[0]) {
749 0           $self->{'-named'} = 1;
750 0           $self->{'-params'} = shift;
751 0           foreach my $p (keys %{$self->{'-params'}}) {
  0            
752 0           $self->{'-params'}->{$p} = _convertArgument($self->{'-params'}->{$p});
753 0 0         croak "Argument '$p' could not be converted"
754             unless defined($self->{'-params'}->{$p});
755             }
756             } else {
757 0           croak 'Mixed named and positional parameters are unsupported'
758 0 0         if grep {'HASH' eq ref $_} @_;
759 0           $self->{'-named'} = 0;
760 0           $self->{'-params'} = [@_];
761              
762 0           foreach my $index (0..$#_) {
763 0           $self->{'-params'}->[$index] = _convertArgument($self->{'-params'}->[$index]);
764 0 0         croak "Argument at index '$index' could not be converted"
765             unless defined($self->{'-params'}->[$index]);
766             }
767             }
768             }
769              
770             sub _interpolateQuery
771             {
772 0     0     my $self = shift;
773              
774 0 0         if ($self->{'-named'}) {
775 0           $self->_interpolateByName();
776             } else {
777 0           $self->_interpolateByIndex();
778             }
779              
780 0           $self->_checkLeftoverParameters();
781             }
782              
783             sub _interpolateByIndex
784             {
785 0     0     my $self = shift;
786 0           my $sql = "$self->{-sql}";
787              
788 0   0       for (my $pos = 0; $pos < length($sql) && -1 != ($pos = index($sql, $sqlQuery::PARAMETER_PLACEHOLDER, $pos));) {
789 0           my $param = eval{$self->_fetchParameter()};
  0            
790 0 0         croak "$@: interpolated so far: $sql" if $@;
791 0           my $value = "$param";
792              
793 0 0         $sql =
794             (0 < $pos ? substr($sql, 0, $pos) : '')
795             . $value
796             . substr($sql, $pos + 1);
797 0           $pos += length $value;
798             }
799              
800 0           $self->{'-interpolated-query'} = $sql;
801             }
802              
803             sub _interpolateByName
804             {
805 0     0     my $self = shift;
806 0           my $sql = "$self->{-sql}";
807              
808 0   0       for (my $pos = 0; $pos < length($sql) && -1 != ($pos = index($sql, ':', $pos));) {
809 0           my ($name) = substr($sql, $pos) =~ m~^:([a-zA-Z_\d-]+)~;
810 0           my $param = eval{$self->_fetchParameter($name)};
  0            
811 0 0         croak "$@: interpolated so far: $sql" if $@;
812 0           my $value = "$param";
813              
814 0 0         $sql =
815             (0 < $pos ? substr($sql, 0, $pos) : '')
816             . $value
817             . substr($sql, $pos + 1 + length($name));
818 0           $pos += length $value;
819             }
820              
821 0           $self->{'-interpolated-query'} = $sql;
822             }
823              
824             sub _fetchParameter
825             {
826 0     0     my $self = shift;
827 0           my $name = shift;
828              
829 0 0         if (defined($name)) {
830 0 0         if (!exists($self->{'-params'}->{$name})) {
831 0           croak sprintf('No such query parameter "%s"', $name);
832             }
833 0           return $self->{'-params'}->{$name};
834             } else {
835 0 0 0       unless (ref $self->{'-params'} && @{$self->{'-params'}}) {
  0            
836 0           croak 'Too few query parameters provided';
837             }
838             }
839              
840 0           shift @{$self->{'-params'}};
  0            
841             }
842              
843             sub _checkLeftoverParameters
844             {
845 0     0     my $self = shift;
846              
847 0 0 0       if ('ARRAY' eq ref $self->{'-params'} && @{$self->{'-params'}}) {
  0            
848 0           croak 'Too many query parameters provided';
849             }
850             }
851              
852             sub _query
853             {
854 0     0     my $self = shift;
855 0           my $sql = shift;
856 0           my $dbh = sqlQuery::dbh();
857 0           my $error;
858              
859             EXECUTE: {
860 0 0         if ($sql !~ m/^select/i) {
  0            
861 0           local $dbh->{RaiseError} = 1;
862 0           local $dbh->{PrintError} = 0;
863 0           my $rows = eval{$dbh->do($sql)};
  0            
864 0 0         $error = $@, last EXECUTE if $@;
865 0           return $rows;
866             }
867              
868 0           $self->{'-sth'} = $dbh->prepare($sql);
869              
870 0           local $self->{'-sth'}->{RaiseError} = 1;
871 0           local $self->{'-sth'}->{PrintError} = 0;
872 0           eval {$self->{'-sth'}->execute};
  0            
873 0 0         $error = $@, last EXECUTE if $@;
874 0           return sqlQueryResult->new($self, $self->{'-sth'});
875             }
876              
877 0           my $file = __FILE__;
878              
879 0           $self->{'-sth'} = undef;
880              
881 0           $error =~ s/\s+at $file line \d+\.\r?\n//;
882 0           $error =~ s/\s*at line \d$//;
883 0           $sql =~ s/(?:\r?\n)+$//;
884 0           croak "$error\n\n<
885             }
886              
887             sub quoteTable
888             {
889 0     0     my $table = shift;
890              
891 0 0         if (ref $table)
892             {
893 0           my ($k,$v);
894 0           ($k) = keys %$table;
895 0           ($v) = values %$table;
896 0           return sprintf('%s AS %s', sqlQuery::quoteTable($k), sqlQuery::quoteTable($v));
897             }
898              
899 0 0         return '*'
900             if '*' eq $table;
901 0           $table = join '.', map {"`$_`"} split('\.', $table);
  0            
902 0           $table =~ s/`+/`/g;
903 0           $table
904             }
905              
906             sub quoteWhenTable
907             {
908 0     0     my $table = shift;
909              
910 0 0 0       return sqlQuery::quoteTable($table)
911             if ref $table || ".$table" =~ m/^(?:\.[a-z_][a-z\d_]*){1,2}$/i;
912 0 0         return $table
913             if $table !~ m/^([a-z_][a-z\d_]*)\.\*$/i;
914 0           return sqlQuery::quoteTable($1).'.*';
915             }
916              
917             sub convertArgument
918             {
919 0     0     my $arg = shift;
920 0           my $value = _convertArgument($arg);
921              
922 0 0         unless (defined($value)) {
923 0           local $Carp::CarpLevel = $Carp::CarpLevel + 1;
924 0           croak 'Argument to "sqlCondition::bind()" cannot be converted; consider using an implicit "sqlValue" instance instead'
925             }
926              
927             $value
928 0           }
929              
930             sub _convertArgument
931             {
932 0     0     my $arg = shift;
933              
934 0 0 0       unless(ref $arg) {
    0          
    0          
935 0 0         return sqlValueNull->new
936             unless defined($arg);
937 0 0         return sqlValueInt->new($arg)
938             if $arg =~ m/^-?\d+$/;
939 0 0         return sqlValueFloat->new($arg)
940             if $arg =~ m/^-?\d+[.]\d+$/;
941 0           return sqlValueString->new($arg);
942             } elsif ('ARRAY' eq ref $arg) {
943 0           return sqlValueList->new($arg);
944             } elsif (blessed $arg && $arg->isa('sqlParameter')) {
945 0           return $arg;
946             }
947 0           undef;
948             }
949             ##------------------------------------------------------------------------------
950             package sqlQueryResult;
951              
952 1     1   11 use strict;
  1         3  
  1         28  
953 1     1   3 use warnings;
  1         4  
  1         27  
954 1     1   3 use Carp qw(croak);
  1         1  
  1         53  
955 1     1   9 use Scalar::Util qw(looks_like_number);
  1         2  
  1         264  
956              
957             sub new
958             {
959 0 0   0     my $class = ref $_[0] ? ref shift : shift;
960 0           my $query = shift;
961 0           my $result = shift;
962              
963 0           bless {-query => $query, -result => $result}, $class;
964             }
965              
966 0     0     sub fetchAssoc {goto &fetchRow}
967             sub fetchRow
968             {
969 0     0     my $self = shift;
970 0           $self->{'-result'}->fetchrow_hashref
971             }
972              
973             sub fetchArray
974             {
975 0     0     my $self = shift;
976 0           $self->{'-result'}->fetchrow_array;
977             }
978              
979             sub fetchColumn
980             {
981 0     0     my $self = shift;
982 0   0       my $column = shift || '0';
983              
984 0 0         if (looks_like_number $column) {
985 0           my @row = $self->{'-result'}->fetchrow_array;
986 0 0         croak "No such query result offset $column"
987             if $column > $#row;
988 0           return $row[$column];
989             } else {
990 0           my $row = $self->fetchRow();
991 0 0         croak "No such query result column $column"
992             unless exists($row->{$column});
993 0           return $row->{$column};
994             }
995             }
996              
997             sub fetchAll
998             {
999 0     0     my $self = shift;
1000 0           my ($row,@rows);
1001              
1002 0           push @rows, $row
1003             while defined($row = $self->fetchAssoc());
1004             @rows
1005 0           }
1006              
1007 0     0     sub numRows {goto &getNumRows}
1008             sub getNumRows
1009             {
1010 0     0     shift->{'-result'}->rows;
1011             }
1012              
1013             sub freeResource
1014             {
1015 0     0     my $self = shift;
1016              
1017 0 0         croak 'Statement seems unexecuted'
1018             unless defined($self->{'-result'});
1019 0           $self->{'-result'}->finish();
1020 0           undef($self->{'-result'});
1021              
1022 0           $self;
1023             }
1024             ##------------------------------------------------------------------------------
1025             package sqlQueryBase;
1026              
1027 1     1   6 use strict;
  1         1  
  1         22  
1028 1     1   3 use warnings;
  1         0  
  1         107  
1029             ##------------------------------------------------------------------------------
1030             sub select
1031             {
1032 0     0     my @fields;
1033             my @params;
1034              
1035 0 0 0       if (@_ && 'ARRAY' eq ref $_[-1]) {
1036 0           @params = @{pop()};
  0            
1037             }
1038              
1039 0 0         unless (@_) {
1040 0           @fields = '*';
1041             } else {
1042 0           @fields = (
1043 0           split(',', join(',', grep {!ref} @_)),
1044 0           grep {ref} @_);
1045             }
1046              
1047 0           sqlSelectFrom->new(
1048             fields => [@fields],
1049             params => [@params]
1050             );
1051             }
1052             ##------------------------------------------------------------------------------
1053             package sqlParameter;
1054              
1055 1     1   3 use strict;
  1         1  
  1         17  
1056 1     1   2 use warnings;
  1         2  
  1         20  
1057 1     1   3 use overload '""' => 'getSafeQuotedValue';
  1         1  
  1         6  
1058 1     1   45 use Carp qw(croak);
  1         1  
  1         31  
1059              
1060             BEGIN {
1061 1     1   2 no strict 'refs';
  1         1  
  1         64  
1062 1     1   2 foreach my $k (qw(getSafeQuotedValue)) {
1063 1     0   46 *{__PACKAGE__."::$k"} = sub {croak __PACKAGE__."::$k() is abstract; implement it in ".(ref $_[0])}
  0         0  
1064 1         2 }
1065             }
1066              
1067             sub new
1068             {
1069 0 0   0     my $class = ref $_[0] ? ref shift : shift;
1070 0           bless {-value => shift}, $class;
1071             }
1072             ##------------------------------------------------------------------------------
1073             package sqlValueNull;
1074              
1075 1     1   3 use strict;
  1         1  
  1         20  
1076 1     1   5 use warnings;
  1         1  
  1         17  
1077 1     1   3 use base 'sqlParameter';
  1         0  
  1         281  
1078              
1079 0     0     sub getSafeQuotedValue {'NULL'}
1080             ##------------------------------------------------------------------------------
1081             package sqlValueLiteral;
1082              
1083 1     1   4 use strict;
  1         1  
  1         20  
1084 1     1   3 use warnings;
  1         0  
  1         26  
1085 1     1   3 use base 'sqlParameter';
  1         1  
  1         212  
1086              
1087 0     0     sub getSafeQuotedValue {shift->{-value}}
1088             ##------------------------------------------------------------------------------
1089             package sqlValueString;
1090              
1091 1     1   5 use strict;
  1         1  
  1         26  
1092 1     1   2 use warnings;
  1         1  
  1         20  
1093 1     1   3 use base 'sqlParameter';
  1         3  
  1         217  
1094              
1095             sub getSafeQuotedValue {
1096 0     0     my $self = shift;
1097 0           sqlQuery::dbh()->quote($self->{-value});
1098             }
1099             ##------------------------------------------------------------------------------
1100             package sqlValueInt;
1101              
1102 1     1   4 use strict;
  1         1  
  1         18  
1103 1     1   2 use warnings;
  1         1  
  1         22  
1104 1     1   2 use base 'sqlParameter';
  1         1  
  1         267  
1105              
1106             sub getSafeQuotedValue {
1107 0     0     int(shift->{-value})
1108             }
1109             ##------------------------------------------------------------------------------
1110             package sqlValueFloat;
1111              
1112 1     1   4 use strict;
  1         13  
  1         19  
1113 1     1   2 use warnings;
  1         1  
  1         20  
1114 1     1   3 use base 'sqlParameter';
  1         0  
  1         252  
1115              
1116             sub new {
1117 0     0     my $self = shift->SUPER::new(@_);
1118 0   0       $self->{-precision} = $_[1] || 8;
1119 0           $self
1120             }
1121              
1122             sub getSafeQuotedValue {
1123 0     0     my $self = shift;
1124 0           sprintf("%.$self->{-precision}f", $self->{-value})
1125             }
1126             ##------------------------------------------------------------------------------
1127             package sqlValueList;
1128              
1129 1     1   4 use strict;
  1         1  
  1         20  
1130 1     1   3 use warnings;
  1         1  
  1         20  
1131 1     1   5 use base 'sqlParameter';
  1         2  
  1         170  
1132 1     1   4 use Carp qw(croak);
  1         1  
  1         103  
1133              
1134             sub new {
1135 0     0     my $self = shift->SUPER::new(@_);
1136              
1137 0 0         unless (@{$self->{-value}}) {
  0            
1138 0           local $Carp::CarpLevel = $Carp::CarpLevel + 2;
1139 0           croak 'Empty lists can break SQL syntax.';
1140             }
1141              
1142             $self
1143 0           }
1144              
1145             sub getSafeQuotedValue {
1146 0     0     join ',', map {"$_"} @{shift->{-value}};
  0            
  0            
1147             }
1148             ##------------------------------------------------------------------------------
1149             package sqlValueDateTimeBase;
1150              
1151 1     1   4 use strict;
  1         1  
  1         30  
1152 1     1   4 use warnings;
  1         1  
  1         25  
1153 1     1   5 use base 'sqlParameter';
  1         1  
  1         200  
1154              
1155 1     1   405 use Date::Parse;
  1         5612  
  1         114  
1156 1     1   5 use Scalar::Util qw(looks_like_number);
  1         1  
  1         120  
1157              
1158             sub new {
1159 0     0     my $self = shift->SUPER::new(@_);
1160              
1161 0 0         unless (defined $self->{-value}) {
    0          
1162 0           $self->{-value} = time;
1163             } elsif (looks_like_number $self->{-value}) {
1164              
1165             } else {
1166 0           $self->{-value} = str2time($self->{-value});
1167             }
1168              
1169 0           $self
1170             }
1171              
1172             sub getSafeQuotedValue {
1173 0     0     sqlQuery::dbh()->quote(shift->format());
1174             }
1175              
1176             sub format {
1177 0     0     die __PACKAGE__.'::format() is "abstract"';
1178             }
1179             ##------------------------------------------------------------------------------
1180             package sqlValueDate;
1181              
1182 1     1   4 use strict;
  1         2  
  1         23  
1183 1     1   3 use warnings;
  1         1  
  1         27  
1184 1     1   3 use base 'sqlValueDateTimeBase';
  1         1  
  1         286  
1185 1     1   460 use POSIX qw(strftime);
  1         4800  
  1         4  
1186              
1187             sub format {
1188 0     0     strftime '%Y-%m-%d', localtime shift->{-value};
1189             }
1190             ##------------------------------------------------------------------------------
1191             package sqlValueDateTime;
1192              
1193 1     1   682 use strict;
  1         1  
  1         25  
1194 1     1   3 use warnings;
  1         1  
  1         21  
1195 1     1   3 use base 'sqlValueDateTimeBase';
  1         1  
  1         197  
1196 1     1   4 use POSIX qw(strftime);
  1         1  
  1         3  
1197              
1198             sub format {
1199 0     0     strftime '%Y-%m-%d %H:%M:%S', localtime shift->{-value};
1200             }
1201             ##------------------------------------------------------------------------------
1202             package sqlSelectAssemble;
1203              
1204 1     1   59 use strict;
  1         1  
  1         16  
1205 1     1   2 use warnings;
  1         1  
  1         20  
1206 1     1   2 use Carp qw/confess/;
  1         1  
  1         28  
1207 1     1   3 use overload '""' => 'assemble';
  1         1  
  1         4  
1208              
1209             sub new
1210             {
1211 0     0     my $class = shift;
1212 0           my ($prev,$prevClass,%args) = @_;
1213 0           my $self = bless {boundArgs => undef, prev => $prev, %args}, $class;
1214              
1215 0 0         if ($prevClass) {
1216 0 0 0       confess sprintf('Invalid predecessor. Got "%s". Wanted "%s"', ref $self->{prev}, $prevClass)
1217             unless ref $self->{prev} && $self->{prev}->isa($prevClass);
1218             }
1219              
1220             $self
1221 0           }
1222              
1223             sub addBoundArgs
1224             {
1225 0     0     my $self = shift;
1226 0           push @{$self->{boundArgs}}, @_;
  0            
1227 0           $self
1228             }
1229              
1230             sub gatherBoundArgs
1231             {
1232 0     0     my $self = shift;
1233 0           my (@args);
1234              
1235 0 0         push @args, @{$self->{boundArgs}}
  0            
1236             if $self->{boundArgs};
1237 0           push @args, $self->gatherConditionArgs();
1238              
1239 0 0         if ($self->{prev}) {
1240 0           push @args, $self->{prev}->gatherBoundArgs();
1241             }
1242              
1243             @args
1244 0           }
1245              
1246 0     0     sub gatherConditionArgs {}
1247              
1248             sub assemble
1249             {
1250 0     0     my $self = shift;
1251 0           my $assembled = $self->_assemble();
1252              
1253 0 0         $assembled = $self->{prev}->assemble() . $assembled
1254             if $self->{prev};
1255              
1256 0           $assembled
1257             }
1258              
1259             sub _assemble
1260             {
1261 0     0     ''
1262             }
1263             ##------------------------------------------------------------------------------
1264             package sqlSelectFrom;
1265              
1266 1     1   251 use strict;
  1         1  
  1         22  
1267 1     1   2 use warnings;
  1         1  
  1         24  
1268 1     1   3 use base 'sqlSelectAssemble';
  1         0  
  1         227  
1269 1     1   5 use Scalar::Util qw(blessed);
  1         1  
  1         449  
1270              
1271             sub new
1272             {
1273 0 0   0     my $class = ref $_[0] ? ref shift : shift;
1274 0           my (%args) = @_;
1275 0           my (@fields);
1276              
1277 0           @fields = @{$args{fields}};
  0            
1278              
1279 0           my $self = bless {
1280             queryFields => undef,
1281             tables => undef,
1282             params => $args{params}
1283             }, $class;
1284              
1285 0           $self->{queryFields} = [$self->translateQueryFields(@fields)];
1286 0           $self
1287             }
1288              
1289             sub from
1290             {
1291 0     0     my $self = shift;
1292 0           $self->{tables} = [@_];
1293 0           sqlSelectJoin->new($self);
1294             }
1295              
1296             sub translateQueryFields
1297             {
1298 0     0     my $self = shift;
1299 0           my (@fields) = @_;
1300 0           my @columns;
1301              
1302 0           foreach my $fieldIn (@fields)
1303             {
1304 0           my (@parts);
1305              
1306 0 0         unless ('HASH' eq ref $fieldIn) {
1307 0           @parts = ($fieldIn, undef);
1308             } else {
1309 0           @parts = %$fieldIn;
1310             }
1311              
1312 0           while (@parts) {
1313 0           my ($field,$alias) = splice(@parts, 0, 2);
1314              
1315 0 0 0       if (blessed $field && $field->isa('sqlParameter'))
1316             {
1317 0 0         push @columns, $sqlQuery::PARAMETER_PLACEHOLDER
1318             unless $alias;
1319 0 0         push @columns, sprintf('%s AS %s',
1320             $sqlQuery::PARAMETER_PLACEHOLDER,
1321             sqlQuery::quoteTable($alias))
1322             if $alias;
1323 0           $self->addBoundArgs($field);
1324 0           next;
1325             }
1326              
1327 0 0 0       $field = sqlQuery::quoteWhenTable($field)
1328             if '*' ne $field && 0 == ~index($field, ' ');
1329              
1330 0 0         unless ($alias) {
1331 0           push @columns, $field
1332             } else {
1333 0 0         $alias = sqlQuery::quoteWhenTable($alias)
1334             unless ~index($alias, ' ');
1335 0           push @columns, "\n\t$field AS $alias";
1336             }
1337             }
1338             }
1339              
1340             @columns
1341 0           }
1342              
1343             sub _assemble
1344             {
1345 0     0     my $self = shift;
1346 0           my $s = 'SELECT';
1347              
1348 0           $s .= ' ' . join(',', @{$self->{params}})
  0            
1349 0 0         if @{$self->{params}};
1350 0           $s .= ' ' . join(',', @{$self->{queryFields}});
  0            
1351              
1352 0 0         if (defined($self->{tables})) {
1353 0           $s .= "\nFROM ";
1354 0           my @t;
1355              
1356 0           foreach my $tableSpec (@{$self->{tables}}) {
  0            
1357 0           my (@tables);
1358              
1359 0 0         if ('HASH' eq ref $tableSpec) {
1360 0           @tables = %$tableSpec;
1361             } else {
1362 0           @tables = ($tableSpec,undef);
1363             }
1364              
1365 0           while (@tables) {
1366 0           my ($table,$alias) = splice(@tables, 0, 2);
1367              
1368 0 0         push @t, sqlQuery::quoteTable($table)
1369             unless $alias;
1370 0 0         push @t, sqlQuery::quoteTable($table)." AS `$alias`"
1371             if $alias;
1372             }
1373             }
1374              
1375 0           $s .= join ',', @t;
1376             }
1377              
1378 0           return "$s\n";
1379             }
1380             ##------------------------------------------------------------------------------
1381             package sqlSelectLimit;
1382              
1383 1     1   4 use strict;
  1         1  
  1         21  
1384 1     1   3 use base 'sqlSelectAssemble';
  1         0  
  1         373  
1385              
1386             sub new
1387             {
1388 0     0     sqlSelectAssemble::new(@_, 'sqlSelectOrderBy',
1389             limit => undef,
1390             offset => undef);
1391             }
1392              
1393             sub limit
1394             {
1395 0     0     my $self = shift;
1396              
1397 0 0 0       if (!@_ || (1 == @_ && !defined($_[0])) || (2 == @_ && !defined($_[0]) && !defined($_[1]))) {
      0        
      0        
      0        
      0        
1398 0           $self->{limit} = undef;
1399             } else {
1400 0           $self->{limit} = int(shift());
1401 0 0         $self->{offset} = int(shift()) if @_;
1402             }
1403 0           sqlSelectAssemble->new($self);
1404             }
1405              
1406             sub _assemble
1407             {
1408 0     0     my $self = shift;
1409 0           my $s;
1410              
1411 0 0         unless (defined($self->{limit})) {
    0          
1412 0           $s = '';
1413             } elsif (defined($self->{offset})) {
1414 0           $s = "LIMIT $self->{offset},$self->{limit}";
1415             } else {
1416 0           $s = "LIMIT $self->{limit}";
1417             }
1418              
1419 0           $s
1420             }
1421             ##------------------------------------------------------------------------------
1422             package sqlSelectOrderBy;
1423              
1424 1     1   5 use strict;
  1         2  
  1         31  
1425 1     1   5 use base 'sqlSelectLimit';
  1         1  
  1         429  
1426              
1427             sub new
1428             {
1429 0     0     sqlSelectAssemble::new(@_, 'sqlSelectHaving', ordering => undef);
1430             }
1431              
1432             sub orderBy
1433             {
1434 0     0     my $self = shift;
1435 0           $self->{ordering} = [@_];
1436 0           sqlSelectLimit->new($self);
1437             }
1438              
1439             sub _assemble
1440             {
1441 0     0     my $self = shift;
1442 0           my $s;
1443              
1444 0 0         unless(defined($self->{ordering})) {
1445 0           $s = '';
1446             } else {
1447 0           $s = [];
1448              
1449 0           foreach my $order (@{$self->{ordering}}) {
  0            
1450 0           my ($theOrder,$direction) = ($order);
1451 0 0         if ('HASH' eq ref $theOrder) {
1452 0           ($direction) = values %$theOrder;
1453 0           ($theOrder) = keys %$theOrder;
1454             }
1455              
1456 0 0         push @$s, sqlQuery::quoteWhenTable($theOrder)
1457             unless $direction;
1458 0 0         push @$s, sqlQuery::quoteWhenTable($theOrder)." $direction"
1459             if $direction;
1460             }
1461              
1462 0           $s = join ',', @$s;
1463 0           $s = "ORDER BY $s\n";
1464             }
1465              
1466 0           $s . $self->SUPER::_assemble();
1467             }
1468             ##------------------------------------------------------------------------------
1469             package sqlSelectHaving;
1470              
1471 1     1   5 use strict;
  1         1  
  1         23  
1472 1     1   3 use base 'sqlSelectOrderBy';
  1         5  
  1         410  
1473              
1474             sub new
1475             {
1476 0     0     sqlSelectAssemble::new(@_, 'sqlSelectGroupBy', havingCond => undef);
1477             }
1478              
1479             sub having
1480             {
1481 0     0     my $self = shift;
1482 0           my $condition = shift;
1483              
1484 0 0 0       die 'Invalid condition'
1485             unless ref $condition && $condition->isa('sqlCondition');
1486              
1487 0           $self->{havingCond} = $condition;
1488 0           sqlSelectOrderBy->new($self);
1489             }
1490              
1491             sub gatherConditionArgs
1492             {
1493 0     0     my $self = shift;
1494 0           my @args;
1495              
1496 0 0         push @args, $self->{havingCond}->getBoundArgs()
1497             if $self->{havingCond};
1498             @args
1499 0           }
1500              
1501             sub _assemble
1502             {
1503 0     0     my $self = shift;
1504 0           my $s;
1505              
1506 0 0 0       unless (defined($self->{havingCond}) && defined($s = $self->{havingCond}->assemble())) {
1507 0           $s = '';
1508             } else {
1509 0           $s = "HAVING $s\n";
1510             }
1511              
1512 0           $s . $self->SUPER::_assemble();
1513             }
1514             ##------------------------------------------------------------------------------
1515             package sqlSelectGroupBy;
1516              
1517 1     1   4 use strict;
  1         0  
  1         20  
1518 1     1   3 use base 'sqlSelectHaving';
  1         1  
  1         223  
1519 1     1   4 use overload '+' => 'union';
  1         1  
  1         4  
1520              
1521             sub union
1522             {
1523 0     0     my ($left,$right) = @_;
1524              
1525 0           "($left) UNION ($right)";
1526             }
1527              
1528             sub new
1529             {
1530 0     0     sqlSelectAssemble::new(@_, 'sqlSelectWhere', grouping => undef);
1531             }
1532              
1533             sub groupBy
1534             {
1535 0     0     my $self = shift;
1536 0           $self->{grouping} = [@_];
1537 0           sqlSelectHaving->new($self);
1538             }
1539              
1540             sub _assemble
1541             {
1542 0     0     my $self = shift;
1543 0           my $s = '';
1544              
1545 0 0         if (defined($self->{grouping}))
1546             {
1547 0           $s = join ',', map {sqlQuery::quoteWhenTable($_)} @{$self->{grouping}};
  0            
  0            
1548 0           $s = "GROUP BY $s\n";
1549             }
1550              
1551 0           $s . $self->SUPER::_assemble();
1552             }
1553             ##------------------------------------------------------------------------------
1554             package sqlSelectWhere;
1555              
1556 1     1   189 use strict;
  1         1  
  1         20  
1557 1     1   3 use base 'sqlSelectGroupBy';
  1         1  
  1         367  
1558              
1559             sub where
1560             {
1561 0     0     my $self = shift;
1562 0           my $condition = shift;
1563              
1564 0 0 0       die 'Invalid condition'
      0        
1565             unless !defined($condition) || (ref $condition && $condition->isa('sqlCondition'));
1566              
1567 0           $self->{whereCond} = $condition;
1568 0           sqlSelectGroupBy->new($self);
1569             }
1570              
1571             sub gatherConditionArgs
1572             {
1573 0     0     my $self = shift;
1574 0           my @args;
1575              
1576 0 0         push @args, $self->{whereCond}->getBoundArgs()
1577             if $self->{whereCond};
1578             @args
1579 0           }
1580              
1581             sub _assemble
1582             {
1583 0     0     my $self = shift;
1584 0           my ($s,$c) = ('');
1585              
1586 0 0 0       if ($self->{whereCond} && defined($c = $self->{whereCond}->assemble()))
1587             {
1588 0           $s = "WHERE $c\n";
1589             }
1590 0           $s . $self->SUPER::_assemble();
1591             }
1592             ##------------------------------------------------------------------------------
1593             package sqlSelectJoin;
1594              
1595 1     1   4 use strict;
  1         1  
  1         23  
1596 1     1   3 use base 'sqlSelectWhere';
  1         6  
  1         269  
1597              
1598 1     1   4 use Carp qw(confess);
  1         0  
  1         381  
1599              
1600             sub new
1601             {
1602 0     0     sqlSelectAssemble::new(@_, 'sqlSelectFrom', joins => []);
1603             }
1604              
1605             sub gatherConditionArgs
1606             {
1607 0     0     my $self = shift;
1608 0           my (@args);
1609              
1610 0 0         if ($self->isa('sqlSelectJoin')) {
1611 0           foreach my $join (@{$self->{joins}}) {
  0            
1612 0           my ($type,$table,$condition) = @$join;
1613 0 0         push @args, $condition->getBoundArgs()
1614             if ref $condition;
1615             }
1616             }
1617              
1618 0           (@args, $self->SUPER::gatherConditionArgs())
1619             }
1620              
1621 0     0     sub innerJoin {shift->_addJoin('INNER', @_)}
1622 0     0     sub rightJoin {shift->_addJoin('RIGHT', @_)}
1623 0     0     sub leftJoin {shift->_addJoin('LEFT', @_)}
1624              
1625             sub _addJoin
1626             {
1627 0     0     my $self = shift;
1628 0           my ($type,$table,$condition) = @_;
1629 0           push @{$self->{joins}}, [$type, $table, $condition];
  0            
1630              
1631 0           $self
1632             }
1633              
1634             sub _assemble
1635             {
1636 0     0     my $self = shift;
1637 0           my $s;
1638              
1639 0 0         unless ($self->isa('sqlSelectJoin')) {
1640 0           $s = ref $self;
1641             } else {
1642 0           $s = [];
1643              
1644 0           foreach my $join (@{$self->{joins}}) {
  0            
1645 0           my ($type, $table, $condition) = @$join;
1646 0           $table = sqlQuery::quoteTable($table);
1647 0           my $j = "$type JOIN $table ";
1648              
1649 0 0         unless (ref $condition) {
    0          
1650 0           $j .= "USING(`$condition`)";
1651             } elsif ($condition->isa('sqlCondition')) {
1652 0           $_ = $condition->assemble();
1653 0           $j .= "ON($_)";
1654             } else {
1655 0           confess sprintf('Cannot use argument "%s" as join condition', $condition);
1656             }
1657              
1658 0           push @$s, "$j\n";
1659             }
1660              
1661 0           $s = join '', @$s;
1662             }
1663              
1664 0           $s . $self->SUPER::_assemble();
1665             }
1666             ##------------------------------------------------------------------------------
1667             package sqlCondition;
1668              
1669 1     1   3 use strict;
  1         4  
  1         19  
1670 1     1   30 use warnings;
  1         1  
  1         23  
1671 1     1   3 use feature 'switch';
  1         1  
  1         78  
1672             use overload
1673 1         3 '""' => 'assemble',
1674             '+' => 'overloadAdd',
1675             '!' => 'overloadNot',
1676             '&' => 'overloadAnd',
1677 1     1   3 '|' => 'overloadOr';
  1         1  
1678 1     1   65 use constant TYPE_DEFAULT => 1;
  1         1  
  1         50  
1679 1     1   4 use constant TYPE_CONNECT_AND => 2;
  1         0  
  1         26  
1680 1     1   3 use constant TYPE_CONNECT_OR => 3;
  1         3  
  1         28  
1681 1     1   3 use constant TYPE_UNARY_NOT => 4;
  1         1  
  1         29  
1682              
1683 1     1   2 use Carp qw(confess);
  1         1  
  1         29  
1684 1     1   3 use Params::Validate qw(:all);
  1         1  
  1         183  
1685 1     1   4 use Scalar::Util qw(blessed);
  1         1  
  1         1569  
1686              
1687             sub new
1688             {
1689 0 0   0     my $class = ref $_[0] ? ref shift : shift;
1690 0           my $self = bless{
1691             parent => undef,
1692             type => shift,
1693             _parts => undef,
1694             _condition => undef,
1695             _alterForNull => undef,
1696             _argument => undef,
1697             _queryArguments => []
1698             }, $class;
1699              
1700 0 0         if (TYPE_UNARY_NOT == $self->{type})
1701             {
1702 0           $self->{_argument} = shift;
1703 0 0 0       die 'Invalid argument' unless
1704             ref $self->{_argument} && $self->{_argument}->isa('sqlCondition');
1705 0           $self->{_argument}->setParent($self);
1706             }
1707              
1708             $self
1709 0           }
1710              
1711             sub assemble
1712             {
1713 0     0     my $self = shift;
1714              
1715 0           given($self->{type}) {
1716              
1717 0           when([TYPE_CONNECT_AND, TYPE_CONNECT_OR]) {
1718 0 0         return undef unless $self->{_parts};
1719 0 0         my ($glue) = (TYPE_CONNECT_AND == $self->{type} ? ' AND ' : ' OR ');
1720 0           return '('.join($glue, map {$_->assemble()} @{$self->{_parts}}).')';
  0            
  0            
1721             }
1722              
1723 0           when([TYPE_DEFAULT]) {
1724 0 0 0       return $self->{_condition}
1725             unless ref $self->{_condition} && $self->{_condition}->isa('sqlCondition');
1726 0           return $self->{_condition}->assemble();
1727             }
1728              
1729 0           when([TYPE_UNARY_NOT]) {
1730 0           $_ = $self->{_argument}->assemble();
1731 0           return "NOT($_)";
1732             }
1733             }
1734             }
1735              
1736             sub overloadAdd
1737             {
1738 0     0     my ($left,$right,$leftConstant) = @_;
1739              
1740 0 0         warn "sqlCondition + sqlCondition will modify the left operand"
1741             if defined $leftConstant;
1742 0           $left->add($right);
1743             }
1744              
1745             sub getOverloadArgs
1746             {
1747 0     0     my ($left,$right,$swap) = @_;
1748              
1749 0 0         ($left,$right) = ($right,$left) if $swap;
1750              
1751 0 0         $left = sqlCondition::C($left) unless ref $left;
1752 0 0         $right = sqlCondition::C($right) unless ref $right;
1753              
1754 0 0 0       die 'Illegal LHS operand' unless blessed($left) && $left->isa('sqlCondition');
1755 0 0 0       die 'Illegal RHS operand' unless blessed($right) && $left->isa('sqlCondition');
1756              
1757 0           ($left,$right);
1758             }
1759              
1760             sub overloadAnd
1761             {
1762 0     0     my ($left,$right) = getOverloadArgs(@_);
1763 0           sqlCondition::AND($left, $right);
1764             }
1765              
1766             sub overloadNot
1767             {
1768 0     0     sqlCondition::NOT($_[0]);
1769             }
1770              
1771             sub overloadOr
1772             {
1773 0     0     my ($left,$right) = getOverloadArgs(@_);
1774 0           sqlCondition::OR($left, $right);
1775             }
1776              
1777             sub add
1778             {
1779 0     0     my $self = shift;
1780 0 0         $self->{_parts} = [] unless $self->{_parts};
1781              
1782 0           push @{$self->{_parts}}, @_;
  0            
1783 0           $_->setParent($self) foreach @_;
1784              
1785 0           $self
1786             }
1787              
1788             sub addSql
1789             {
1790 0     0     my $self = shift;
1791 0           my $format = shift;
1792              
1793 0           $self->add(C(sprintf($format, @_)));
1794             }
1795              
1796             sub bind
1797             {
1798 0     0     my $self = shift;
1799              
1800 0 0 0       if (1 == scalar @_ && !defined($_[0]) && defined($self->{_alterForNull})) {
      0        
1801 0           ($self->{_condition}) = split(' ', $self->{_condition}, 2);
1802 0 0         $self->{_condition} .= ' IS '.($self->{_alterForNull} ? '' : 'NOT ').'NULL';
1803 0           return $self;
1804             }
1805              
1806             $self->_bind(sqlQuery::convertArgument($_))
1807 0           foreach (@_);
1808 0           $self
1809             }
1810              
1811             sub getBoundArgs
1812             {
1813 0     0     @{shift->{_queryArguments}};
  0            
1814             }
1815              
1816             sub releaseBoundArgs
1817             {
1818 0     0     my $self = shift;
1819 0           my @args = $self->getBoundArgs();
1820 0           $self->{_queryArguments} = [];
1821 0           @args;
1822             }
1823              
1824 0     0     sub _OR {goto &OR}
1825             sub OR
1826             {
1827 0 0   0     confess 'OR() expects at least 1 parameter.' unless @_;
1828 0           connectedList(TYPE_CONNECT_OR, @_);
1829             }
1830              
1831 0     0     sub _AND {goto &AND}
1832             sub AND
1833             {
1834 0 0   0     confess 'AND() expects at least 1 parameter.' unless @_;
1835 0           connectedList(TYPE_CONNECT_AND, @_);
1836             }
1837              
1838             sub NOT
1839             {
1840 0     0     sqlCondition->new(TYPE_UNARY_NOT, @_);
1841             }
1842              
1843             sub C
1844             {
1845 0     0     my $cond = sqlCondition->new(TYPE_DEFAULT);
1846              
1847 0 0         if (1 == scalar @_) {
1848 0           $cond->{_condition} = shift;
1849             } else {
1850 0           $cond->{_condition} = sprintf($_[0], @_[1..$#_]);
1851             }
1852              
1853 0           $cond
1854             }
1855              
1856             sub IN
1857             {
1858 0     0     my $column = shift;
1859 0           C("%s IN($sqlQuery::PARAMETER_PLACEHOLDER)", sqlQuery::quoteWhenTable($column));
1860             }
1861              
1862             sub NOTIN
1863             {
1864 0     0     my $column = shift;
1865 0           C("%s NOT IN($sqlQuery::PARAMETER_PLACEHOLDER)", sqlQuery::quoteWhenTable($column));
1866             }
1867              
1868             sub LIKE
1869             {
1870 0     0     my ($column,$pattern) = validate_pos @_,
1871             {column => {type => SCALAR}},
1872             {pattern => {type => SCALAR}};
1873              
1874 0           $pattern =~ s/"/""/g;
1875 0           $column = sqlQuery::quoteWhenTable($column);
1876 0           C("$column LIKE \"$pattern\"");
1877             }
1878              
1879             sub BETWEEN
1880             {
1881 0     0     my ($column,$start,$end) = validate_pos @_,
1882             {column => {type => SCALAR}},
1883             {start => {isa => 'sqlParameter'}},
1884             {end => {isa => 'sqlParameter'}};
1885 0           $column = sqlQuery::quoteWhenTable($column);
1886              
1887 0           C("$column BETWEEN $sqlQuery::PARAMETER_PLACEHOLDER AND $sqlQuery::PARAMETER_PLACEHOLDER")
1888             ->bind($start)->bind($end);
1889             }
1890              
1891             sub ISNULL
1892             {
1893 0     0     my ($column) = validate_pos @_,
1894             {column => {type => SCALAR}};
1895 0           $column = sqlQuery::quoteWhenTable($column);
1896              
1897 0           C("$column IS NULL")
1898             }
1899              
1900             sub ISNOTNULL
1901             {
1902 0     0     my ($column) = validate_pos @_,
1903             {column => {type => SCALAR}};
1904 0           $column = sqlQuery::quoteWhenTable($column);
1905              
1906 0           C("$column IS NOT NULL")
1907             }
1908              
1909             sub EQ
1910             {
1911 0     0     my $cond = _OP('=', @_);
1912 0           $cond->{_alterForNull} = 1;
1913 0           $cond
1914             }
1915              
1916             sub NE
1917             {
1918 0     0     my $cond = _OP('!=', @_);
1919 0           $cond->{_alterForNull} = 0;
1920 0           $cond
1921             }
1922              
1923 0     0     sub LT {_OP('<', @_)}
1924 0     0     sub GT {_OP('>', @_)}
1925 0     0     sub LTE {_OP('<=', @_)}
1926 0     0     sub GTE {_OP('>=', @_)}
1927              
1928             sub _OP
1929             {
1930 0     0     my ($operator, $left, $right) = @_;
1931 0 0         C('%s %s %s',
1932             sqlQuery::quoteWhenTable($left),
1933             $operator,
1934             3 != scalar @_
1935             ? $sqlQuery::PARAMETER_PLACEHOLDER
1936             : sqlQuery::quoteWhenTable($right));
1937             }
1938              
1939             sub connectedList
1940             {
1941 0     0     my $type = shift;
1942 0           my $cond = sqlCondition->new($type);
1943              
1944 0           foreach my $a (@_) {
1945 0 0 0       $cond->insert($a), next unless blessed($a) && $a->isa('sqlCondition');
1946 0 0         $cond->insert($a), next if $a->{type} != $type;
1947 0           $cond->_bind($_) foreach $a->releaseBoundArgs();
1948 0           $cond->insert(@{$a->{_parts}});
  0            
1949             }
1950              
1951             $cond
1952 0           }
1953              
1954             sub insert
1955             {
1956 0     0     my $self = shift;
1957              
1958 0 0         $self->{_parts} = [] unless $self->{_parts};
1959 0           $self->add(@_);
1960             }
1961              
1962             sub _bind
1963             {
1964 0     0     my $self = shift;
1965 0           my ($parameter) = validate_pos @_,
1966             {parameter => {isa => 'sqlParameter'}};
1967              
1968 0 0         push @{$self->{_queryArguments}}, $parameter
  0            
1969             unless $self->{parent};
1970 0 0         $self->{parent}->up()->_bind($parameter)
1971             if $self->{parent};
1972 0           $self
1973             }
1974              
1975             sub setParent
1976             {
1977 0     0     my $self = shift;
1978 0           my ($parent) = validate_pos @_,
1979             {parameter => {isa => 'sqlCondition'}};
1980              
1981 0           $self->{parent} = $parent;
1982 0           $self->{parent}->up()->_bind($_)
1983 0           foreach @{$self->{_queryArguments}};
1984 0           $self->{_queryArguments} = [];
1985 0           $self
1986             }
1987              
1988             sub up
1989             {
1990 0     0     my $self = shift;
1991              
1992 0 0         return $self
1993             unless defined($self->{parent});
1994 0           $self->{parent}->up();
1995             }
1996              
1997             1