lib/SQL/Abstract/ExtraClauses.pm

   1 package SQL::Abstract::ExtraClauses;
   2
   3 use strict;
   4 use warnings;
   5 use if $] < '5.010', 'MRO::Compat';
   6 use mro 'c3';
   7 use base qw(SQL::Abstract);
   8
   9 BEGIN { *puke = \&SQL::Abstract::puke }
  10
  11 sub new {
  12   my $self = shift->next::method(@_);
  13   my @clauses = $self->clauses_of('select');
  14   my @before_setop;
  15   CLAUSE: foreach my $idx (0..$#clauses) {
  16     if ($clauses[$idx] eq 'order_by') {
  17       @before_setop = @clauses[0..$idx-1];
  18       splice(@clauses, $idx, 0, qw(setop group_by having));
  19       last CLAUSE;
  20     }
  21   }
  22   die "Huh?" unless @before_setop;
  23   $self->clauses_of(select => 'with', @clauses);
  24   $self->clause_expanders(
  25     'select.group_by', sub {
  26       $_[0]->_expand_maybe_list_expr($_[2], -ident)
  27     },
  28     'select.having', sub { $_[0]->expand_expr($_[2]) },
  29   );
  30   foreach my $thing (qw(join from_list)) {
  31     $self->expander($thing => "_expand_${thing}")
  32          ->renderer($thing => "_render_${thing}")
  33   }
  34   $self->op_expander(as => '_expand_op_as');
  35   $self->expander(as => '_expand_op_as');
  36   $self->renderer(as => '_render_as');
  37   $self->expander(alias => sub {
  38     my ($self, undef, $args) = @_;
  39     if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
  40       $args = $alias;
  41     }
  42     +{ -alias => [
  43         map $self->expand_expr($_, -ident),
  44         ref($args) eq 'ARRAY' ? @{$args} : $args
  45       ]
  46     }
  47   });
  48   $self->renderer(alias => '_render_alias');
  49
  50   $self->clauses_of(update => sub {
  51     my ($self, @clauses) = @_;
  52     splice(@clauses, 2, 0, 'from');
  53     @clauses;
  54   });
  55
  56   $self->clauses_of(delete => sub {
  57     my ($self, @clauses) = @_;
  58     splice(@clauses, 1, 0, 'using');
  59     @clauses;
  60   });
  61
  62   $self->clause_expanders(
  63     'update.from' => '_expand_select_clause_from',
  64     'delete.using' => sub {
  65       +(using => $_[0]->_expand_from_list(undef, $_[2]));
  66     },
  67     'insert.rowvalues' => sub {
  68       +(from => $_[0]->expand_expr({ -values => $_[2] }));
  69     },
  70     'insert.select' => sub {
  71       +(from => $_[0]->expand_expr({ -select => $_[2] }));
  72     },
  73   );
  74
  75   # set ops
  76   $self->wrap_expander(select => sub {
  77     my $orig = shift;
  78     sub {
  79       my $self = shift;
  80       my $exp = $self->$orig(@_);
  81       return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
  82       if (my @keys = grep $sel->{$_}, @before_setop) {
  83         my %inner; @inner{@keys} = delete @{$sel}{@keys};
  84         unshift @{(values(%$setop))[0]{queries}},
  85           { -select => \%inner };
  86       }
  87       return $exp;
  88     }
  89   });
  90   my $expand_setop = sub {
  91     my ($self, $setop, $args) = @_;
  92     +{ "-${setop}" => {
  93          %$args,
  94          queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
  95     } };
  96   };
  97   $self->expanders(map +($_ => $expand_setop), qw(union intersect except));
  98
  99   $self->clause_renderer('select.setop' => sub {
 100     my ($self, undef, $setop) = @_;
 101     $self->render_aqt($setop);
 102   });
 103
 104   $self->renderer($_ => sub {
 105     my ($self, $setop, $args) = @_;
 106     $self->join_query_parts(
 107       ' '.$self->format_keyword(join '_', $setop, ($args->{type}||())).' ',
 108       @{$args->{queries}}
 109     );
 110   }) for qw(union intersect except);
 111
 112   my $setop_expander = sub {
 113     my ($self, $setop, $args) = @_;
 114     my ($op, $type) = split '_', $setop;
 115     +(setop => $self->expand_expr({
 116       "-${op}" => {
 117         ($type ? (type => $type) : ()),
 118         queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
 119       }
 120     }));
 121   };
 122
 123   $self->clause_expanders(
 124     map +($_ => $setop_expander),
 125       map "select.${_}",
 126         map +($_, "${_}_all", "${_}_distinct"),
 127           qw(union intersect except)
 128   );
 129
 130   $self->clause_expander('select.with' => my $with_expander = sub {
 131     my ($self, $name, $with) = @_;
 132     my (undef, $type) = split '_', $name;
 133     if (ref($with) eq 'HASH') {
 134       return +{
 135         %$with,
 136         queries => [
 137           map +[
 138             $self->expand_expr({ -alias => $_->[0] }, -ident),
 139             $self->expand_expr($_->[1]),
 140           ], @{$with->{queries}}
 141         ]
 142       }
 143     }
 144     my @with = @$with;
 145     my @exp;
 146     while (my ($alias, $query) = splice @with, 0, 2) {
 147       push @exp, [
 148         $self->expand_expr({ -alias => $alias }, -ident),
 149         $self->expand_expr($query)
 150       ];
 151     }
 152     return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
 153   });
 154   $self->clause_expander('select.with_recursive', $with_expander);
 155   $self->clause_renderer('select.with' => my $with_renderer = sub {
 156     my ($self, undef, $with) = @_;
 157     my $q_part = $self->join_query_parts(', ',
 158       map {
 159         my ($alias, $query) = @$_;
 160         $self->join_query_parts(' ',
 161             $alias,
 162             $self->format_keyword('as'),
 163             $query,
 164         )
 165       } @{$with->{queries}}
 166     );
 167     return $self->join_query_parts(' ',
 168       $self->format_keyword(join '_', 'with', ($with->{type}||'')),
 169       $q_part,
 170     );
 171   });
 172   foreach my $stmt (qw(insert update delete)) {
 173     $self->clauses_of($stmt => 'with', $self->clauses_of($stmt));
 174     $self->clause_expander("${stmt}.$_", $with_expander)
 175       for qw(with with_recursive);
 176     $self->clause_renderer("${stmt}.with", $with_renderer);
 177   }
 178   $self->expander(cast => sub {
 179     return { -func => [ cast => $_[2] ] } if ref($_[2]) eq 'HASH';
 180     my ($cast, $to) = @{$_[2]};
 181     +{ -func => [ cast => { -as => [
 182       $self->expand_expr($cast),
 183       $self->expand_expr($to, -ident),
 184     ] } ] };
 185   });
 186
 187   return $self;
 188 }
 189
 190 sub _expand_select_clause_from {
 191   my ($self, undef, $from) = @_;
 192   +(from => $self->_expand_from_list(undef, $from));
 193 }
 194
 195 sub _expand_from_list {
 196   my ($self, undef, $args) = @_;
 197   if (ref($args) eq 'HASH') {
 198     return $args if $args->{-from_list};
 199     return { -from_list => [ $self->expand_expr($args) ] };
 200   }
 201   my @list;
 202   my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
 203   while (my $entry = shift @args) {
 204     if (!ref($entry) and $entry =~ /^-(.*)/) {
 205       if ($1 eq 'as') {
 206         $list[-1] = $self->expand_expr({ -as => [
 207           $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
 208         ]});
 209         next;
 210       }
 211       $entry = { $entry => shift @args };
 212     }
 213     my $aqt = $self->expand_expr($entry, -ident);
 214     if ($aqt->{-join} and not $aqt->{-join}{from}) {
 215       $aqt->{-join}{from} = pop @list;
 216     }
 217     push @list, $aqt;
 218   }
 219   return { -from_list => \@list };
 220 }
 221
 222 sub _expand_join {
 223   my ($self, undef, $args) = @_;
 224   my %proto = (
 225     ref($args) eq 'HASH'
 226       ? %$args
 227       : (to => $args->[0], @{$args}[1..$#$args])
 228   );
 229   if (my $as = delete $proto{as}) {
 230     $proto{to} = $self->expand_expr({ -as => [ $proto{to}, $as ] });
 231   }
 232   if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
 233     $proto{using} = [
 234       map [ $self->expand_expr($_, -ident) ],
 235         ref($using) eq 'ARRAY' ? @$using: $using
 236     ];
 237   }
 238   my %ret = map +($_ => $self->expand_expr($proto{$_}, -ident)),
 239               sort keys %proto;
 240   return +{ -join => \%ret };
 241 }
 242
 243 sub _render_from_list {
 244   my ($self, undef, $list) = @_;
 245   return $self->join_query_parts(', ', @$list);
 246 }
 247
 248 sub _render_join {
 249   my ($self, undef, $args) = @_;
 250
 251   my @parts = (
 252     $args->{from},
 253     $self->format_keyword(join '_', ($args->{type}||()), 'join'),
 254     (map +($_->{-ident} || $_->{-as} ? $_ : ('(', $_, ')')), $args->{to}),
 255     ($args->{on} ? (
 256       $self->format_keyword('on') ,
 257       $args->{on},
 258     ) : ()),
 259     ($args->{using} ? (
 260       $self->format_keyword('using'),
 261       '(', $args->{using}, ')',
 262     ) : ()),
 263   );
 264   return $self->join_query_parts(' ', @parts);
 265 }
 266
 267 sub _expand_op_as {
 268   my ($self, undef, $vv, $k) = @_;
 269   my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
 270   $k ||= shift @vv;
 271   my $ik = $self->expand_expr($k, -ident);
 272   return +{ -as => [ $ik, $self->expand_expr($vv[0], -alias) ] }
 273     if @vv == 1 and ref($vv[0]) eq 'HASH';
 274
 275   my @as = map $self->expand_expr($_, -ident), @vv;
 276   return { -as => [ $ik, { -alias => \@as } ] };
 277 }
 278
 279 sub _render_as {
 280   my ($self, undef, $args) = @_;
 281   my ($thing, $alias) = @$args;
 282   return $self->join_query_parts(
 283     ' ',
 284     $thing,
 285     $self->format_keyword('as'),
 286     $alias,
 287   );
 288 }
 289
 290 sub _render_alias {
 291   my ($self, undef, $args) = @_;
 292   my ($as, @cols) = @$args;
 293   return (@cols
 294     ? $self->join_query_parts('',
 295          $as,
 296          '(',
 297          $self->join_query_parts(
 298            ', ',
 299            @cols
 300          ),
 301          ')',
 302       )
 303     : $self->render_aqt($as)
 304   );
 305 }
 306
 307 sub _expand_update_clause_target {
 308   my ($self, undef, $target) = @_;
 309   +(target => $self->_expand_from_list(undef, $target));
 310 }
 311
 312 1;