Profile of /project/perl/lib/SQL/Abstract.pm

File	/project/perl/lib/SQL/Abstract.pm
Statements Executed	10
Statement Execution Time	6.31ms

Subroutines — ordered by exclusive time
Exclusive Time	Inclusive Time	Subroutine
0s	0s	SQL::Abstract::::AUTOLOADSQL::Abstract::AUTOLOAD
0s	0s	SQL::Abstract::::BEGINSQL::Abstract::BEGIN
0s	0s	SQL::Abstract::::DESTROYSQL::Abstract::DESTROY
0s	0s	SQL::Abstract::::_anoncopySQL::Abstract::_anoncopy
0s	0s	SQL::Abstract::::_bindtypeSQL::Abstract::_bindtype
0s	0s	SQL::Abstract::::_convertSQL::Abstract::_convert
0s	0s	SQL::Abstract::::_debugSQL::Abstract::_debug
0s	0s	SQL::Abstract::::_modlogicSQL::Abstract::_modlogic
0s	0s	SQL::Abstract::::_order_bySQL::Abstract::_order_by
0s	0s	SQL::Abstract::::_quoteSQL::Abstract::_quote
0s	0s	SQL::Abstract::::_recurse_whereSQL::Abstract::_recurse_where
0s	0s	SQL::Abstract::::_sqlcaseSQL::Abstract::_sqlcase
0s	0s	SQL::Abstract::::_tableSQL::Abstract::_table
0s	0s	SQL::Abstract::::belchSQL::Abstract::belch
0s	0s	SQL::Abstract::::deleteSQL::Abstract::delete
0s	0s	SQL::Abstract::::generateSQL::Abstract::generate
0s	0s	SQL::Abstract::::insertSQL::Abstract::insert
0s	0s	SQL::Abstract::::newSQL::Abstract::new
0s	0s	SQL::Abstract::::pukeSQL::Abstract::puke
0s	0s	SQL::Abstract::::selectSQL::Abstract::select
0s	0s	SQL::Abstract::::updateSQL::Abstract::update
0s	0s	SQL::Abstract::::valuesSQL::Abstract::values
0s	0s	SQL::Abstract::::whereSQL::Abstract::where

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1
2					package SQL::Abstract;
3
4					=head1 NAME
5
6					SQL::Abstract - Generate SQL from Perl data structures
7
8					=head1 SYNOPSIS
9
10					use SQL::Abstract;
11
12					my $sql = SQL::Abstract->new;
13
14					my($stmt, @bind) = $sql->select($table, \@fields, \%where, \@order);
15
16					my($stmt, @bind) = $sql->insert($table, \%fieldvals \|\| \@values);
17
18					my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where);
19
20					my($stmt, @bind) = $sql->delete($table, \%where);
21
22					# Then, use these in your DBI statements
23					my $sth = $dbh->prepare($stmt);
24					$sth->execute(@bind);
25
26					# Just generate the WHERE clause
27					my($stmt, @bind) = $sql->where(\%where, \@order);
28
29					# Return values in the same order, for hashed queries
30					# See PERFORMANCE section for more details
31					my @bind = $sql->values(\%fieldvals);
32
33					=head1 DESCRIPTION
34
35					This module was inspired by the excellent L<DBIx::Abstract>.
36					However, in using that module I found that what I really wanted
37					to do was generate SQL, but still retain complete control over my
38					statement handles and use the DBI interface. So, I set out to
39					create an abstract SQL generation module.
40
41					While based on the concepts used by L<DBIx::Abstract>, there are
42					several important differences, especially when it comes to WHERE
43					clauses. I have modified the concepts used to make the SQL easier
44					to generate from Perl data structures and, IMO, more intuitive.
45					The underlying idea is for this module to do what you mean, based
46					on the data structures you provide it. The big advantage is that
47					you don't have to modify your code every time your data changes,
48					as this module figures it out.
49
50					To begin with, an SQL INSERT is as easy as just specifying a hash
51					of C<key=value> pairs:
52
53					my %data = (
54					name => 'Jimbo Bobson',
55					phone => '123-456-7890',
56					address => '42 Sister Lane',
57					city => 'St. Louis',
58					state => 'Louisiana',
59					);
60
61					The SQL can then be generated with this:
62
63					my($stmt, @bind) = $sql->insert('people', \%data);
64
65					Which would give you something like this:
66
67					$stmt = "INSERT INTO people
68					(address, city, name, phone, state)
69					VALUES (?, ?, ?, ?, ?)";
70					@bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson',
71					'123-456-7890', 'Louisiana');
72
73					These are then used directly in your DBI code:
74
75					my $sth = $dbh->prepare($stmt);
76					$sth->execute(@bind);
77
78					In addition, you can apply SQL functions to elements of your C<%data>
79					by specifying an arrayref for the given hash value. For example, if
80					you need to execute the Oracle C<to_date> function on a value, you
81					can say something like this:
82
83					my %data = (
84					name => 'Bill',
85					date_entered => ["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
86					);
87
88					The first value in the array is the actual SQL. Any other values are
89					optional and would be included in the bind values array. This gives
90					you:
91
92					my($stmt, @bind) = $sql->insert('people', \%data);
93
94					$stmt = "INSERT INTO people (name, date_entered)
95					VALUES (?, to_date(?,'MM/DD/YYYY'))";
96					@bind = ('Bill', '03/02/2003');
97
98					An UPDATE is just as easy, all you change is the name of the function:
99
100					my($stmt, @bind) = $sql->update('people', \%data);
101
102					Notice that your C<%data> isn't touched; the module will generate
103					the appropriately quirky SQL for you automatically. Usually you'll
104					want to specify a WHERE clause for your UPDATE, though, which is
105					where handling C<%where> hashes comes in handy...
106
107					This module can generate pretty complicated WHERE statements
108					easily. For example, simple C<key=value> pairs are taken to mean
109					equality, and if you want to see if a field is within a set
110					of values, you can use an arrayref. Let's say we wanted to
111					SELECT some data based on this criteria:
112
113					my %where = (
114					requestor => 'inna',
115					worker => ['nwiger', 'rcwe', 'sfz'],
116					status => { '!=', 'completed' }
117					);
118
119					my($stmt, @bind) = $sql->select('tickets', '*', \%where);
120
121					The above would give you something like this:
122
123					$stmt = "SELECT * FROM tickets WHERE
124					( requestor = ? ) AND ( status != ? )
125					AND ( worker = ? OR worker = ? OR worker = ? )";
126					@bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
127
128					Which you could then use in DBI code like so:
129
130					my $sth = $dbh->prepare($stmt);
131					$sth->execute(@bind);
132
133					Easy, eh?
134
135					=head1 FUNCTIONS
136
137					The functions are simple. There's one for each major SQL operation,
138					and a constructor you use first. The arguments are specified in a
139					similar order to each function (table, then fields, then a where
140					clause) to try and simplify things.
141
142					=cut
143
144	3	106µs	1	246µs	use Carp; # spent 246µs making 1 call to Exporter::import
145	3	6.17ms	1	21µs	use strict; # spent 21µs making 1 call to strict::import
146
147	1	7µs			our $VERSION = '1.22';
148	1	6µs			our $REVISION = '$Id: Abstract.pm 12 2006-11-30 17:05:24Z nwiger $';
149	1	4µs			our $AUTOLOAD;
150
151					# Fix SQL case, if so requested
152					sub _sqlcase {
153					my $self = shift;
154					return $self->{case} ? $_[0] : uc($_[0]);
155					}
156
157					# Anon copies of arrays/hashes
158					# Based on deep_copy example by merlyn
159					# http://www.stonehenge.com/merlyn/UnixReview/col30.html
160					sub _anoncopy {
161					my $orig = shift;
162					return (ref $orig eq 'HASH') ? +{map { $_ => _anoncopy($orig->{$_}) } keys %$orig}
163					: (ref $orig eq 'ARRAY') ? [map _anoncopy($_), @$orig]
164					: $orig;
165					}
166
167					# Debug
168					sub _debug {
169					return unless $_[0]->{debug}; shift; # a little faster
170					my $func = (caller(1))[3];
171					warn "[$func] ", @_, "\n";
172					}
173
174					sub belch (@) {
175					my($func) = (caller(1))[3];
176					carp "[$func] Warning: ", @_;
177					}
178
179					sub puke (@) {
180					my($func) = (caller(1))[3];
181					croak "[$func] Fatal: ", @_;
182					}
183
184					# Utility functions
185					sub _table {
186					my $self = shift;
187					my $tab = shift;
188					if (ref $tab eq 'ARRAY') {
189					return join ', ', map { $self->_quote($_) } @$tab;
190					} else {
191					return $self->_quote($tab);
192					}
193					}
194
195					sub _quote {
196					my $self = shift;
197					my $label = shift;
198
199					return $label
200					if $label eq '*';
201
202					return $self->{quote_char} . $label . $self->{quote_char}
203					if !defined $self->{name_sep};
204
205					return join $self->{name_sep},
206					map { $self->{quote_char} . $_ . $self->{quote_char} }
207					split /\Q$self->{name_sep}\E/, $label;
208					}
209
210					# Conversion, if applicable
211					sub _convert ($) {
212					my $self = shift;
213					return @_ unless $self->{convert};
214					my $conv = $self->_sqlcase($self->{convert});
215					my @ret = map { $conv.'('.$_.')' } @_;
216					return wantarray ? @ret : $ret[0];
217					}
218
219					# And bindtype
220					sub _bindtype (@) {
221					my $self = shift;
222					my($col,@val) = @_;
223					return $self->{bindtype} eq 'columns' ? [ @_ ] : @val;
224					}
225
226					# Modified -logic or -nest
227					sub _modlogic ($) {
228					my $self = shift;
229					my $sym = @_ ? lc(shift) : $self->{logic};
230					$sym =~ tr/_/ /;
231					$sym = $self->{logic} if $sym eq 'nest';
232					return $self->_sqlcase($sym); # override join
233					}
234
235					=head2 new(option => 'value')
236
237					The C<new()> function takes a list of options and values, and returns
238					a new B<SQL::Abstract> object which can then be used to generate SQL
239					through the methods below. The options accepted are:
240
241					=over
242
243					=item case
244
245					If set to 'lower', then SQL will be generated in all lowercase. By
246					default SQL is generated in "textbook" case meaning something like:
247
248					SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
249
250					=item cmp
251
252					This determines what the default comparison operator is. By default
253					it is C<=>, meaning that a hash like this:
254
255					%where = (name => 'nwiger', email => 'nate@wiger.org');
256
257					Will generate SQL like this:
258
259					WHERE name = 'nwiger' AND email = 'nate@wiger.org'
260
261					However, you may want loose comparisons by default, so if you set
262					C<cmp> to C<like> you would get SQL such as:
263
264					WHERE name like 'nwiger' AND email like 'nate@wiger.org'
265
266					You can also override the comparsion on an individual basis - see
267					the huge section on L</"WHERE CLAUSES"> at the bottom.
268
269					=item logic
270
271					This determines the default logical operator for multiple WHERE
272					statements in arrays. By default it is "or", meaning that a WHERE
273					array of the form:
274
275					@where = (
276					event_date => {'>=', '2/13/99'},
277					event_date => {'<=', '4/24/03'},
278					);
279
280					Will generate SQL like this:
281
282					WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
283
284					This is probably not what you want given this query, though (look
285					at the dates). To change the "OR" to an "AND", simply specify:
286
287					my $sql = SQL::Abstract->new(logic => 'and');
288
289					Which will change the above C<WHERE> to:
290
291					WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
292
293					=item convert
294
295					This will automatically convert comparisons using the specified SQL
296					function for both column and value. This is mostly used with an argument
297					of C<upper> or C<lower>, so that the SQL will have the effect of
298					case-insensitive "searches". For example, this:
299
300					$sql = SQL::Abstract->new(convert => 'upper');
301					%where = (keywords => 'MaKe iT CAse inSeNSItive');
302
303					Will turn out the following SQL:
304
305					WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive')
306
307					The conversion can be C<upper()>, C<lower()>, or any other SQL function
308					that can be applied symmetrically to fields (actually B<SQL::Abstract> does
309					not validate this option; it will just pass through what you specify verbatim).
310
311					=item bindtype
312
313					This is a kludge because many databases suck. For example, you can't
314					just bind values using DBI's C<execute()> for Oracle C<CLOB> or C<BLOB> fields.
315					Instead, you have to use C<bind_param()>:
316
317					$sth->bind_param(1, 'reg data');
318					$sth->bind_param(2, $lots, {ora_type => ORA_CLOB});
319
320					The problem is, B<SQL::Abstract> will normally just return a C<@bind> array,
321					which loses track of which field each slot refers to. Fear not.
322
323					If you specify C<bindtype> in new, you can determine how C<@bind> is returned.
324					Currently, you can specify either C<normal> (default) or C<columns>. If you
325					specify C<columns>, you will get an array that looks like this:
326
327					my $sql = SQL::Abstract->new(bindtype => 'columns');
328					my($stmt, @bind) = $sql->insert(...);
329
330					@bind = (
331					[ 'column1', 'value1' ],
332					[ 'column2', 'value2' ],
333					[ 'column3', 'value3' ],
334					);
335
336					You can then iterate through this manually, using DBI's C<bind_param()>.
337
338					$sth->prepare($stmt);
339					my $i = 1;
340					for (@bind) {
341					my($col, $data) = @$_;
342					if ($col eq 'details' \|\| $col eq 'comments') {
343					$sth->bind_param($i, $data, {ora_type => ORA_CLOB});
344					} elsif ($col eq 'image') {
345					$sth->bind_param($i, $data, {ora_type => ORA_BLOB});
346					} else {
347					$sth->bind_param($i, $data);
348					}
349					$i++;
350					}
351					$sth->execute; # execute without @bind now
352
353					Now, why would you still use B<SQL::Abstract> if you have to do this crap?
354					Basically, the advantage is still that you don't have to care which fields
355					are or are not included. You could wrap that above C<for> loop in a simple
356					sub called C<bind_fields()> or something and reuse it repeatedly. You still
357					get a layer of abstraction over manual SQL specification.
358
359					=item quote_char
360
361					This is the character that a table or column name will be quoted
362					with. By default this is an empty string, but you could set it to
363					the character C<`>, to generate SQL like this:
364
365					SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
366
367					This is useful if you have tables or columns that are reserved words
368					in your database's SQL dialect.
369
370					=item name_sep
371
372					This is the character that separates a table and column name. It is
373					necessary to specify this when the C<quote_char> option is selected,
374					so that tables and column names can be individually quoted like this:
375
376					SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
377
378					=back
379
380					=cut
381
382					sub new {
383					my $self = shift;
384					my $class = ref($self) \|\| $self;
385					my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
386
387					# choose our case by keeping an option around
388					delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
389
390					# override logical operator
391					$opt{logic} = uc $opt{logic} if $opt{logic};
392
393					# how to return bind vars
394					$opt{bindtype} \|\|= delete($opt{bind_type}) \|\| 'normal';
395
396					# default comparison is "=", but can be overridden
397					$opt{cmp} \|\|= '=';
398
399					# default quotation character around tables/columns
400					$opt{quote_char} \|\|= '';
401
402					return bless \%opt, $class;
403					}
404
405					=head2 insert($table, \@values \|\| \%fieldvals)
406
407					This is the simplest function. You simply give it a table name
408					and either an arrayref of values or hashref of field/value pairs.
409					It returns an SQL INSERT statement and a list of bind values.
410
411					=cut
412
413					sub insert {
414					my $self = shift;
415					my $table = $self->_table(shift);
416					my $data = shift \|\| return;
417
418					my $sql = $self->_sqlcase('insert into') . " $table ";
419					my(@sqlf, @sqlv, @sqlq) = ();
420
421					my $ref = ref $data;
422					if ($ref eq 'HASH') {
423					for my $k (sort keys %$data) {
424					my $v = $data->{$k};
425					my $r = ref $v;
426					# named fields, so must save names in order
427					push @sqlf, $self->_quote($k);
428					if ($r eq 'ARRAY') {
429					# SQL included for values
430					my @val = @$v;
431					push @sqlq, shift @val;
432					push @sqlv, $self->_bindtype($k, @val);
433					} elsif ($r eq 'SCALAR') {
434					# embedded literal SQL
435					push @sqlq, $$v;
436					} else {
437					push @sqlq, '?';
438					push @sqlv, $self->_bindtype($k, $v);
439					}
440					}
441					$sql .= '(' . join(', ', @sqlf) .') '. $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')';
442					} elsif ($ref eq 'ARRAY') {
443					# just generate values(?,?) part
444					# no names (arrayref) so can't generate bindtype
445					carp "Warning: ",__PACKAGE__,"->insert called with arrayref when bindtype set"
446					if $self->{bindtype} ne 'normal';
447					for my $v (@$data) {
448					my $r = ref $v;
449					if ($r eq 'ARRAY') {
450					my @val = @$v;
451					push @sqlq, shift @val;
452					push @sqlv, @val;
453					} elsif ($r eq 'SCALAR') {
454					# embedded literal SQL
455					push @sqlq, $$v;
456					} else {
457					push @sqlq, '?';
458					push @sqlv, $v;
459					}
460					}
461					$sql .= $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')';
462					} elsif ($ref eq 'SCALAR') {
463					# literal SQL
464					$sql .= $$data;
465					} else {
466					puke "Unsupported data type specified to \$sql->insert";
467					}
468
469					return wantarray ? ($sql, @sqlv) : $sql;
470					}
471
472					=head2 update($table, \%fieldvals, \%where)
473
474					This takes a table, hashref of field/value pairs, and an optional
475					hashref WHERE clause. It returns an SQL UPDATE function and a list
476					of bind values.
477
478					=cut
479
480					sub update {
481					my $self = shift;
482					my $table = $self->_table(shift);
483					my $data = shift \|\| return;
484					my $where = shift;
485
486					my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ');
487					my(@sqlf, @sqlv) = ();
488
489					puke "Unsupported data type specified to \$sql->update"
490					unless ref $data eq 'HASH';
491
492					for my $k (sort keys %$data) {
493					my $v = $data->{$k};
494					my $r = ref $v;
495					my $label = $self->_quote($k);
496					if ($r eq 'ARRAY') {
497					# SQL included for values
498					my @bind = @$v;
499					my $sql = shift @bind;
500					push @sqlf, "$label = $sql";
501					push @sqlv, $self->_bindtype($k, @bind);
502					} elsif ($r eq 'SCALAR') {
503					# embedded literal SQL
504					push @sqlf, "$label = $$v";
505					} else {
506					push @sqlf, "$label = ?";
507					push @sqlv, $self->_bindtype($k, $v);
508					}
509					}
510
511					$sql .= join ', ', @sqlf;
512
513					if ($where) {
514					my($wsql, @wval) = $self->where($where);
515					$sql .= $wsql;
516					push @sqlv, @wval;
517					}
518
519					return wantarray ? ($sql, @sqlv) : $sql;
520					}
521
522					=head2 select($table, \@fields, \%where, \@order)
523
524					This takes a table, arrayref of fields (or '*'), optional hashref
525					WHERE clause, and optional arrayref order by, and returns the
526					corresponding SQL SELECT statement and list of bind values.
527
528					=cut
529
530					sub select {
531					my $self = shift;
532					my $table = $self->_table(shift);
533					my $fields = shift \|\| '*';
534					my $where = shift;
535					my $order = shift;
536
537					my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields : $fields;
538					my $sql = join ' ', $self->_sqlcase('select'), $f, $self->_sqlcase('from'), $table;
539
540					my(@sqlf, @sqlv) = ();
541					my($wsql, @wval) = $self->where($where, $order);
542					$sql .= $wsql;
543					push @sqlv, @wval;
544
545					return wantarray ? ($sql, @sqlv) : $sql;
546					}
547
548					=head2 delete($table, \%where)
549
550					This takes a table name and optional hashref WHERE clause.
551					It returns an SQL DELETE statement and list of bind values.
552
553					=cut
554
555					sub delete {
556					my $self = shift;
557					my $table = $self->_table(shift);
558					my $where = shift;
559
560					my $sql = $self->_sqlcase('delete from') . " $table";
561					my(@sqlf, @sqlv) = ();
562
563					if ($where) {
564					my($wsql, @wval) = $self->where($where);
565					$sql .= $wsql;
566					push @sqlv, @wval;
567					}
568
569					return wantarray ? ($sql, @sqlv) : $sql;
570					}
571
572					=head2 where(\%where, \@order)
573
574					This is used to generate just the WHERE clause. For example,
575					if you have an arbitrary data structure and know what the
576					rest of your SQL is going to look like, but want an easy way
577					to produce a WHERE clause, use this. It returns an SQL WHERE
578					clause and list of bind values.
579
580					=cut
581
582					# Finally, a separate routine just to handle WHERE clauses
583					sub where {
584					my $self = shift;
585					my $where = shift;
586					my $order = shift;
587
588					# Need a separate routine to properly wrap w/ "where"
589					my $sql = '';
590					my @ret = $self->_recurse_where($where);
591					if (@ret) {
592					my $wh = shift @ret;
593					$sql .= $self->_sqlcase(' where ') . $wh if $wh;
594					}
595
596					# order by?
597					if ($order) {
598					$sql .= $self->_order_by($order);
599					}
600
601					return wantarray ? ($sql, @ret) : $sql;
602					}
603
604
605					sub _recurse_where {
606					local $^W = 0; # really, you've gotta be fucking kidding me
607					my $self = shift;
608					my $where = _anoncopy(shift); # prevent destroying original
609					my $ref = ref $where \|\| '';
610					my $join = shift \|\| $self->{logic} \|\|
611					($ref eq 'ARRAY' ? $self->_sqlcase('or') : $self->_sqlcase('and'));
612
613					# For assembling SQL fields and values
614					my(@sqlf, @sqlv) = ();
615
616					# If an arrayref, then we join each element
617					if ($ref eq 'ARRAY') {
618					# need to use while() so can shift() for arrays
619					my $subjoin;
620					while (my $el = shift @$where) {
621
622					# skip empty elements, otherwise get invalid trailing AND stuff
623					if (my $ref2 = ref $el) {
624					if ($ref2 eq 'ARRAY') {
625					next unless @$el;
626					} elsif ($ref2 eq 'HASH') {
627					next unless %$el;
628					$subjoin \|\|= $self->_sqlcase('and');
629					} elsif ($ref2 eq 'SCALAR') {
630					# literal SQL
631					push @sqlf, $$el;
632					next;
633					}
634					$self->_debug("$ref2(*top) means join with $subjoin");
635					} else {
636					# top-level arrayref with scalars, recurse in pairs
637					$self->_debug("NOREF(*top) means join with $subjoin");
638					$el = {$el => shift(@$where)};
639					}
640					my @ret = $self->_recurse_where($el, $subjoin);
641					push @sqlf, shift @ret;
642					push @sqlv, @ret;
643					}
644					}
645					elsif ($ref eq 'HASH') {
646					# Note: during recursion, the last element will always be a hashref,
647					# since it needs to point a column => value. So this be the end.
648					for my $k (sort keys %$where) {
649					my $v = $where->{$k};
650					my $label = $self->_quote($k);
651					if ($k =~ /^-(\D+)/) {
652					# special nesting, like -and, -or, -nest, so shift over
653					my $subjoin = $self->_modlogic($1);
654					$self->_debug("OP(-$1) means special logic ($subjoin), recursing...");
655					my @ret = $self->_recurse_where($v, $subjoin);
656					push @sqlf, shift @ret;
657					push @sqlv, @ret;
658					} elsif (! defined($v)) {
659					# undef = null
660					$self->_debug("UNDEF($k) means IS NULL");
661					push @sqlf, $label . $self->_sqlcase(' is null');
662					} elsif (ref $v eq 'ARRAY') {
663					my @v = @$v;
664
665					# multiple elements: multiple options
666					$self->_debug("ARRAY($k) means multiple elements: [ @v ]");
667
668					# special nesting, like -and, -or, -nest, so shift over
669					my $subjoin = $self->_sqlcase('or');
670					if ($v[0] =~ /^-(\D+)/) {
671					$subjoin = $self->_modlogic($1); # override subjoin
672					$self->_debug("OP(-$1) means special logic ($subjoin), shifting...");
673					shift @v;
674					}
675
676					# map into an array of hashrefs and recurse
677					my @ret = $self->_recurse_where([map { {$k => $_} } @v], $subjoin);
678
679					# push results into our structure
680					push @sqlf, shift @ret;
681					push @sqlv, @ret;
682					} elsif (ref $v eq 'HASH') {
683					# modified operator { '!=', 'completed' }
684					for my $f (sort keys %$v) {
685					my $x = $v->{$f};
686					$self->_debug("HASH($k) means modified operator: { $f }");
687
688					# check for the operator being "IN" or "BETWEEN" or whatever
689					if (ref $x eq 'ARRAY') {
690					if ($f =~ /^-?\s(not[\s_]+)?(in\|between)\s$/i) {
691					my $u = $self->_modlogic($1 . $2);
692					$self->_debug("HASH($f => $x) uses special operator: [ $u ]");
693					if ($u =~ /between/i) {
694					# SQL sucks
695					push @sqlf, join ' ', $self->_convert($label), $u, $self->_convert('?'),
696					$self->_sqlcase('and'), $self->_convert('?');
697					} else {
698					push @sqlf, join ' ', $self->_convert($label), $u, '(',
699					join(', ', map { $self->_convert('?') } @$x),
700					')';
701					}
702					push @sqlv, $self->_bindtype($k, @$x);
703					} else {
704					# multiple elements: multiple options
705					$self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
706
707					# map into an array of hashrefs and recurse
708					my @ret = $self->_recurse_where([map { {$k => {$f, $_}} } @$x]);
709
710					# push results into our structure
711					push @sqlf, shift @ret;
712					push @sqlv, @ret;
713					}
714					} elsif (! defined($x)) {
715					# undef = NOT null
716					my $not = ($f eq '!=' \|\| $f eq 'not like') ? ' not' : '';
717					push @sqlf, $label . $self->_sqlcase(" is$not null");
718					} else {
719					# regular ol' value
720					$f =~ s/^-//; # strip leading -like =>
721					$f =~ s/_/ /; # _ => " "
722					push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($f), $self->_convert('?');
723					push @sqlv, $self->_bindtype($k, $x);
724					}
725					}
726					} elsif (ref $v eq 'SCALAR') {
727					# literal SQL
728					$self->_debug("SCALAR($k) means literal SQL: $$v");
729					push @sqlf, "$label $$v";
730					} else {
731					# standard key => val
732					$self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
733					push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($self->{cmp}), $self->_convert('?');
734					push @sqlv, $self->_bindtype($k, $v);
735					}
736					}
737					}
738					elsif ($ref eq 'SCALAR') {
739					# literal sql
740					$self->_debug("SCALAR(*top) means literal SQL: $$where");
741					push @sqlf, $$where;
742					}
743					elsif (defined $where) {
744					# literal sql
745					$self->_debug("NOREF(*top) means literal SQL: $where");
746					push @sqlf, $where;
747					}
748
749					# assemble and return sql
750					my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '';
751					return wantarray ? ($wsql, @sqlv) : $wsql;
752					}
753
754					sub _order_by {
755					my $self = shift;
756					my $ref = ref $_[0];
757
758					my @vals = $ref eq 'ARRAY' ? @{$_[0]} :
759					$ref eq 'SCALAR' ? ${$_[0]} :
760					$ref eq '' ? $_[0] :
761					puke "Unsupported data struct $ref for ORDER BY";
762
763					my $val = join ', ', map { $self->_quote($_) } @vals;
764					return $val ? $self->_sqlcase(' order by')." $val" : '';
765					}
766
767					=head2 values(\%data)
768
769					This just returns the values from the hash C<%data>, in the same
770					order that would be returned from any of the other above queries.
771					Using this allows you to markedly speed up your queries if you
772					are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
773
774					=cut
775
776					sub values {
777					my $self = shift;
778					my $data = shift \|\| return;
779					puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
780					unless ref $data eq 'HASH';
781					return map { $self->_bindtype($_, $data->{$_}) } sort keys %$data;
782					}
783
784					=head2 generate($any, 'number', $of, \@data, $struct, \%types)
785
786					Warning: This is an experimental method and subject to change.
787
788					This returns arbitrarily generated SQL. It's a really basic shortcut.
789					It will return two different things, depending on return context:
790
791					my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
792					my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
793
794					These would return the following:
795
796					# First calling form
797					$stmt = "CREATE TABLE test (?, ?)";
798					@bind = (field1, field2);
799
800					# Second calling form
801					$stmt_and_val = "CREATE TABLE test (field1, field2)";
802
803					Depending on what you're trying to do, it's up to you to choose the correct
804					format. In this example, the second form is what you would want.
805
806					By the same token:
807
808					$sql->generate('alter session', { nls_date_format => 'MM/YY' });
809
810					Might give you:
811
812					ALTER SESSION SET nls_date_format = 'MM/YY'
813
814					You get the idea. Strings get their case twiddled, but everything
815					else remains verbatim.
816
817					=cut
818
819					sub generate {
820					my $self = shift;
821
822					my(@sql, @sqlq, @sqlv);
823
824					for (@_) {
825					my $ref = ref $_;
826					if ($ref eq 'HASH') {
827					for my $k (sort keys %$_) {
828					my $v = $_->{$k};
829					my $r = ref $v;
830					my $label = $self->_quote($k);
831					if ($r eq 'ARRAY') {
832					# SQL included for values
833					my @bind = @$v;
834					my $sql = shift @bind;
835					push @sqlq, "$label = $sql";
836					push @sqlv, $self->_bindtype($k, @bind);
837					} elsif ($r eq 'SCALAR') {
838					# embedded literal SQL
839					push @sqlq, "$label = $$v";
840					} else {
841					push @sqlq, "$label = ?";
842					push @sqlv, $self->_bindtype($k, $v);
843					}
844					}
845					push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
846					} elsif ($ref eq 'ARRAY') {
847					# unlike insert(), assume these are ONLY the column names, i.e. for SQL
848					for my $v (@$_) {
849					my $r = ref $v;
850					if ($r eq 'ARRAY') {
851					my @val = @$v;
852					push @sqlq, shift @val;
853					push @sqlv, @val;
854					} elsif ($r eq 'SCALAR') {
855					# embedded literal SQL
856					push @sqlq, $$v;
857					} else {
858					push @sqlq, '?';
859					push @sqlv, $v;
860					}
861					}
862					push @sql, '(' . join(', ', @sqlq) . ')';
863					} elsif ($ref eq 'SCALAR') {
864					# literal SQL
865					push @sql, $$_;
866					} else {
867					# strings get case twiddled
868					push @sql, $self->_sqlcase($_);
869					}
870					}
871
872					my $sql = join ' ', @sql;
873
874					# this is pretty tricky
875					# if ask for an array, return ($stmt, @bind)
876					# otherwise, s/?/shift @sqlv/ to put it inline
877					if (wantarray) {
878					return ($sql, @sqlv);
879					} else {
880					1 while $sql =~ s/\?/my $d = shift(@sqlv);
881					ref $d ? $d->[1] : $d/e;
882					return $sql;
883					}
884					}
885
886					sub DESTROY { 1 }
887					sub AUTOLOAD {
888					# This allows us to check for a local, then _form, attr
889					my $self = shift;
890					my($name) = $AUTOLOAD =~ /.*::(.+)/;
891					return $self->generate($name, @_);
892					}
893
894	1	15µs			1;
895
896					__END__
897
898					=head1 WHERE CLAUSES
899
900					This module uses a variation on the idea from L<DBIx::Abstract>. It
901					is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
902					module is that things in arrays are OR'ed, and things in hashes
903					are AND'ed.>
904
905					The easiest way to explain is to show lots of examples. After
906					each C<%where> hash shown, it is assumed you used:
907
908					my($stmt, @bind) = $sql->where(\%where);
909
910					However, note that the C<%where> hash can be used directly in any
911					of the other functions as well, as described above.
912
913					So, let's get started. To begin, a simple hash:
914
915					my %where = (
916					user => 'nwiger',
917					status => 'completed'
918					);
919
920					Is converted to SQL C<key = val> statements:
921
922					$stmt = "WHERE user = ? AND status = ?";
923					@bind = ('nwiger', 'completed');
924
925					One common thing I end up doing is having a list of values that
926					a field can be in. To do this, simply specify a list inside of
927					an arrayref:
928
929					my %where = (
930					user => 'nwiger',
931					status => ['assigned', 'in-progress', 'pending'];
932					);
933
934					This simple code will create the following:
935
936					$stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
937					@bind = ('nwiger', 'assigned', 'in-progress', 'pending');
938
939					If you want to specify a different type of operator for your comparison,
940					you can use a hashref for a given column:
941
942					my %where = (
943					user => 'nwiger',
944					status => { '!=', 'completed' }
945					);
946
947					Which would generate:
948
949					$stmt = "WHERE user = ? AND status != ?";
950					@bind = ('nwiger', 'completed');
951
952					To test against multiple values, just enclose the values in an arrayref:
953
954					status => { '!=', ['assigned', 'in-progress', 'pending'] };
955
956					Which would give you:
957
958					"WHERE status != ? OR status != ? OR status != ?"
959
960					But, this is probably not what you want in this case (look at it). So
961					the hashref can also contain multiple pairs, in which case it is expanded
962					into an C<AND> of its elements:
963
964					my %where = (
965					user => 'nwiger',
966					status => { '!=', 'completed', -not_like => 'pending%' }
967					);
968
969					# Or more dynamically, like from a form
970					$where{user} = 'nwiger';
971					$where{status}{'!='} = 'completed';
972					$where{status}{'-not_like'} = 'pending%';
973
974					# Both generate this
975					$stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
976					@bind = ('nwiger', 'completed', 'pending%');
977
978					To get an OR instead, you can combine it with the arrayref idea:
979
980					my %where => (
981					user => 'nwiger',
982					priority => [ {'=', 2}, {'!=', 1} ]
983					);
984
985					Which would generate:
986
987					$stmt = "WHERE user = ? AND priority = ? OR priority != ?";
988					@bind = ('nwiger', '2', '1');
989
990					However, there is a subtle trap if you want to say something like
991					this (notice the C<AND>):
992
993					WHERE priority != ? AND priority != ?
994
995					Because, in Perl you I<can't> do this:
996
997					priority => { '!=', 2, '!=', 1 }
998
999					As the second C<!=> key will obliterate the first. The solution
1000					is to use the special C<-modifier> form inside an arrayref:
1001
1002					priority => [ -and => {'!=', 2}, {'!=', 1} ]
1003
1004					Normally, these would be joined by C<OR>, but the modifier tells it
1005					to use C<AND> instead. (Hint: You can use this in conjunction with the
1006					C<logic> option to C<new()> in order to change the way your queries
1007					work by default.) B<Important:> Note that the C<-modifier> goes
1008					B<INSIDE> the arrayref, as an extra first element. This will
1009					B<NOT> do what you think it might:
1010
1011					priority => -and => [{'!=', 2}, {'!=', 1}] # WRONG!
1012
1013					Here is a quick list of equivalencies, since there is some overlap:
1014
1015					# Same
1016					status => {'!=', 'completed', 'not like', 'pending%' }
1017					status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}]
1018
1019					# Same
1020					status => {'=', ['assigned', 'in-progress']}
1021					status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
1022					status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
1023
1024					In addition to C<-and> and C<-or>, there is also a special C<-nest>
1025					operator which adds an additional set of parens, to create a subquery.
1026					For example, to get something like this:
1027
1028					$stmt = WHERE user = ? AND ( workhrs > ? OR geo = ? )
1029					@bind = ('nwiger', '20', 'ASIA');
1030
1031					You would do:
1032
1033					my %where = (
1034					user => 'nwiger',
1035					-nest => [ workhrs => {'>', 20}, geo => 'ASIA' ],
1036					);
1037
1038					You can also use the hashref format to compare a list of fields using the
1039					C<IN> comparison operator, by specifying the list as an arrayref:
1040
1041					my %where = (
1042					status => 'completed',
1043					reportid => { -in => [567, 2335, 2] }
1044					);
1045
1046					Which would generate:
1047
1048					$stmt = "WHERE status = ? AND reportid IN (?,?,?)";
1049					@bind = ('completed', '567', '2335', '2');
1050
1051					You can use this same format to use other grouping functions, such
1052					as C<BETWEEN>, C<SOME>, and so forth. For example:
1053
1054					my %where = (
1055					user => 'nwiger',
1056					completion_date => {
1057					-not_between => ['2002-10-01', '2003-02-06']
1058					}
1059					);
1060
1061					Would give you:
1062
1063					WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
1064
1065					So far, we've seen how multiple conditions are joined with a top-level
1066					C<AND>. We can change this by putting the different conditions we want in
1067					hashes and then putting those hashes in an array. For example:
1068
1069					my @where = (
1070					{
1071					user => 'nwiger',
1072					status => { -like => ['pending%', 'dispatched'] },
1073					},
1074					{
1075					user => 'robot',
1076					status => 'unassigned',
1077					}
1078					);
1079
1080					This data structure would create the following:
1081
1082					$stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) )
1083					OR ( user = ? AND status = ? ) )";
1084					@bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
1085
1086					This can be combined with the C<-nest> operator to properly group
1087					SQL statements:
1088
1089					my @where = (
1090					-and => [
1091					user => 'nwiger',
1092					-nest => [
1093					-and => [workhrs => {'>', 20}, geo => 'ASIA' ],
1094					-and => [workhrs => {'<', 50}, geo => 'EURO' ]
1095					],
1096					],
1097					);
1098
1099					That would yield:
1100
1101					WHERE ( user = ? AND
1102					( ( workhrs > ? AND geo = ? )
1103					OR ( workhrs < ? AND geo = ? ) ) )
1104
1105					Finally, sometimes only literal SQL will do. If you want to include
1106					literal SQL verbatim, you can specify it as a scalar reference, namely:
1107
1108					my $inn = 'is Not Null';
1109					my %where = (
1110					priority => { '<', 2 },
1111					requestor => \$inn
1112					);
1113
1114					This would create:
1115
1116					$stmt = "WHERE priority < ? AND requestor is Not Null";
1117					@bind = ('2');
1118
1119					Note that in this example, you only get one bind parameter back, since
1120					the verbatim SQL is passed as part of the statement.
1121
1122					Of course, just to prove a point, the above can also be accomplished
1123					with this:
1124
1125					my %where = (
1126					priority => { '<', 2 },
1127					requestor => { '!=', undef },
1128					);
1129
1130					TMTOWTDI.
1131
1132					These pages could go on for a while, since the nesting of the data
1133					structures this module can handle are pretty much unlimited (the
1134					module implements the C<WHERE> expansion as a recursive function
1135					internally). Your best bet is to "play around" with the module a
1136					little to see how the data structures behave, and choose the best
1137					format for your data based on that.
1138
1139					And of course, all the values above will probably be replaced with
1140					variables gotten from forms or the command line. After all, if you
1141					knew everything ahead of time, you wouldn't have to worry about
1142					dynamically-generating SQL and could just hardwire it into your
1143					script.
1144
1145					=head1 PERFORMANCE
1146
1147					Thanks to some benchmarking by Mark Stosberg, it turns out that
1148					this module is many orders of magnitude faster than using C<DBIx::Abstract>.
1149					I must admit this wasn't an intentional design issue, but it's a
1150					byproduct of the fact that you get to control your C<DBI> handles
1151					yourself.
1152
1153					To maximize performance, use a code snippet like the following:
1154
1155					# prepare a statement handle using the first row
1156					# and then reuse it for the rest of the rows
1157					my($sth, $stmt);
1158					for my $href (@array_of_hashrefs) {
1159					$stmt \|\|= $sql->insert('table', $href);
1160					$sth \|\|= $dbh->prepare($stmt);
1161					$sth->execute($sql->values($href));
1162					}
1163
1164					The reason this works is because the keys in your C<$href> are sorted
1165					internally by B<SQL::Abstract>. Thus, as long as your data retains
1166					the same structure, you only have to generate the SQL the first time
1167					around. On subsequent queries, simply use the C<values> function provided
1168					by this module to return your values in the correct order.
1169
1170					=head1 FORMBUILDER
1171
1172					If you use my C<CGI::FormBuilder> module at all, you'll hopefully
1173					really like this part (I do, at least). Building up a complex query
1174					can be as simple as the following:
1175
1176					#!/usr/bin/perl
1177
1178					use CGI::FormBuilder;
1179					use SQL::Abstract;
1180
1181					my $form = CGI::FormBuilder->new(...);
1182					my $sql = SQL::Abstract->new;
1183
1184					if ($form->submitted) {
1185					my $field = $form->field;
1186					my $id = delete $field->{id};
1187					my($stmt, @bind) = $sql->update('table', $field, {id => $id});
1188					}
1189
1190					Of course, you would still have to connect using C<DBI> to run the
1191					query, but the point is that if you make your form look like your
1192					table, the actual query script can be extremely simplistic.
1193
1194					If you're B<REALLY> lazy (I am), check out C<HTML::QuickTable> for
1195					a fast interface to returning and formatting data. I frequently
1196					use these three modules together to write complex database query
1197					apps in under 50 lines.
1198
1199					=head1 NOTES
1200
1201					There is not (yet) any explicit support for SQL compound logic
1202					statements like "AND NOT". Instead, just do the de Morgan's
1203					law transformations yourself. For example, this:
1204
1205					"lname LIKE '%son%' AND NOT ( age < 10 OR age > 20 )"
1206
1207					Becomes:
1208
1209					"lname LIKE '%son%' AND ( age >= 10 AND age <= 20 )"
1210
1211					With the corresponding C<%where> hash:
1212
1213					%where = (
1214					lname => {like => '%son%'},
1215					age => [-and => {'>=', 10}, {'<=', 20}],
1216					);
1217
1218					Again, remember that the C<-and> goes I<inside> the arrayref.
1219
1220					=head1 ACKNOWLEDGEMENTS
1221
1222					There are a number of individuals that have really helped out with
1223					this module. Unfortunately, most of them submitted bugs via CPAN
1224					so I have no idea who they are! But the people I do know are:
1225
1226					Mark Stosberg (benchmarking)
1227					Chas Owens (initial "IN" operator support)
1228					Philip Collins (per-field SQL functions)
1229					Eric Kolve (hashref "AND" support)
1230					Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
1231					Dan Kubb (support for "quote_char" and "name_sep")
1232					Matt Trout (DBIx::Class support)
1233
1234					Thanks!
1235
1236					=head1 BUGS
1237
1238					If found, please DO NOT submit anything via C<rt.cpan.org> - that
1239					just causes me a ton of work. Email me a patch (or script demonstrating
1240					the problem) to the below address, and include the VERSION you're using.
1241
1242					=head1 SEE ALSO
1243
1244					L<DBIx::Abstract>, L<DBI\|DBI>, L<CGI::FormBuilder>, L<HTML::QuickTable>
1245
1246					=head1 AUTHOR
1247
1248					Copyright (c) 2001-2006 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
1249
1250					For support, your best bet is to try the C<DBIx::Class> users mailing list.
1251					While not an official support venue, C<DBIx::Class> makes heavy use of
1252					C<SQL::Abstract>, and as such list members there are very familiar with
1253					how to create queries.
1254
1255					This module is free software; you may copy this under the terms of
1256					the GNU General Public License, or the Artistic License, copies of
1257					which should have accompanied your Perl kit.
1258
1259					=cut
1260