lib/SQL/Abstract/ExtraClauses.pm

   1 package SQL::Abstract::ExtraClauses;
   2
   3 use Moo;
   4
   5 has sqla => (
   6   is => 'ro', init_arg => undef,
   7   handles => [ qw(
   8     expand_expr expand_maybe_list_expr render_aqt join_query_parts
   9   ) ],
  10 );
  11
  12 sub cb {
  13   my ($self, $method, @args) = @_;
  14   return sub {
  15     local $self->{sqla} = shift;
  16     $self->$method(@args, @_)
  17   };
  18 }
  19
  20 sub register {
  21   my ($self, $method, @pairs) = @_;
  22   my $sqla = $self->sqla;
  23   while (my ($car, $cdr) = splice(@pairs, 0, 2)) {
  24     my $cb = $self->cb($cdr);
  25     $sqla->$method($car, $cb);
  26   }
  27   return $self;
  28 }
  29
  30 sub apply_to {
  31   my ($self, $sqla) = @_;
  32   $self = $self->new unless ref($self);
  33   local $self->{sqla} = $sqla;
  34   $self->register_extensions($sqla);
  35 }
  36
  37 sub register_extensions {
  38   my ($self, $sqla) = @_;
  39   my @clauses = $sqla->clauses_of('select');
  40   my @before_setop;
  41   CLAUSE: foreach my $idx (0..$#clauses) {
  42     if ($clauses[$idx] eq 'order_by') {
  43       @before_setop = @clauses[0..$idx-1];
  44       splice(@clauses, $idx, 0, qw(setop group_by having));
  45       last CLAUSE;
  46     }
  47   }
  48   die "Huh?" unless @before_setop;
  49   $sqla->clauses_of(select => 'with', @clauses);
  50   $self->register(
  51     clause_expanders =>
  52       'select.group_by'
  53         => sub { $_[0]->expand_maybe_list_expr($_[2], -ident) },
  54       'select.having'
  55         => sub { $_[0]->expand_expr($_[2]) },
  56   );
  57   $self->register(
  58     expander => (join => '_expand_join', from_list => '_expand_from_list')
  59   );
  60   $self->register(
  61     renderer => (join => '_render_join', from_list => '_render_from_list')
  62   );
  63   $sqla->binop_expander(as => $self->cb('_expand_op_as'));
  64   $sqla->renderer(as => $self->cb('_render_as'));
  65   $sqla->expander(alias => $self->cb('_expand_alias'));
  66   $sqla->renderer(alias => $self->cb('_render_alias'));
  67
  68   $sqla->clauses_of(update => sub {
  69     my ($self, @clauses) = @_;
  70     splice(@clauses, 2, 0, 'from');
  71     @clauses;
  72   });
  73
  74   $sqla->clauses_of(delete => sub {
  75     my ($self, @clauses) = @_;
  76     splice(@clauses, 1, 0, 'using');
  77     @clauses;
  78   });
  79
  80   $sqla->clause_expanders(
  81     'update.from' => $self->cb('_expand_from_list'),
  82     'delete.using' => $self->cb('_expand_from_list'),
  83     'insert.rowvalues' => $self->cb(sub {
  84       +(from => $_[0]->expand_expr({ -values => $_[2] }));
  85     }),
  86     'insert.select' => $self->cb(sub {
  87       +(from => $_[0]->expand_expr({ -select => $_[2] }));
  88     }),
  89   );
  90
  91   # set ops
  92   $sqla->wrap_expander(select => sub {
  93     $self->cb('_expand_select', $_[0], \@before_setop);
  94   });
  95
  96   $sqla->clause_renderer(
  97     'select.setop' => $self->cb(sub { $_[0]->render_aqt($_[2]); })
  98   );
  99
 100   foreach my $setop (qw(union intersect except)) {
 101     $sqla->expander($setop => $self->cb('_expand_setop'));
 102     $sqla->renderer($setop => $self->cb('_render_setop'));
 103   }
 104
 105   my $setop_expander = $self->cb('_expand_clause_setop');
 106
 107   $sqla->clause_expanders(
 108     map +($_ => $setop_expander),
 109       map "select.${_}",
 110         map +($_, "${_}_all", "${_}_distinct"),
 111           qw(union intersect except)
 112   );
 113
 114   my $w_exp = $self->cb('_expand_with');
 115   my $w_rdr = $self->cb('_render_with');
 116   $sqla->clause_expander('select.with' => $w_exp);
 117   $sqla->clause_expander('select.with_recursive' => $w_exp);
 118   $sqla->clause_renderer('select.with' => $w_rdr);
 119
 120   foreach my $stmt (qw(insert update delete)) {
 121     $sqla->clauses_of($stmt => 'with', $sqla->clauses_of($stmt));
 122     $sqla->clause_expander("${stmt}.$_" => $w_exp)
 123       for qw(with with_recursive);
 124     $sqla->clause_renderer("${stmt}.with" => $w_rdr);
 125   }
 126
 127   $sqla->expander(cast => $self->cb('_expand_cast'));
 128
 129   $sqla->clause_expanders(
 130     "select.from", $self->cb('_expand_from_list'),
 131     "update.target", $self->cb('_expand_update_clause_target'),
 132     "update.update", $self->cb('_expand_update_clause_target'),
 133   );
 134
 135   return $sqla;
 136 }
 137
 138 sub _expand_select {
 139   my ($self, $orig, $before_setop, @args) = @_;
 140   my $exp = $self->sqla->$orig(@args);
 141   return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
 142   if (my @keys = grep $sel->{$_}, @$before_setop) {
 143     my %inner; @inner{@keys} = delete @{$sel}{@keys};
 144     unshift @{(values(%$setop))[0]{queries}},
 145       { -select => \%inner };
 146   }
 147   return $exp;
 148 }
 149
 150 sub _expand_from_list {
 151   my ($self, undef, $args) = @_;
 152   if (ref($args) eq 'HASH') {
 153     return $args if $args->{-from_list};
 154     return { -from_list => [ $self->expand_expr($args) ] };
 155   }
 156   my @list;
 157   my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
 158   while (my $entry = shift @args) {
 159     if (!ref($entry) and $entry =~ /^-(.*)/) {
 160       if ($1 eq 'as') {
 161         $list[-1] = $self->expand_expr({ -as => [
 162           $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
 163         ]});
 164         next;
 165       }
 166       $entry = { $entry => shift @args };
 167     }
 168     my $aqt = $self->expand_expr($entry, -ident);
 169     if ($aqt->{-join} and not $aqt->{-join}{from}) {
 170       $aqt->{-join}{from} = pop @list;
 171     }
 172     push @list, $aqt;
 173   }
 174   return { -from_list => \@list };
 175 }
 176
 177 sub _expand_join {
 178   my ($self, undef, $args) = @_;
 179   my %proto = (
 180     ref($args) eq 'HASH'
 181       ? %$args
 182       : (to => $args->[0], @{$args}[1..$#$args])
 183   );
 184   if (my $as = delete $proto{as}) {
 185     $proto{to} = $self->expand_expr({ -as => [ $proto{to}, $as ] });
 186   }
 187   if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
 188     $proto{using} = [
 189       map [ $self->expand_expr($_, -ident) ],
 190         ref($using) eq 'ARRAY' ? @$using: $using
 191     ];
 192   }
 193   my %ret = map +($_ => $self->expand_expr($proto{$_}, -ident)),
 194               sort keys %proto;
 195   return +{ -join => \%ret };
 196 }
 197
 198 sub _render_from_list {
 199   my ($self, undef, $list) = @_;
 200   return $self->join_query_parts(', ', @$list);
 201 }
 202
 203 sub _render_join {
 204   my ($self, undef, $args) = @_;
 205
 206   my @parts = (
 207     $args->{from},
 208     { -keyword => join '_', ($args->{type}||()), 'join' },
 209     (map +($_->{-ident} || $_->{-as} ? $_ : ('(', $_, ')')), $args->{to}),
 210     ($args->{on} ? (
 211       { -keyword => 'on' },
 212       $args->{on},
 213     ) : ()),
 214     ($args->{using} ? (
 215       { -keyword => 'using' },
 216       '(', $args->{using}, ')',
 217     ) : ()),
 218   );
 219   return $self->join_query_parts(' ', @parts);
 220 }
 221
 222 sub _expand_op_as {
 223   my ($self, undef, $vv, $k) = @_;
 224   my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
 225   my $ik = $self->expand_expr($k, -ident);
 226   return +{ -as => [ $ik, $self->expand_expr($vv[0], -alias) ] }
 227     if @vv == 1 and ref($vv[0]) eq 'HASH';
 228
 229   my @as = map $self->expand_expr($_, -ident), @vv;
 230   return { -as => [ $ik, { -alias => \@as } ] };
 231 }
 232
 233 sub _render_as {
 234   my ($self, undef, $args) = @_;
 235   my ($thing, $alias) = @$args;
 236   return $self->join_query_parts(
 237     ' ',
 238     $thing,
 239     { -keyword => 'as' },
 240     $alias,
 241   );
 242 }
 243
 244 sub _render_alias {
 245   my ($self, undef, $args) = @_;
 246   my ($as, @cols) = @$args;
 247   return (@cols
 248     ? $self->join_query_parts('',
 249          $as,
 250          '(',
 251          $self->join_query_parts(
 252            ', ',
 253            @cols
 254          ),
 255          ')',
 256       )
 257     : $self->render_aqt($as)
 258   );
 259 }
 260
 261 sub _expand_update_clause_target {
 262   my ($self, undef, $target) = @_;
 263   +(target => $self->_expand_from_list(undef, $target));
 264 }
 265
 266 sub _expand_cast {
 267   my ($self, undef, $thing) = @_;
 268   return { -func => [ cast => $thing ] } if ref($thing) eq 'HASH';
 269   my ($cast, $to) = @{$thing};
 270   +{ -func => [ cast => { -as => [
 271     $self->expand_expr($cast),
 272     $self->expand_expr($to, -ident),
 273   ] } ] };
 274 }
 275
 276 sub _expand_alias {
 277   my ($self, undef, $args) = @_;
 278   if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
 279     $args = $alias;
 280   }
 281   +{ -alias => [
 282       map $self->expand_expr($_, -ident),
 283       ref($args) eq 'ARRAY' ? @{$args} : $args
 284     ]
 285   }
 286 }
 287
 288 sub _expand_with {
 289   my ($self, $name, $with) = @_;
 290   my (undef, $type) = split '_', $name;
 291   if (ref($with) eq 'HASH') {
 292     return +{
 293       %$with,
 294       queries => [
 295         map +[
 296           $self->expand_expr({ -alias => $_->[0] }, -ident),
 297           $self->expand_expr($_->[1]),
 298         ], @{$with->{queries}}
 299       ]
 300     }
 301   }
 302   my @with = @$with;
 303   my @exp;
 304   while (my ($alias, $query) = splice @with, 0, 2) {
 305     push @exp, [
 306       $self->expand_expr({ -alias => $alias }, -ident),
 307       $self->expand_expr($query)
 308     ];
 309   }
 310   return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
 311 }
 312
 313 sub _render_with {
 314   my ($self, undef, $with) = @_;
 315   my $q_part = $self->join_query_parts(', ',
 316     map {
 317       my ($alias, $query) = @$_;
 318       $self->join_query_parts(' ',
 319           $alias,
 320           { -keyword => 'as' },
 321           $query,
 322       )
 323     } @{$with->{queries}}
 324   );
 325   return $self->join_query_parts(' ',
 326     { -keyword => join '_', 'with', ($with->{type}||'') },
 327     $q_part,
 328   );
 329 }
 330
 331 sub _expand_setop {
 332   my ($self, $setop, $args) = @_;
 333   +{ "-${setop}" => {
 334        %$args,
 335        queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
 336   } };
 337 }
 338
 339 sub _render_setop {
 340   my ($self, $setop, $args) = @_;
 341   $self->join_query_parts(
 342     { -keyword => ' '.join('_', $setop, ($args->{type}||())).' ' },
 343     @{$args->{queries}}
 344   );
 345 }
 346
 347 sub _expand_clause_setop {
 348   my ($self, $setop, $args) = @_;
 349   my ($op, $type) = split '_', $setop;
 350   +(setop => $self->expand_expr({
 351     "-${op}" => {
 352       ($type ? (type => $type) : ()),
 353       queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
 354     }
 355   }));
 356 }
 357
 358 1;
 359
 360 __END__
 361
 362 =head1 NAME
 363
 364 SQL::Abstract::ExtraClauses - new/experimental additions to L<SQL::Abstract>
 365
 366 =head1 SYNOPSIS
 367
 368   my $sqla = SQL::Abstract->new;
 369   SQL::Abstract::ExtraClauses->apply_to($sqla);
 370
 371 =head1 METHODS
 372
 373 =head2 apply_to
 374
 375 Applies the plugin to an L<SQL::Abstract> object.
 376
 377 =head2 cb
 378
 379 For plugin authors, creates a callback to call a method on the plugin.
 380
 381 =head2 sqla
 382
 383 Available only during plugin callback executions, contains the currently
 384 active L<SQL::Abstract> object.
 385
 386 =head1 NODE TYPES
 387
 388 =head2 alias
 389
 390 Represents a table alias. Expands name and column names with ident as default.
 391
 392   # expr
 393   { -alias => [ 't', 'x', 'y', 'z' ] }
 394
 395   # aqt
 396   { -alias => [
 397       { -ident => [ 't' ] }, { -ident => [ 'x' ] },
 398       { -ident => [ 'y' ] }, { -ident => [ 'z' ] },
 399   ] }
 400
 401   # query
 402   t(x, y, z)
 403   []
 404
 405 =head2 as
 406
 407 Represents an sql AS. LHS is expanded with ident as default, RHS is treated
 408 as a list of arguments for the alias node.
 409
 410   # expr
 411   { foo => { -as => 'bar' } }
 412
 413   # aqt
 414   { -as =>
 415       [
 416         { -ident => [ 'foo' ] },
 417         { -alias => [ { -ident => [ 'bar' ] } ] },
 418       ]
 419   }
 420
 421   # query
 422   foo AS bar
 423   []
 424
 425   # expr
 426   { -as => [ { -select => { _ => 'blah' } }, 't', 'blah' ] }
 427
 428   # aqt
 429   { -as => [
 430       { -select =>
 431           { select => { -op => [ ',', { -ident => [ 'blah' ] } ] } }
 432       },
 433       { -alias => [ { -ident => [ 't' ] }, { -ident => [ 'blah' ] } ] },
 434   ] }
 435
 436   # query
 437   (SELECT blah) AS t(blah)
 438   []
 439
 440 =head2 cast
 441
 442   # expr
 443   { -cast => [ { -ident => 'birthday' }, 'date' ] }
 444
 445   # aqt
 446   { -func => [
 447       'cast', {
 448         -as => [ { -ident => [ 'birthday' ] }, { -ident => [ 'date' ] } ]
 449       },
 450   ] }
 451
 452   # query
 453   CAST(birthday AS date)
 454   []
 455
 456 =cut