lib/DBIx/Class/SQL/Abstract.pm

   1 package DBIx::Class::SQL::Abstract;
   2
   3 use strict;
   4 use warnings;
   5
   6 # Many thanks to SQL::Abstract, from which I stole most of this
   7
   8 sub _debug { }
   9
  10 sub _cond_resolve {
  11   my ($self, $cond, $attrs, $join) = @_;
  12   $cond = $self->_anoncopy($cond);   # prevent destroying original
  13   my $ref   = ref $cond || '';
  14   $join   ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND');
  15   my $cmp   = uc($attrs->{cmp}) || '=';
  16
  17   # For assembling SQL fields and values
  18   my(@sqlf) = ();
  19
  20   # If an arrayref, then we join each element
  21   if ($ref eq 'ARRAY') {
  22     # need to use while() so can shift() for arrays
  23     my $subjoin;
  24     while (my $el = shift @$cond) {
  25
  26       # skip empty elements, otherwise get invalid trailing AND stuff
  27       if (my $ref2 = ref $el) {
  28         if ($ref2 eq 'ARRAY') {
  29           next unless @$el;
  30         } elsif ($ref2 eq 'HASH') {
  31           next unless %$el;
  32           $subjoin ||= 'AND';
  33         } elsif ($ref2 eq 'SCALAR') {
  34           # literal SQL
  35           push @sqlf, $$el;
  36           next;
  37         }
  38         $self->_debug("$ref2(*top) means join with $subjoin");
  39       } else {
  40         # top-level arrayref with scalars, recurse in pairs
  41         $self->_debug("NOREF(*top) means join with $subjoin") if $subjoin;
  42         $el = {$el => shift(@$cond)};
  43       }
  44       my @ret = $self->_cond_resolve($el, $attrs, $subjoin);
  45       push @sqlf, shift @ret;
  46     }
  47   }
  48   elsif ($ref eq 'HASH') {
  49     # Note: during recursion, the last element will always be a hashref,
  50     # since it needs to point a column => value. So this be the end.
  51     for my $k (sort keys %$cond) {
  52       my $v = $cond->{$k};
  53       if ($k =~ /^-(.*)/) {
  54         # special nesting, like -and, -or, -nest, so shift over
  55         my $subjoin = $self->_modlogic($attrs, uc($1));
  56         $self->_debug("OP(-$1) means special logic ($subjoin), recursing...");
  57         my @ret = $self->_cond_resolve($v, $attrs, $subjoin);
  58         push @sqlf, shift @ret;
  59       } elsif (! defined($v)) {
  60         # undef = null
  61         $self->_debug("UNDEF($k) means IS NULL");
  62         push @sqlf, $self->_cond_key($attrs => $k) . ' IS NULL'
  63       } elsif (ref $v eq 'ARRAY') {
  64         # multiple elements: multiple options
  65         # warnings... $self->_debug("ARRAY($k) means multiple elements: [ @$v ]");
  66
  67         # special nesting, like -and, -or, -nest, so shift over
  68         my $subjoin = 'OR';
  69         if ($v->[0] =~ /^-(.*)/) {
  70           $subjoin = $self->_modlogic($attrs, uc($1));    # override subjoin
  71           $self->_debug("OP(-$1) means special logic ($subjoin), shifting...");
  72           shift @$v;
  73         }
  74
  75         # map into an array of hashrefs and recurse
  76         my @ret = $self->_cond_resolve([map { {$k => $_} } @$v], $attrs, $subjoin);
  77
  78         # push results into our structure
  79         push @sqlf, shift @ret;
  80       } elsif (ref $v eq 'HASH') {
  81         # modified operator { '!=', 'completed' }
  82         for my $f (sort keys %$v) {
  83           my $x = $v->{$f};
  84           $self->_debug("HASH($k) means modified operator: { $f }");
  85
  86           # check for the operator being "IN" or "BETWEEN" or whatever
  87           if (ref $x eq 'ARRAY') {
  88             if ($f =~ /^-?\s*(not[\s_]+)?(in|between)\s*$/i) {
  89               my $mod = $1 ? $1 . $2 : $2;  # avoid uninitialized value warnings
  90               my $u = $self->_modlogic($attrs, uc($mod));
  91               $self->_debug("HASH($f => $x) uses special operator: [ $u ]");
  92               if ($u =~ /BETWEEN/) {
  93                 # SQL sucks
  94                 $self->throw( "BETWEEN must have exactly two arguments" ) unless @$x == 2;
  95                 push @sqlf, join ' ',
  96                               $self->_cond_key($attrs => $k), $u,
  97                               $self->_cond_value($attrs => $k => $x->[0]),
  98                               'AND',
  99                               $self->_cond_value($attrs => $k => $x->[1]);
 100               } else {
 101                 push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(',
 102                         join(', ',
 103                           map { $self->_cond_value($attrs, $k, $_) } @$x),
 104                       ')';
 105               }
 106             } else {
 107               # multiple elements: multiple options
 108               $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
 109
 110               # map into an array of hashrefs and recurse
 111               my @ret = $self->_cond_resolve([map { {$k => {$f, $_}} } @$x], $attrs);
 112
 113               # push results into our structure
 114               push @sqlf, shift @ret;
 115             }
 116           } elsif (! defined($x)) {
 117             # undef = NOT null
 118             my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : '';
 119             push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL";
 120           } else {
 121             # regular ol' value
 122             $f =~ s/^-//;   # strip leading -like =>
 123             $f =~ s/_/ /;   # _ => " "
 124             push @sqlf, join ' ', $self->_cond_key($attrs => $k), uc($f),
 125                           $self->_cond_value($attrs => $k => $x);
 126           }
 127         }
 128       } elsif (ref $v eq 'SCALAR') {
 129         # literal SQL
 130         $self->_debug("SCALAR($k) means literal SQL: $$v");
 131         push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v;
 132       } else {
 133         # standard key => val
 134         $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v");
 135         push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp,
 136                       $self->_cond_value($attrs => $k => $v);
 137       }
 138     }
 139   }
 140   elsif ($ref eq 'SCALAR') {
 141     # literal sql
 142     $self->_debug("SCALAR(*top) means literal SQL: $$cond");
 143     push @sqlf, $$cond;
 144   }
 145   elsif (defined $cond) {
 146     # literal sql
 147     $self->_debug("NOREF(*top) means literal SQL: $cond");
 148     push @sqlf, $cond;
 149   }
 150
 151   # assemble and return sql
 152   my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '1 = 1';
 153   return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql;
 154 }
 155
 156 sub _cond_key {
 157   my ($self, $attrs, $key) = @_;
 158   return $key;
 159 }
 160
 161 sub _cond_value {
 162   my ($self, $attrs, $key, $value) = @_;
 163   push(@{$attrs->{bind}}, $value);
 164   return '?';
 165 }
 166
 167 # Anon copies of arrays/hashes
 168 sub _anoncopy {
 169   my ($self, $orig) = @_;
 170   return (ref $orig eq 'HASH' ) ? { %$orig }
 171      : (ref $orig eq 'ARRAY') ? [ @$orig ]
 172      : $orig;     # rest passthru ok
 173 }
 174
 175 sub _modlogic {
 176   my ($self, $attrs, $sym) = @_;
 177   $sym ||= $attrs->{logic};
 178   $sym =~ tr/_/ /;
 179   $sym = $attrs->{logic} if $sym eq 'nest';
 180   return uc($sym);  # override join
 181 }
 182
 183 1;
 184
 185 =head1 NAME
 186
 187 DBIx::Class::SQL::Abstract - SQL::Abstract customized for DBIC.
 188
 189 =head1 SYNOPSIS
 190
 191 =head1 DESCRIPTION
 192
 193 This is a customized version of L<SQL::Abstract> for use in
 194 generating L<DBIx::Searchbuilder> searches.
 195
 196 =cut
 197
 198 =head1 AUTHORS
 199
 200 Matt S. Trout <perl-stuff@trout.me.uk>
 201
 202 =head1 LICENSE
 203
 204 You may distribute this code under the same terms as Perl itself.
 205
 206 =cut