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