lib/DBIx/Class/SQL/Abstract.pm

   1 package DBIx::Class::SQL::Abstract;
   2
   3 # Many thanks to SQL::Abstract, from which I stole most of this
   4
   5 sub _debug { }
   6
   7 sub _cond_resolve {
   8   my ($self, $cond, $attrs, $join) = @_;
   9   my $ref   = ref $cond || '';
  10   $join   ||= $attrs->{logic} || ($ref eq 'ARRAY' ? 'OR' : 'AND');
  11   my $cmp   = uc($attrs->{cmp}) || '=';
  12
  13   # For assembling SQL fields and values
  14   my(@sqlf) = ();
  15
  16   # If an arrayref, then we join each element
  17   if ($ref eq 'ARRAY') {
  18     # need to use while() so can shift() for arrays
  19     while (my $el = shift @$cond) {
  20       my $subjoin = 'OR';
  21
  22       # skip empty elements, otherwise get invalid trailing AND stuff
  23       if (my $ref2 = ref $el) {
  24         if ($ref2 eq 'ARRAY') {
  25           next unless @$el;
  26         } elsif ($ref2 eq 'HASH') {
  27           next unless %$el;
  28           $subjoin = 'AND';
  29         } elsif ($ref2 eq 'SCALAR') {
  30           # literal SQL
  31           push @sqlf, $$el;
  32           next;
  33         }
  34         $self->_debug("$ref2(*top) means join with $subjoin");
  35       } else {
  36         # top-level arrayref with scalars, recurse in pairs
  37         $self->_debug("NOREF(*top) means join with $subjoin");
  38         $el = {$el => shift(@$cond)};
  39       }
  40       push @sqlf, scalar $self->_cond_resolve($el, $attrs, $subjoin);
  41     }
  42   }
  43   elsif ($ref eq 'HASH') {
  44     # Note: during recursion, the last element will always be a hashref,
  45     # since it needs to point a column => value. So this be the end.
  46     for my $k (sort keys %$cond) {
  47       my $v = $cond->{$k};
  48       if (! defined($v)) {
  49         # undef = null
  50         $self->_debug("UNDEF($k) means IS NULL");
  51         push @sqlf, $k . ' IS NULL'
  52       } elsif (ref $v eq 'ARRAY') {
  53         # multiple elements: multiple options
  54         $self->_debug("ARRAY($k) means multiple elements: [ @$v ]");
  55
  56         # map into an array of hashrefs and recurse
  57         my @w = ();
  58         push @w, { $k => $_ } for @$v;
  59         push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR');
  60
  61       } elsif (ref $v eq 'HASH') {
  62         # modified operator { '!=', 'completed' }
  63         for my $f (sort keys %$v) {
  64           my $x = $v->{$f};
  65           $self->_debug("HASH($k) means modified operator: { $f }");
  66
  67           # check for the operator being "IN" or "BETWEEN" or whatever
  68           if ($f =~ /^([\s\w]+)$/i && ref $x eq 'ARRAY') {
  69             my $u = uc($1);
  70             if ($u =~ /BETWEEN/) {
  71               # SQL sucks
  72               die "BETWEEN must have exactly two arguments" unless @$x == 2;
  73               push @sqlf, join ' ',
  74                             $self->_cond_key($attrs => $k), $u,
  75                             $self->_cond_value($attrs => $k => $x->[0]),
  76                             'AND',
  77                             $self->_cond_value($attrs => $k => $x->[1]);
  78             } else {
  79               push @sqlf, join ' ', $self->_cond_key($attrs, $k), $u, '(',
  80                       join(', ',
  81                         map { $self->_cond_value($attrs, $k, $_) } @$x),
  82                     ')';
  83             }
  84           } elsif (ref $x eq 'ARRAY') {
  85             # multiple elements: multiple options
  86             $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
  87
  88             # map into an array of hashrefs and recurse
  89             my @w = ();
  90             push @w, { $k => { $f => $_ } } for @$x;
  91             push @sqlf, scalar $self->_cond_resolve(\@w, $attrs, 'OR');
  92
  93           } elsif (! defined($x)) {
  94             # undef = NOT null
  95             my $not = ($f eq '!=' || $f eq 'not like') ? ' NOT' : '';
  96             push @sqlf, $self->_cond_key($attrs => $k) . " IS${not} NULL";
  97           } else {
  98             # regular ol' value
  99             push @sqlf, join ' ', $self->_cond_key($attrs => $k), $f,
 100                           $self->_cond_value($attrs => $k => $x);
 101           }
 102         }
 103       } elsif (ref $v eq 'SCALAR') {
 104         # literal SQL
 105         $self->_debug("SCALAR($k) means literal SQL: $$v");
 106         push @sqlf, join ' ', $self->_cond_key($attrs => $k), $$v;
 107       } else {
 108         # standard key => val
 109         $self->_debug("NOREF($k) means simple key=val: $k ${cmp} $v");
 110         push @sqlf, join ' ', $self->_cond_key($attrs => $k), $cmp,
 111                       $self->_cond_value($attrs => $k => $v);
 112       }
 113     }
 114   }
 115   elsif ($ref eq 'SCALAR') {
 116     # literal sql
 117     $self->_debug("SCALAR(*top) means literal SQL: $$cond");
 118     push @sqlf, $$cond;
 119   }
 120   elsif (defined $cond) {
 121     # literal sql
 122     $self->_debug("NOREF(*top) means literal SQL: $cond");
 123     push @sqlf, $cond;
 124   }
 125
 126   # assemble and return sql
 127   my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '';
 128   return wantarray ? ($wsql, @{$attrs->{bind} || []}) : $wsql;
 129 }
 130
 131 sub _cond_key {
 132   my ($self, $attrs, $key) = @_;
 133   return $key;
 134 }
 135
 136 sub _cond_value {
 137   my ($self, $attrs, $key, $value) = @_;
 138   push(@{$attrs->{bind}}, $value);
 139   return '?';
 140 }
 141
 142 1;