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