lib/DBIx/Class/SQLMaker/Converter.pm

   1 package DBIx::Class::SQLMaker::Converter;
   2
   3 use Data::Query::Constants qw(DQ_ALIAS DQ_GROUP DQ_WHERE DQ_JOIN DQ_SLICE);
   4 use Moo;
   5 use namespace::clean;
   6
   7 extends 'SQL::Abstract::Converter';
   8
   9 around _select_to_dq => sub {
  10   my ($orig, $self) = (shift, shift);
  11   my $attrs = $_[4];
  12   my $orig_dq = $self->$orig(@_);
  13   return $orig_dq unless $attrs->{limit};
  14   +{
  15     type => DQ_SLICE,
  16     from => $orig_dq,
  17     limit => do {
  18       local $SQL::Abstract::Converter::Cur_Col_Meta
  19         = { sqlt_datatype => 'integer' };
  20       $self->_value_to_dq($attrs->{limit})
  21     },
  22     ($attrs->{offset}
  23       ? (offset => do {
  24           local $SQL::Abstract::Converter::Cur_Col_Meta
  25             = { sqlt_datatype => 'integer' };
  26           $self->_value_to_dq($attrs->{offset})
  27         })
  28       : ()
  29     ),
  30     ($attrs->{order_is_stable}
  31       ? (order_is_stable => 1)
  32       : ()),
  33     ($attrs->{preserve_order}
  34       ? (preserve_order => 1)
  35       : ())
  36   };
  37 };
  38
  39 around _select_field_to_dq => sub {
  40   my ($orig, $self) = (shift, shift);
  41   my ($field) = @_;
  42   my $ref = ref $field;
  43   if ($ref eq 'HASH') {
  44     my %hash = %$field;  # shallow copy
  45
  46     my $as = delete $hash{-as};   # if supplied
  47
  48     my ($func, $args, @toomany) = %hash;
  49
  50     # there should be only one pair
  51     if (@toomany) {
  52       die( "Malformed select argument - too many keys in hash: " . join (',', keys %$field ) );
  53     }
  54
  55     if (lc ($func) eq 'distinct' && ref $args eq 'ARRAY' && @$args > 1) {
  56       die(
  57         'The select => { distinct => ... } syntax is not supported for multiple columns.'
  58        .' Instead please use { group_by => [ qw/' . (join ' ', @$args) . '/ ] }'
  59        .' or { select => [ qw/' . (join ' ', @$args) . '/ ], distinct => 1 }'
  60       );
  61     }
  62
  63     my $field_dq = do {
  64       if ($func) {
  65         $self->_op_to_dq(
  66           apply => $self->_ident_to_dq(uc($func)),
  67           @{$self->_select_field_list_to_dq($args)},
  68         );
  69       } else {
  70         $self->_select_field_to_dq($args);
  71       }
  72     };
  73
  74     return $field_dq unless $as;
  75
  76     return +{
  77       type => DQ_ALIAS,
  78       from => $field_dq,
  79       to => $as
  80     };
  81   } else {
  82     return $self->$orig(@_);
  83   }
  84 };
  85
  86 around _source_to_dq => sub {
  87   my ($orig, $self) = (shift, shift);
  88   my $attrs = $_[4]; # table, fields, where, order, attrs
  89   my $start_dq = $self->$orig(@_);
  90   # if we have HAVING but no GROUP BY we render an empty DQ_GROUP
  91   # node, which causes DQ to recognise the HAVING as being what it is.
  92   # This ... is kinda bull. But that's how HAVING is specified.
  93   return $start_dq unless $attrs->{group_by} or $attrs->{having};
  94   my $grouped_dq = $self->_group_by_to_dq($attrs->{group_by}||[], $start_dq);
  95   return $grouped_dq unless $attrs->{having};
  96   +{
  97     type => DQ_WHERE,
  98     from => $grouped_dq,
  99     where => $self->_where_to_dq($attrs->{having})
 100   };
 101 };
 102
 103 sub _group_by_to_dq {
 104   my ($self, $group, $from) = @_;
 105   +{
 106     type => DQ_GROUP,
 107     by => $self->_select_field_list_to_dq($group),
 108     from => $from,
 109   };
 110 }
 111
 112 around _table_to_dq => sub {
 113   my ($orig, $self) = (shift, shift);
 114   my ($spec) = @_;
 115   if (my $ref = ref $spec ) {
 116     if ($ref eq 'ARRAY') {
 117       return $self->_join_to_dq(@$spec);
 118     }
 119     elsif ($ref eq 'HASH') {
 120       my ($as, $table, $toomuch) = ( map
 121         { $_ => $spec->{$_} }
 122         ( grep { $_ !~ /^\-/ } keys %$spec )
 123       );
 124       die "Only one table/as pair expected in from-spec but an exra '$toomuch' key present"
 125         if defined $toomuch;
 126
 127       return +{
 128         type => DQ_ALIAS,
 129         from => $self->_table_to_dq($table),
 130         to => $as,
 131         ($spec->{-rsrc}
 132           ? (
 133               'dbix-class.source_name' => $spec->{-rsrc}->source_name,
 134               'dbix-class.join_path' => $spec->{-join_path},
 135               'dbix-class.is_single' => $spec->{-is_single},
 136             )
 137           : ()
 138         )
 139       };
 140     }
 141   }
 142   return $self->$orig(@_);
 143 };
 144
 145 sub _join_to_dq {
 146   my ($self, $from, @joins) = @_;
 147
 148   my $cur_dq = $self->_table_to_dq($from);
 149
 150   if (!@joins or @joins == 1 and ref($joins[0]) eq 'HASH') {
 151     return $cur_dq;
 152   }
 153
 154   foreach my $join (@joins) {
 155     my ($to, $on) = @$join;
 156
 157     # check whether a join type exists
 158     my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
 159     my $join_type;
 160     if (ref($to_jt) eq 'HASH' and defined($to_jt->{-join_type})) {
 161       $join_type = lc($to_jt->{-join_type});
 162       $join_type =~ s/^\s+ | \s+$//xg;
 163       undef($join_type) unless $join_type =~ s/^(left|right).*/$1/;
 164     }
 165
 166     $cur_dq = +{
 167       type => DQ_JOIN,
 168       ($join_type ? (outer => $join_type) : ()),
 169       left => $cur_dq,
 170       right => $self->_table_to_dq($to),
 171       ($on
 172         ? (on => $self->_expr_to_dq($self->_expand_join_condition($on)))
 173         : ()),
 174     };
 175   }
 176
 177   return $cur_dq;
 178 }
 179
 180 sub _expand_join_condition {
 181   my ($self, $cond) = @_;
 182
 183   # Backcompat for the old days when a plain hashref
 184   # { 't1.col1' => 't2.col2' } meant ON t1.col1 = t2.col2
 185   # Once things settle we should start warning here so that
 186   # folks unroll their hacks
 187   if (
 188     ref $cond eq 'HASH'
 189       and
 190     keys %$cond == 1
 191       and
 192     (keys %$cond)[0] =~ /\./
 193       and
 194     ! ref ( (values %$cond)[0] )
 195   ) {
 196     return +{ keys %$cond => { -ident => values %$cond } }
 197   }
 198   elsif ( ref $cond eq 'ARRAY' ) {
 199     return [ map $self->_expand_join_condition($_), @$cond ];
 200   }
 201
 202   return $cond;
 203 }
 204
 205 around _bind_to_dq => sub {
 206   my ($orig, $self) = (shift, shift);
 207   my @args = do {
 208     if ($self->bind_meta) {
 209       map { ref($_) eq 'ARRAY' ? $_ : [ {} => $_ ] } @_
 210     } else {
 211       @_
 212     }
 213   };
 214   return $self->$orig(@args);
 215 };
 216
 217 1;
 218
 219 =head1 OPERATORS
 220
 221 =head2 -ident
 222
 223 Used to explicitly specify an SQL identifier. Takes a plain string as value
 224 which is then invariably treated as a column name (and is being properly
 225 quoted if quoting has been requested). Most useful for comparison of two
 226 columns:
 227
 228     my %where = (
 229         priority => { '<', 2 },
 230         requestor => { -ident => 'submitter' }
 231     );
 232
 233 which results in:
 234
 235     $stmt = 'WHERE "priority" < ? AND "requestor" = "submitter"';
 236     @bind = ('2');
 237
 238 =head2 -value
 239
 240 The -value operator signals that the argument to the right is a raw bind value.
 241 It will be passed straight to DBI, without invoking any of the SQL::Abstract
 242 condition-parsing logic. This allows you to, for example, pass an array as a
 243 column value for databases that support array datatypes, e.g.:
 244
 245     my %where = (
 246         array => { -value => [1, 2, 3] }
 247     );
 248
 249 which results in:
 250
 251     $stmt = 'WHERE array = ?';
 252     @bind = ([1, 2, 3]);
 253
 254 =head1 AUTHORS
 255
 256 See L<DBIx::Class/CONTRIBUTORS>.
 257
 258 =head1 LICENSE
 259
 260 You may distribute this code under the same terms as Perl itself.
 261
 262 =cut