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 new {
  12   my ($proto, @args) = @_;
  13   my $new = $proto->next::method(@args);
  14   $new->{clauses_of}{select} = [
  15     @{$new->{clauses_of}{select}}, qw(group_by having)
  16   ];
  17   $new->{expand_clause}{'select.group_by'} = sub {
  18     $_[0]->_expand_maybe_list_expr($_[1], -ident)
  19   };
  20   $new->{expand_clause}{'select.having'} = sub {
  21     $_[0]->expand_expr($_[1])
  22   };
  23   $new->{expand}{from_list} = '_expand_from_list';
  24   $new->{render}{from_list} = '_render_from_list';
  25   $new->{expand}{join} = '_expand_join';
  26   $new->{render}{join} = '_render_join';
  27   return $new;
  28 }
  29
  30 sub _expand_select_clause_from {
  31   my ($self, $from) = @_;
  32   +(from => $self->_expand_from_list(undef, $from));
  33 }
  34
  35 sub _expand_from_list {
  36   my ($self, undef, $args) = @_;
  37   if (ref($args) eq 'HASH') {
  38     return { -from_list => [ $self->expand_expr($args) ] };
  39   }
  40   my @list;
  41   my @args = ref($args) ? @$args : ($args);
  42   while (my $entry = shift @args) {
  43     if (!ref($entry) and $entry =~ /^-/) {
  44       $entry = { $entry => shift @args };
  45     }
  46     my $aqt = $self->expand_expr($entry, -ident);
  47     if ($aqt->{-join} and not $aqt->{-join}{from}) {
  48       $aqt->{-join}{from} = pop @list;
  49     }
  50     push @list, $aqt;
  51   }
  52   return { -from_list => \@list };
  53 }
  54
  55 sub _expand_join {
  56   my ($self, undef, $args) = @_;
  57   my %proto = (
  58     ref($args) eq 'HASH'
  59       ? %$args
  60       : (to => $args->[0], @{$args}[1..$#$args])
  61   );
  62   my %ret = map +($_ => $self->expand_expr($proto{$_}, -ident)),
  63               sort keys %proto;
  64   return +{ -join => \%ret };
  65 }
  66
  67 sub _render_from_list {
  68   my ($self, $list) = @_;
  69   return $self->_join_parts(', ', map [ $self->render_aqt($_) ], @$list);
  70 }
  71
  72 sub _render_join {
  73   my ($self, $args) = @_;
  74
  75   my @parts = (
  76     [ $self->render_aqt($args->{from}) ],
  77     [ $self->_sqlcase(
  78         ($args->{type}
  79           ? join(' ', split '_', $args->{type}).' '
  80           : ''
  81         )
  82         .'join'
  83       )
  84     ],
  85     [ $self->render_aqt($args->{to}) ],
  86     ($args->{on} ? (
  87       [ $self->_sqlcase('on') ],
  88       [ $self->render_aqt($args->{on}) ],
  89     ) : ()),
  90     ($args->{using} ? (
  91       [ $self->_sqlcase('using') ],
  92       [ $self->render_aqt($args->{using}) ],
  93     ) : ()),
  94   );
  95   return $self->_join_parts(' ', @parts);
  96 }
  97
  98 1;