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