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::Clauses);
   8
   9 BEGIN { *puke = \&SQL::Abstract::puke }
  10
  11 sub register_defaults {
  12   my $self = shift;
  13   $self->next::method(@_);
  14   my @clauses = $self->clauses_of('select');
  15   my @before_setop;
  16   CLAUSE: foreach my $idx (0..$#clauses) {
  17     if ($clauses[$idx] eq 'order_by') {
  18       @before_setop = @clauses[0..$idx-1];
  19       splice(@clauses, $idx, 0, qw(setop group_by having));
  20       last CLAUSE;
  21     }
  22   }
  23   die "Huh?" unless @before_setop;
  24   $self->clauses_of(select => @clauses);
  25   $self->clause_expanders(
  26     'select.group_by', sub {
  27       $_[0]->_expand_maybe_list_expr($_[1], -ident)
  28     },
  29     'select.having', 'expand_expr',
  30   );
  31   foreach my $thing (qw(join from_list)) {
  32     $self->expander($thing => "_expand_${thing}")
  33          ->renderer($thing => "_render_${thing}")
  34   }
  35   $self->op_expander(as => '_expand_op_as');
  36   $self->expander(as => '_expand_op_as');
  37   $self->renderer(as => '_render_as');
  38
  39   $self->clauses_of(update => sub {
  40     my ($self, @clauses) = @_;
  41     splice(@clauses, 2, 0, 'from');
  42     @clauses;
  43   });
  44
  45   $self->clauses_of(delete => sub {
  46     my ($self, @clauses) = @_;
  47     splice(@clauses, 1, 0, 'using');
  48     @clauses;
  49   });
  50
  51   $self->clause_expanders(
  52     'update.from' => '_expand_select_clause_from',
  53     'delete.using' => sub {
  54       +(using => $_[0]->_expand_from_list(undef, $_[1]));
  55     },
  56     'insert.rowvalues' => sub {
  57       +(from => $_[0]->expand_expr({ -values => $_[1] }));
  58     },
  59     'insert.select' => sub {
  60       +(from => $_[0]->expand_expr({ -select => $_[1] }));
  61     },
  62   );
  63
  64   # set ops
  65   {
  66     my $orig = $self->expander('select');
  67     $self->expander(select => sub {
  68       my $self = shift;
  69       my $exp = $self->$orig(@_);
  70       return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
  71       if (my @keys = grep $sel->{$_}, @before_setop) {
  72         my %inner; @inner{@keys} = delete @{$sel}{@keys};
  73         unshift @{(values(%$setop))[0]{queries}},
  74           { -select => \%inner };
  75       }
  76       return $exp;
  77     });
  78   }
  79
  80   $self->clause_expander('select.union' => sub {
  81     +(setop => $_[0]->expand_expr({
  82                  -union => {
  83                    queries => (ref($_[1]) eq 'ARRAY' ? $_[1] : [ $_[1] ]),
  84                  }
  85                }));
  86   });
  87   $self->clause_expander('select.union_all' => sub {
  88     +(setop => $_[0]->expand_expr({
  89                  -union => {
  90                    type => 'all',
  91                    queries => (ref($_[1]) eq 'ARRAY' ? $_[1] : [ $_[1] ]),
  92                  }
  93                }));
  94   });
  95   $self->expander(union => sub {
  96     my ($self, undef, $args) = @_;
  97     +{ -union => {
  98          %$args,
  99          queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
 100     } };
 101   });
 102
 103   $self->clause_renderer('select.setop' => sub {
 104     my ($self, $setop) = @_;
 105     $self->render_aqt($setop);
 106   });
 107
 108   $self->renderer(union => sub {
 109     my ($self, $args) = @_;
 110     $self->join_clauses(
 111       ' '.$self->format_keyword(join '_', 'union', ($args->{type}||())).' ',
 112       map [ $self->render_aqt($_) ], @{$args->{queries}}
 113     );
 114   });
 115
 116   return $self;
 117 }
 118
 119 sub format_keyword { $_[0]->_sqlcase(join ' ', split '_', $_[1]) }
 120
 121 sub _expand_select_clause_from {
 122   my ($self, $from) = @_;
 123   +(from => $self->_expand_from_list(undef, $from));
 124 }
 125
 126 sub _expand_from_list {
 127   my ($self, undef, $args) = @_;
 128   if (ref($args) eq 'HASH') {
 129     return { -from_list => [ $self->expand_expr($args) ] };
 130   }
 131   my @list;
 132   my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
 133   while (my $entry = shift @args) {
 134     if (!ref($entry) and $entry =~ /^-(.*)/) {
 135       if ($1 eq 'as') {
 136         $list[-1] = $self->expand_expr({ -as => [
 137           $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
 138         ]});
 139         next;
 140       }
 141       $entry = { $entry => shift @args };
 142     }
 143     my $aqt = $self->expand_expr($entry, -ident);
 144     if ($aqt->{-join} and not $aqt->{-join}{from}) {
 145       $aqt->{-join}{from} = pop @list;
 146     }
 147     push @list, $aqt;
 148   }
 149   return { -from_list => \@list };
 150 }
 151
 152 sub _expand_join {
 153   my ($self, undef, $args) = @_;
 154   my %proto = (
 155     ref($args) eq 'HASH'
 156       ? %$args
 157       : (to => $args->[0], @{$args}[1..$#$args])
 158   );
 159   if (my $as = delete $proto{as}) {
 160     $proto{to} = { -as => [ $proto{to}, ref($as) eq 'ARRAY' ? @$as : $as ] };
 161   }
 162   if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
 163     $proto{using} = { -row => [
 164       map [ $self->expand_expr($_, -ident) ],
 165         ref($using) eq 'ARRAY' ? @$using: $using
 166     ] };
 167   }
 168   my %ret = map +($_ => $self->expand_expr($proto{$_}, -ident)),
 169               sort keys %proto;
 170   return +{ -join => \%ret };
 171 }
 172
 173 sub _render_from_list {
 174   my ($self, $list) = @_;
 175   return $self->join_clauses(', ', map [ $self->render_aqt($_) ], @$list);
 176 }
 177
 178 sub _render_join {
 179   my ($self, $args) = @_;
 180
 181   my @parts = (
 182     [ $self->render_aqt($args->{from}) ],
 183     [ $self->format_keyword(join '_', ($args->{type}||()), 'join') ],
 184     [ $self->render_aqt(
 185         map +($_->{-ident} || $_->{-as} ? $_ : { -row => [ $_ ] }), $args->{to}
 186     ) ],
 187     ($args->{on} ? (
 188       [ $self->format_keyword('on') ],
 189       [ $self->render_aqt($args->{on}) ],
 190     ) : ()),
 191     ($args->{using} ? (
 192       [ $self->format_keyword('using') ],
 193       [ $self->render_aqt($args->{using}) ],
 194     ) : ()),
 195   );
 196   return $self->join_clauses(' ', @parts);
 197 }
 198
 199 sub _expand_op_as {
 200   my ($self, undef, $vv, $k) = @_;
 201   my @as = map $self->expand_expr($_, -ident),
 202              (defined($k) ? ($k) : ()), ref($vv) eq 'ARRAY' ? @$vv : $vv;
 203   return { -as => \@as };
 204 }
 205
 206 sub _render_as {
 207   my ($self, $args) = @_;
 208   my ($thing, $as, @cols) = @$args;
 209   return $self->join_clauses(
 210     ' ',
 211     [ $self->render_aqt($thing) ],
 212     [ $self->format_keyword('as') ],
 213     (@cols
 214       ? [ $self->join_clauses('',
 215             [ $self->render_aqt($as) ],
 216             [ '(' ],
 217             [ $self->join_clauses(
 218                 ', ',
 219                 map [ $self->render_aqt($_) ], @cols
 220             ) ],
 221             [ ')' ],
 222         ) ]
 223       : [ $self->render_aqt($as) ]
 224     ),
 225   );
 226 }
 227
 228 1;