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 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, @pairs) = @_;
  22   my $sqla = $self->sqla;
  23   while (my ($method, $cases) = splice(@pairs, 0, 2)) {
  24     my @cases = @$cases;
  25     while (my ($name, $case) = splice(@cases, 0, 2)) {
  26       $sqla->$method($name, $self->cb($case));
  27     }
  28   }
  29   return $self;
  30 }
  31
  32 sub apply_to {
  33   my ($self, $sqla) = @_;
  34   $self = $self->new unless ref($self);
  35   local $self->{sqla} = $sqla;
  36   $self->register_extensions($sqla);
  37 }
  38
  39 sub register_extensions {
  40   my ($self, $sqla) = @_;
  41
  42   my @clauses = $sqla->clauses_of('select');
  43   my @before_setop;
  44   CLAUSE: foreach my $idx (0..$#clauses) {
  45     if ($clauses[$idx] eq 'order_by') {
  46       @before_setop = @clauses[0..$idx-1];
  47       splice(@clauses, $idx, 0, qw(setop group_by having));
  48       last CLAUSE;
  49     }
  50   }
  51
  52   die "Huh?" unless @before_setop;
  53   $sqla->clauses_of(select => @clauses);
  54
  55   $sqla->clauses_of(update => sub {
  56     my ($self, @clauses) = @_;
  57     splice(@clauses, 2, 0, 'from');
  58     @clauses;
  59   });
  60
  61   $sqla->clauses_of(delete => sub {
  62     my ($self, @clauses) = @_;
  63     splice(@clauses, 1, 0, 'using');
  64     @clauses;
  65   });
  66
  67   $self->register(
  68     (map +(
  69       "${_}er" => [
  70         do {
  71           my $x = $_;
  72           (map +($_ => "_${x}_${_}"), qw(join from_list alias))
  73         }
  74        ]
  75     ), qw(expand render)),
  76     binop_expander => [ as => '_expand_op_as' ],
  77     renderer => [ as => '_render_as' ],
  78     expander => [ cast => '_expand_cast' ],
  79     clause_expanders => [
  80       "select.from", '_expand_from_list',
  81       'select.group_by'
  82         => sub { $_[0]->expand_expr({ -list => $_[2] }, -ident) },
  83       'select.having'
  84         => sub { $_[0]->expand_expr($_[2]) },
  85       'update.from' => '_expand_from_list',
  86       "update.target", '_expand_update_clause_target',
  87       "update.update", '_expand_update_clause_target',
  88       'delete.using' => '_expand_from_list',
  89       'insert.rowvalues' => sub {
  90         +(from => $_[0]->expand_expr({ -values => $_[2] }));
  91       },
  92       'insert.select' => sub {
  93         +(from => $_[0]->expand_expr({ -select => $_[2] }));
  94       },
  95     ],
  96   );
  97
  98   # set ops
  99   $sqla->wrap_expander(select => sub {
 100     $self->cb('_expand_select', $_[0], \@before_setop);
 101   });
 102
 103   $self->register(
 104     clause_renderer => [
 105       'select.setop' => sub { $_[0]->render_aqt($_[2]) }
 106     ],
 107     expander => [ map +($_ => '_expand_setop'), qw(union intersect except) ],
 108     renderer => [ map +($_ => '_render_setop'), qw(union intersect except) ],
 109   );
 110
 111   my $setop_expander = $self->cb('_expand_clause_setop');
 112
 113   $sqla->clause_expanders(
 114     map +($_ => $setop_expander),
 115       map "select.${_}",
 116         map +($_, "${_}_all", "${_}_distinct"),
 117           qw(union intersect except)
 118   );
 119
 120   foreach my $stmt (qw(select insert update delete)) {
 121     $sqla->clauses_of($stmt => 'with', $sqla->clauses_of($stmt));
 122     $self->register(
 123       clause_expanders => [
 124         "${stmt}.with" => '_expand_with',
 125         "${stmt}.with_recursive" => '_expand_with',
 126       ],
 127       clause_renderer => [ "${stmt}.with" => '_render_with' ],
 128     );
 129   }
 130
 131   return $sqla;
 132 }
 133
 134 sub _expand_select {
 135   my ($self, $orig, $before_setop, @args) = @_;
 136   my $exp = $self->sqla->$orig(@args);
 137   return $exp unless my $setop = (my $sel = $exp->{-select})->{setop};
 138   if (my @keys = grep $sel->{$_}, @$before_setop) {
 139     my %inner; @inner{@keys} = delete @{$sel}{@keys};
 140     unshift @{(values(%$setop))[0]{queries}},
 141       { -select => \%inner };
 142   }
 143   return $exp;
 144 }
 145
 146 sub _expand_from_list {
 147   my ($self, undef, $args) = @_;
 148   if (ref($args) eq 'HASH') {
 149     return $args if $args->{-from_list};
 150     return { -from_list => [ $self->expand_expr($args) ] };
 151   }
 152   my @list;
 153   my @args = ref($args) eq 'ARRAY' ? @$args : ($args);
 154   while (my $entry = shift @args) {
 155     if (!ref($entry) and $entry =~ /^-(.*)/) {
 156       if ($1 eq 'as') {
 157         $list[-1] = $self->expand_expr({ -as => [
 158           $list[-1], map +(ref($_) eq 'ARRAY' ? @$_ : $_), shift(@args)
 159         ]});
 160         next;
 161       }
 162       $entry = { $entry => shift @args };
 163     }
 164     my $aqt = $self->expand_expr($entry, -ident);
 165     if ($aqt->{-join} and not $aqt->{-join}{from}) {
 166       $aqt->{-join}{from} = pop @list;
 167     }
 168     push @list, $aqt;
 169   }
 170   return $list[0] if @list == 1;
 171   return { -from_list => \@list };
 172 }
 173
 174 sub _expand_join {
 175   my ($self, undef, $args) = @_;
 176   my %proto = (
 177     ref($args) eq 'HASH'
 178       ? %$args
 179       : (to => @$args)
 180   );
 181   if (my $as = delete $proto{as}) {
 182     $proto{to} = $self->expand_expr(
 183                    { -as => [ { -from_list => $proto{to} }, $as ] }
 184                  );
 185   }
 186   if (defined($proto{using}) and ref(my $using = $proto{using}) ne 'HASH') {
 187     $proto{using} = [
 188       map [ $self->expand_expr($_, -ident) ],
 189         ref($using) eq 'ARRAY' ? @$using: $using
 190     ];
 191   }
 192   my %ret = (
 193     type => delete $proto{type},
 194     to => $self->expand_expr({ -from_list => delete $proto{to} }, -ident)
 195   );
 196   %ret = (%ret,
 197     map +($_ => $self->expand_expr($proto{$_}, -ident)),
 198       sort keys %proto
 199   );
 200   return +{ -join => \%ret };
 201 }
 202
 203 sub _render_from_list {
 204   my ($self, undef, $list) = @_;
 205   return $self->join_query_parts(', ', @$list);
 206 }
 207
 208 sub _render_join {
 209   my ($self, undef, $args) = @_;
 210
 211   my @parts = (
 212     $args->{from},
 213     { -keyword => join '_', ($args->{type}||()), 'join' },
 214     (map +($_->{-ident} || $_->{-as}
 215       ? $_
 216       : ('(', $self->render_aqt($_, 1), ')')),
 217         map +(@{$_->{-from_list}||[]} == 1 ? $_->{-from_list}[0] : $_),
 218           $args->{to}
 219     ),
 220     ($args->{on} ? (
 221       { -keyword => 'on' },
 222       $args->{on},
 223     ) : ()),
 224     ($args->{using} ? (
 225       { -keyword => 'using' },
 226       '(', $args->{using}, ')',
 227     ) : ()),
 228   );
 229   return $self->join_query_parts(' ', @parts);
 230 }
 231
 232 sub _expand_op_as {
 233   my ($self, undef, $vv, $k) = @_;
 234   my @vv = (ref($vv) eq 'ARRAY' ? @$vv : $vv);
 235   my $ik = $self->expand_expr($k, -ident);
 236   return +{ -as => [ $ik, $self->expand_expr($vv[0], -ident) ] }
 237     if @vv == 1 and ref($vv[0]) eq 'HASH';
 238
 239   my @as = map $self->expand_expr($_, -ident), @vv;
 240   return { -as => [ $ik, $self->expand_expr({ -alias => \@as }) ] };
 241 }
 242
 243 sub _render_as {
 244   my ($self, undef, $args) = @_;
 245   my ($thing, $alias) = @$args;
 246   return $self->join_query_parts(
 247     ' ',
 248     $thing,
 249     { -keyword => 'as' },
 250     $alias,
 251   );
 252 }
 253
 254 sub _render_alias {
 255   my ($self, undef, $args) = @_;
 256   my ($as, @cols) = @$args;
 257   return (@cols
 258     ? $self->join_query_parts('',
 259          $as,
 260          '(',
 261          $self->join_query_parts(
 262            ', ',
 263            @cols
 264          ),
 265          ')',
 266       )
 267     : $self->render_aqt($as)
 268   );
 269 }
 270
 271 sub _expand_update_clause_target {
 272   my ($self, undef, $target) = @_;
 273   +(target => $self->_expand_from_list(undef, $target));
 274 }
 275
 276 sub _expand_cast {
 277   my ($self, undef, $thing) = @_;
 278   return { -func => [ cast => $thing ] } if ref($thing) eq 'HASH';
 279   my ($cast, $to) = @{$thing};
 280   +{ -func => [ cast => { -as => [
 281     $self->expand_expr($cast),
 282     $self->expand_expr($to, -ident),
 283   ] } ] };
 284 }
 285
 286 sub _expand_alias {
 287   my ($self, undef, $args) = @_;
 288   if (ref($args) eq 'HASH' and my $alias = $args->{-alias}) {
 289     $args = $alias;
 290   }
 291   my @parts = map $self->expand_expr($_, -ident),
 292                 ref($args) eq 'ARRAY' ? @{$args} : $args;
 293   return $parts[0] if @parts == 1;
 294   return { -alias => \@parts };
 295 }
 296
 297 sub _expand_with {
 298   my ($self, $name, $with) = @_;
 299   my (undef, $type) = split '_', $name;
 300   if (ref($with) eq 'HASH') {
 301     return +{
 302       %$with,
 303       queries => [
 304         map +[
 305           $self->expand_expr({ -alias => $_->[0] }, -ident),
 306           $self->expand_expr($_->[1]),
 307         ], @{$with->{queries}}
 308       ]
 309     }
 310   }
 311   my @with = @$with;
 312   my @exp;
 313   while (my ($alias, $query) = splice @with, 0, 2) {
 314     push @exp, [
 315       $self->expand_expr({ -alias => $alias }, -ident),
 316       $self->expand_expr($query)
 317     ];
 318   }
 319   return +(with => { ($type ? (type => $type) : ()), queries => \@exp });
 320 }
 321
 322 sub _render_with {
 323   my ($self, undef, $with) = @_;
 324   my $q_part = $self->join_query_parts(', ',
 325     map {
 326       my ($alias, $query) = @$_;
 327       $self->join_query_parts(' ',
 328           $alias,
 329           { -keyword => 'as' },
 330           $query,
 331       )
 332     } @{$with->{queries}}
 333   );
 334   return $self->join_query_parts(' ',
 335     { -keyword => join '_', 'with', ($with->{type}||'') },
 336     $q_part,
 337   );
 338 }
 339
 340 sub _expand_setop {
 341   my ($self, $setop, $args) = @_;
 342   +{ "-${setop}" => {
 343        %$args,
 344        queries => [ map $self->expand_expr($_), @{$args->{queries}} ],
 345   } };
 346 }
 347
 348 sub _render_setop {
 349   my ($self, $setop, $args) = @_;
 350   $self->join_query_parts(
 351     { -keyword => ' '.join('_', $setop, ($args->{type}||())).' ' },
 352     @{$args->{queries}}
 353   );
 354 }
 355
 356 sub _expand_clause_setop {
 357   my ($self, $setop, $args) = @_;
 358   my ($op, $type) = split '_', $setop;
 359   +(setop => $self->expand_expr({
 360     "-${op}" => {
 361       ($type ? (type => $type) : ()),
 362       queries => (ref($args) eq 'ARRAY' ? $args : [ $args ])
 363     }
 364   }));
 365 }
 366
 367 1;
 368
 369 __END__
 370
 371 =head1 NAME
 372
 373 SQL::Abstract::ExtraClauses - new/experimental additions to L<SQL::Abstract>
 374
 375 =head1 SYNOPSIS
 376
 377   my $sqla = SQL::Abstract->new;
 378   SQL::Abstract::ExtraClauses->apply_to($sqla);
 379
 380 =head1 WARNING
 381
 382 This module is basically a nursery for things that seem like a good idea
 383 to live in until we figure out if we were right about that.
 384
 385 =head1 METHODS
 386
 387 =head2 apply_to
 388
 389 Applies the plugin to an L<SQL::Abstract> object.
 390
 391 =head2 register_extensions
 392
 393 Registers the extensions described below
 394
 395 =head2 cb
 396
 397 For plugin authors, creates a callback to call a method on the plugin.
 398
 399 =head2 register
 400
 401 For plugin authors, registers callbacks more easily.
 402
 403 =head2 sqla
 404
 405 Available only during plugin callback executions, contains the currently
 406 active L<SQL::Abstract> object.
 407
 408 =head1 NODE TYPES
 409
 410 =head2 alias
 411
 412 Represents a table alias. Expands name and column names with ident as default.
 413
 414   # expr
 415   { -alias => [ 't', 'x', 'y', 'z' ] }
 416
 417   # aqt
 418   { -alias => [
 419       { -ident => [ 't' ] }, { -ident => [ 'x' ] },
 420       { -ident => [ 'y' ] }, { -ident => [ 'z' ] },
 421   ] }
 422
 423   # query
 424   t(x, y, z)
 425   []
 426
 427 =head2 as
 428
 429 Represents an sql AS. LHS is expanded with ident as default, RHS is treated
 430 as a list of arguments for the alias node.
 431
 432   # expr
 433   { foo => { -as => 'bar' } }
 434
 435   # aqt
 436   { -as => [ { -ident => [ 'foo' ] }, { -ident => [ 'bar' ] } ] }
 437
 438   # query
 439   foo AS bar
 440   []
 441
 442   # expr
 443   { -as => [ { -select => { _ => 'blah' } }, 't', 'blah' ] }
 444
 445   # aqt
 446   { -as => [
 447       { -select =>
 448           { select => { -op => [ ',', { -ident => [ 'blah' ] } ] } }
 449       },
 450       { -alias => [ { -ident => [ 't' ] }, { -ident => [ 'blah' ] } ] },
 451   ] }
 452
 453   # query
 454   (SELECT blah) AS t(blah)
 455   []
 456
 457 =head2 cast
 458
 459   # expr
 460   { -cast => [ { -ident => 'birthday' }, 'date' ] }
 461
 462   # aqt
 463   { -func => [
 464       'cast', {
 465         -as => [ { -ident => [ 'birthday' ] }, { -ident => [ 'date' ] } ]
 466       },
 467   ] }
 468
 469   # query
 470   CAST(birthday AS date)
 471   []
 472
 473 =head2 join
 474
 475 If given an arrayref, pretends it was given a hashref with the first
 476 element of the arrayref as the value for 'to' and the remaining pairs copied.
 477
 478 Given a hashref, the 'as' key is if presented expanded to wrap the 'to'.
 479
 480 If present the 'using' key is expanded as a list of idents.
 481
 482 Known keys are: 'from' (the left hand side), 'type' ('left', 'right', or
 483 nothing), 'to' (the right hand side), 'on' and 'using'.
 484
 485   # expr
 486   { -join => {
 487       from => 'lft',
 488       on => { 'lft.bloo' => { '>' => 'rgt.blee' } },
 489       to => 'rgt',
 490       type => 'left',
 491   } }
 492
 493   # aqt
 494   { -join => {
 495       from => { -ident => [ 'lft' ] },
 496       on => { -op => [
 497           '>', { -ident => [ 'lft', 'bloo' ] },
 498           { -ident => [ 'rgt', 'blee' ] },
 499       ] },
 500       to => { -ident => [ 'rgt' ] },
 501       type => 'left',
 502   } }
 503
 504   # query
 505   lft LEFT JOIN rgt ON lft.bloo > rgt.blee
 506   []
 507
 508 =head2 from_list
 509
 510 List of components of the FROM clause; -foo type elements indicate a pair
 511 with the next element; this is easiest if I show you:
 512
 513   # expr
 514   { -from_list => [
 515       't1', -as => 'table_one', -join =>
 516       [ 't2', 'on', { 'table_one.x' => 't2.x' } ],
 517   ] }
 518
 519   # aqt
 520   { -join => {
 521       from =>
 522         {
 523           -as => [ { -ident => [ 't1' ] }, { -ident => [ 'table_one' ] } ]
 524         },
 525       on => { -op => [
 526           '=', { -ident => [ 'table_one', 'x' ] },
 527           { -ident => [ 't2', 'x' ] },
 528       ] },
 529       to => { -ident => [ 't2' ] },
 530       type => undef,
 531   } }
 532
 533   # query
 534   t1 AS table_one JOIN t2 ON table_one.x = t2.x
 535   []
 536
 537 Or with using:
 538
 539   # expr
 540   { -from_list =>
 541       [ 't1', -as => 'table_one', -join => [ 't2', 'using', [ 'x' ] ] ]
 542   }
 543
 544   # aqt
 545   { -join => {
 546       from =>
 547         {
 548           -as => [ { -ident => [ 't1' ] }, { -ident => [ 'table_one' ] } ]
 549         },
 550       to => { -ident => [ 't2' ] },
 551       type => undef,
 552       using =>
 553         { -op => [ 'or', { -op => [ 'or', { -ident => [ 'x' ] } ] } ] },
 554   } }
 555
 556   # query
 557   t1 AS table_one JOIN t2 USING ( x )
 558   []
 559
 560 With oddities:
 561
 562   # expr
 563   { -from_list => [
 564       'x', -join =>
 565       [ [ 'y', -join => [ 'z', 'type', 'left' ] ], 'type', 'left' ],
 566   ] }
 567
 568   # aqt
 569   { -join => {
 570       from => { -ident => [ 'x' ] },
 571       to => { -join => {
 572           from => { -ident => [ 'y' ] },
 573           to => { -ident => [ 'z' ] },
 574           type => 'left',
 575       } },
 576       type => 'left',
 577   } }
 578
 579   # query
 580   x LEFT JOIN ( y LEFT JOIN z )
 581   []
 582
 583 =head1 STATEMENT EXTENSIONS
 584
 585 =head2 group by clause for select
 586
 587 Expanded as a list with an ident default:
 588
 589   # expr
 590   { -select => { group_by => [ 'foo', 'bar' ] } }
 591
 592   # aqt
 593   { -select => { group_by =>
 594         {
 595           -op => [ ',', { -ident => [ 'foo' ] }, { -ident => [ 'bar' ] } ]
 596         }
 597   } }
 598
 599   # query
 600   GROUP BY foo, bar
 601   []
 602
 603 =head2 having clause for select
 604
 605 Basic expr, just like where, given having is pretty much post-group-by
 606 where clause:
 607
 608   # expr
 609   { -select =>
 610       { having => { '>' => [ { -count => { -ident => 'foo' } }, 3 ] } }
 611   }
 612
 613   # aqt
 614   { -select => { having => { -op => [
 615           '>', { -func => [ 'count', { -ident => [ 'foo' ] } ] },
 616           { -bind => [ undef, 3 ] },
 617   ] } } }
 618
 619   # query
 620   HAVING COUNT(foo) > ?
 621   [ 3 ]
 622
 623 =cut