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