-
package SQL::Abstract;
=head1 NAME
$sth->execute(@bind);
# Just generate the WHERE clause
- my($stmt, @bind) = $sql->where(\%where, \@order);
+ my($stmt, @bind) = $sql->where(\%where, \@order);
# Return values in the same order, for hashed queries
# See PERFORMANCE section for more details
use Carp;
use strict;
-our $VERSION = do { my @r=(q$Revision: 1.21 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
+our $VERSION = '1.23';
+#XXX don't understand this below, leaving it for someone else. did bump the $VERSION --groditi
+our $REVISION = '$Id$';
our $AUTOLOAD;
# Fix SQL case, if so requested
# Utility functions
sub _table {
my $self = shift;
- my $tab = shift;
- if (ref $tab eq 'ARRAY') {
- return join ', ', map { $self->_quote($_) } @$tab;
+ my $from = shift;
+ if (ref $from eq 'ARRAY') {
+ return $self->_recurse_from(@$from);
+ } elsif (ref $from eq 'HASH') {
+ return $self->_make_as($from);
+ } else {
+ return $self->_quote($from);
+ }
+}
+
+sub _recurse_from {
+ my ($self, $from, @join) = @_;
+ my @sqlf;
+ push(@sqlf, $self->_make_as($from));
+ foreach my $j (@join) {
+ push @sqlf, ', ' . $self->_quote($j) and next unless ref $j;
+ push @sqlf, ', ' . $$j and next if ref $j eq 'SCALAR';
+ my ($to, $on) = @$j;
+
+ # check whether a join type exists
+ my $join_clause = '';
+ my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
+ if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
+ $join_clause = $self->_sqlcase(' '.($to_jt->{-join_type}).' JOIN ');
+ } else {
+ $join_clause = $self->_sqlcase(' JOIN ');
+ }
+ push(@sqlf, $join_clause);
+
+ if (ref $to eq 'ARRAY') {
+ push(@sqlf, '(', $self->_recurse_from(@$to), ')');
+ } else {
+ push(@sqlf, $self->_make_as($to));
+ }
+ push(@sqlf, $self->_sqlcase(' ON '), $self->_join_condition($on));
+ }
+ return join('', @sqlf);
+}
+
+sub _make_as {
+ my ($self, $from) = @_;
+ return $self->_quote($from) unless ref $from;
+ return $$from if ref $from eq 'SCALAR';
+ return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
+ reverse each %{$self->_skip_options($from)});
+}
+
+sub _skip_options {
+ my ($self, $hash) = @_;
+ my $clean_hash = {};
+ $clean_hash->{$_} = $hash->{$_}
+ for grep {!/^-/} keys %$hash;
+ return $clean_hash;
+}
+
+sub _join_condition {
+ my ($self, $cond) = @_;
+ if (ref $cond eq 'HASH') {
+ my %j;
+ for (keys %$cond) {
+ my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
+ };
+ return $self->_recurse_where(\%j);
+ } elsif (ref $cond eq 'ARRAY') {
+ return join(' OR ', map { $self->_join_condition($_) } @$cond);
} else {
- return $self->_quote($tab);
+ die "Can't handle this yet!";
}
}
+
sub _quote {
my $self = shift;
my $label = shift;
+ return '' unless defined $label;
+
return $label
if $label eq '*';
+ return $$label if ref($label) eq 'SCALAR';
+
+ return $label unless $self->{quote_char};
+
+ if (ref $self->{quote_char} eq "ARRAY") {
+
+ return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
+ if !defined $self->{name_sep};
+
+ my $sep = $self->{name_sep};
+ return join($self->{name_sep},
+ map { $_ eq '*'
+ ? $_
+ : $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
+ split( /\Q$sep\E/, $label ) );
+ }
+
+
return $self->{quote_char} . $label . $self->{quote_char}
if !defined $self->{name_sep};
return join $self->{name_sep},
- map { $self->{quote_char} . $_ . $self->{quote_char} }
+ map { $_ eq '*' ? $_ : $self->{quote_char} . $_ . $self->{quote_char} }
split /\Q$self->{name_sep}\E/, $label;
}
=head2 update($table, \%fieldvals, \%where)
This takes a table, hashref of field/value pairs, and an optional
-hashref WHERE clause. It returns an SQL UPDATE function and a list
+hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
of bind values.
=cut
=head2 select($table, \@fields, \%where, \@order)
This takes a table, arrayref of fields (or '*'), optional hashref
-WHERE clause, and optional arrayref order by, and returns the
+L<WHERE clause|/WHERE CLAUSES>, and optional array or hash ref L<ORDER BY clause|/ORDER BY CLAUSES>, and returns the
corresponding SQL SELECT statement and list of bind values.
=cut
=head2 delete($table, \%where)
-This takes a table name and optional hashref WHERE clause.
+This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
It returns an SQL DELETE statement and list of bind values.
=cut
for my $k (sort keys %$where) {
my $v = $where->{$k};
my $label = $self->_quote($k);
+
if ($k =~ /^-(\D+)/) {
# special nesting, like -and, -or, -nest, so shift over
my $subjoin = $self->_modlogic($1);
# modified operator { '!=', 'completed' }
for my $f (sort keys %$v) {
my $x = $v->{$f};
+
+ # do the right thing for single -in values
+ $x = [$x] if ($f =~ /^-?\s*(not[\s_]+)?in\s*$/i && ref $x ne 'ARRAY');
+
$self->_debug("HASH($k) means modified operator: { $f }");
# check for the operator being "IN" or "BETWEEN" or whatever
$self->_debug("HASH($f => $x) uses special operator: [ $u ]");
if ($u =~ /between/i) {
# SQL sucks
+ # Throw an exception if you try to use between with
+ # anything other than 2 values
+ $self->puke("You need two values to use between") unless @$x == 2;
push @sqlf, join ' ', $self->_convert($label), $u, $self->_convert('?'),
$self->_sqlcase('and'), $self->_convert('?');
- } else {
+ } elsif (@$x) {
+ # DWIM for empty arrayrefs
push @sqlf, join ' ', $self->_convert($label), $u, '(',
join(', ', map { $self->_convert('?') } @$x),
')';
+ } elsif(@$x == 0){
+ # Empty IN defaults to 0=1 and empty NOT IN to 1=1
+ push(@sqlf, ($u =~ /not/i ? "1=1" : "0=1"));
}
push @sqlv, $self->_bindtype($k, @$x);
} else {
sub _order_by {
my $self = shift;
- my $ref = ref $_[0];
-
- my @vals = $ref eq 'ARRAY' ? @{$_[0]} :
- $ref eq 'SCALAR' ? ${$_[0]} :
- $ref eq '' ? $_[0] :
- puke "Unsupported data struct $ref for ORDER BY";
+ my $ref = ref $_[0] || '';
+
+ my $_order_hash = sub {
+ local *__ANON__ = '_order_by_hash';
+ my ($col, $order);
+ my $hash = shift; # $_ was failing in some cases for me --groditi
+ if ( $col = $hash->{'-desc'} ) {
+ $order = 'DESC'
+ } elsif ( $col = $hash->{'-asc'} ) {
+ $order = 'ASC';
+ } else {
+ puke "Hash must have a key of '-desc' or '-asc' for ORDER BY";
+ }
+ return $self->_quote($col) . " $order";
+
+ };
+
+ my @vals;
+ if ($ref eq 'ARRAY') {
+ foreach (@{ $_[0] }) {
+ my $ref = ref $_;
+ if (!$ref || $ref eq 'SCALAR') {
+ push @vals, $self->_quote($_);
+ } elsif ($ref eq 'HASH') {
+ push @vals, $_order_hash->($_);
+ } else {
+ puke "Unsupported nested data struct $ref for ORDER BY";
+ }
+ }
+ } elsif ($ref eq 'HASH') {
+ push @vals, $_order_hash->($_[0]);
+ } elsif (!$ref || $ref eq 'SCALAR') {
+ push @vals, $self->_quote($_[0]);
+ } else {
+ puke "Unsupported data struct $ref for ORDER BY";
+ }
- my $val = join ', ', map { $self->_quote($_) } @vals;
+ my $val = join ', ', @vals;
return $val ? $self->_sqlcase(' order by')." $val" : '';
}
operator which adds an additional set of parens, to create a subquery.
For example, to get something like this:
- $stmt = WHERE user = ? AND ( workhrs > ? OR geo = ? )
+ $stmt = "WHERE user = ? AND ( workhrs > ? OR geo = ? )";
@bind = ('nwiger', '20', 'ASIA');
You would do:
dynamically-generating SQL and could just hardwire it into your
script.
+=head1 ORDER BY CLAUSES
+
+Some functions take an order by clause. This can either be a scalar (just a
+column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
+or an array of either of the two previous forms. Examples:
+
+ Given | Will Generate
+ ----------------------------------------------------------
+ \'colA DESC' | ORDER BY colA DESC
+ 'colA' | ORDER BY colA
+ [qw/colA colB/] | ORDER BY colA, colB
+ {-asc => 'colA'} | ORDER BY colA ASC
+ {-desc => 'colB'} | ORDER BY colB DESC
+ [ |
+ {-asc => 'colA'}, | ORDER BY colA ASC, colB DESC
+ {-desc => 'colB'} |
+ ] |
+ [colA => {-asc => 'colB'}] | ORDER BY colA, colB ASC
+ ==========================================================
+
=head1 PERFORMANCE
Thanks to some benchmarking by Mark Stosberg, it turns out that
this module. Unfortunately, most of them submitted bugs via CPAN
so I have no idea who they are! But the people I do know are:
+ Ash Berlin (order_by hash term support)
+ Matt Trout (DBIx::Class support)
Mark Stosberg (benchmarking)
Chas Owens (initial "IN" operator support)
Philip Collins (per-field SQL functions)
Eric Kolve (hashref "AND" support)
Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
Dan Kubb (support for "quote_char" and "name_sep")
+ Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
Thanks!
-=head1 BUGS
-
-If found, please DO NOT submit anything via C<rt.cpan.org> - that
-just causes me a ton of work. Email me a patch (or script demonstrating
-the problem) to the below address, and include the VERSION string you'll
-be seeing shortly.
-
=head1 SEE ALSO
-L<DBIx::Abstract>, L<DBI|DBI>, L<CGI::FormBuilder>, L<HTML::QuickTable>
+L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>.
-=head1 VERSION
+=head1 AUTHOR
-$Id: Abstract.pm,v 1.21 2006/03/08 01:27:56 nwiger Exp $
+Copyright (c) 2001-2007 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
-=head1 AUTHOR
+This module is actively maintained by Matt Trout <mst@shadowcatsystems.co.uk>
-Copyright (c) 2001-2006 Nathan Wiger <nate@wiger.org>. All Rights Reserved.
+For support, your best bet is to try the C<DBIx::Class> users mailing list.
+While not an official support venue, C<DBIx::Class> makes heavy use of
+C<SQL::Abstract>, and as such list members there are very familiar with
+how to create queries.
This module is free software; you may copy this under the terms of
the GNU General Public License, or the Artistic License, copies of
projects / scpubgit/Q-Branch.git / blobdiff