lib/SQL/Abstract/AST/v1.pm

   1 use MooseX::Declare;
   2
   3 class SQL::Abstract::AST::v1 extends SQL::Abstract {
   4
   5   use Carp qw/croak/;
   6   use Data::Dump qw/pp/;
   7
   8   use Moose::Util::TypeConstraints;
   9   use MooseX::Types::Moose qw/ArrayRef Str Int Ref HashRef/;
  10   use MooseX::AttributeHelpers;
  11   use SQL::Abstract::Types qw/AST/;
  12   use Devel::PartialDump qw/dump/;
  13
  14   clean;
  15
  16   # set things that are valid in where clauses
  17   override _build_expr_dispatch_table {
  18     return {
  19       %{super()},
  20       in => $self->can('_in'),
  21       not_in => $self->can('_in'),
  22       and => $self->can('_recurse_where'),
  23       or => $self->can('_recurse_where'),
  24       map { +"$_" => $self->can("_$_") } qw/
  25         value
  26         name
  27         true
  28         false
  29         expr
  30       /
  31     };
  32   }
  33
  34   method _select(AST $ast) {
  35     # Default to requiring columns and from.
  36     # DB specific ones (i.e. mysql/Pg) can not require the FROM part with a bit
  37     # of refactoring
  38
  39     for (qw/columns tablespec/) {
  40       confess "'$_' is required in select AST with " . dump ($ast)
  41         unless exists $ast->{$_};
  42     }
  43
  44     # Check that columns is a -list
  45     confess "'columns' should be an array ref, not " . dump($ast->{columns})
  46       unless is_ArrayRef($ast->{columns});
  47
  48     my $cols = $self->_list({-type => 'list', args => $ast->{columns} });
  49
  50     my @output = (
  51       SELECT => $cols
  52     );
  53
  54     push @output, FROM => $self->dispatch($ast->{tablespec})
  55       if exists $ast->{tablespec};
  56
  57     if (exists $ast->{where}) {
  58       my $sub_ast = $ast->{where};
  59
  60       confess "$_ option is not an AST: " . dump($sub_ast)
  61         unless is_AST($sub_ast);
  62
  63       push @output, "WHERE", $self->_expr($sub_ast);
  64     }
  65
  66     for (qw/group_by having order_by/) {
  67       if (exists $ast->{$_}) {
  68         my $sub_ast = $ast->{$_};
  69
  70         confess "$_ option is not an AST or an ArrayRef: " . dump($sub_ast)
  71           unless is_AST($sub_ast) || is_ArrayRef($sub_ast);;
  72
  73         my $meth = "__$_";
  74         push @output, $self->$meth($sub_ast);
  75       }
  76     }
  77
  78     return join(' ', @output);
  79   }
  80
  81   method _join(HashRef $ast) {
  82
  83     # TODO: Validate join type
  84     my $type = $ast->{join_type} || "";
  85
  86     my @output = $self->dispatch($ast->{lhs});
  87
  88     push @output, uc $type if $type;
  89     push @output, "JOIN", $self->dispatch($ast->{rhs});
  90
  91     push @output,
  92         exists $ast->{on}
  93       ? ('ON', '(' . $self->_expr( $ast->{on} ) . ')' )
  94       : ('USING', '(' .$self->dispatch($ast->{using}
  95                         || croak "No 'on' or 'uinsg' clause passed to join cluase: " .
  96                                  dump($ast)
  97                         ) .
  98                   ')' );
  99
 100     return join(" ", @output);
 101
 102   }
 103
 104   method _ordering(AST $ast) {
 105
 106     my $output = $self->_expr($ast->{expr});
 107
 108     $output .= " " . uc $1
 109       if $ast->{direction} &&
 110          ( $ast->{direction} =~ /^(asc|desc)$/i
 111            || confess "Unknown ordering direction " . dump($ast)
 112          );
 113
 114     return $output;
 115   }
 116
 117   method _name(AST $ast) {
 118     my @names = @{$ast->{args}};
 119
 120     my $sep = $self->name_separator;
 121     my $quote = $self->is_quoting
 122               ? $self->quote_chars
 123               : [ '' ];
 124
 125     my $join = $quote->[-1] . $sep . $quote->[0];
 126
 127     # We dont want to quote * in [qw/me */]: `me`.* is the desired output there
 128     # This means you can't have a field called `*`. I am willing to accept this
 129     # situation, cos thats a really stupid thing to want.
 130     my $post;
 131     $post = pop @names if $names[-1] eq '*';
 132
 133     my $ret;
 134     $ret = $quote->[0] .
 135            join( $join, @names ) .
 136            $quote->[-1]
 137       if @names;
 138
 139     $ret = $ret
 140          ? $ret . $sep . $post
 141          : $post
 142       if defined $post;
 143
 144
 145     return $ret;
 146   }
 147
 148
 149   method _list(AST $ast) {
 150     my @items = is_ArrayRef($ast->{args})
 151               ? @{$ast->{args}}
 152               : $ast->{args};
 153
 154     return join(
 155       $self->list_separator,
 156       map { $self->dispatch($_) } @items);
 157   }
 158
 159   # TODO: I think i want to parameterized AST type to get better validation
 160   method _alias(AST $ast) {
 161
 162     # TODO: Maybe we want qq{ AS "$as"} here
 163     return $self->dispatch($ast->{ident}) . " AS " . $ast->{as};
 164
 165   }
 166
 167   method _value(AST $ast) {
 168
 169     $self->add_bind($ast->{value});
 170     return "?";
 171   }
 172
 173   # Not dispatchable to.
 174   method __having($args) {
 175     return "HAVING " . $self->_list({-type => 'list', args => $args});
 176   }
 177
 178   method __group_by($args) {
 179     return "GROUP BY " . $self->_list({-type => 'list', args => $args});
 180   }
 181
 182   method __order_by($args) {
 183     return "ORDER BY " . $self->_list({-type => 'list', args => $args});
 184   }
 185
 186
 187   # Perhaps badly named. handles 'and' and 'or' clauses
 188   method _recurse_where(AST $ast) {
 189
 190     my $op = $ast->{op};
 191
 192     my $OP = uc $op;
 193     my $prio = $SQL::Abstract::PRIO{$op};
 194
 195     my $dispatch_table = $self->expr_dispatch_table;
 196
 197     my @output;
 198     foreach ( @{$ast->{args}} ) {
 199       croak "invalid component in where clause: $_" unless is_AST($_);
 200
 201       if ($_->{-type} eq 'expr' && $_->{op} =~ /^(and|or)$/) {
 202         my $sub_prio = $SQL::Abstract::PRIO{$1};
 203
 204         if ($sub_prio <= $prio) {
 205           push @output, $self->_recurse_where($_);
 206         } else {
 207           push @output, '(' . $self->_recurse_where($_) . ')';
 208         }
 209       } else {
 210         push @output, $self->_expr($_);
 211       }
 212     }
 213
 214     return join(" $OP ", @output);
 215   }
 216
 217   method _expr(AST $ast) {
 218     my $op = $ast->{-type};
 219
 220     $op = $ast->{op} if $op eq 'expr';
 221
 222     if (my $code = $self->lookup_expr_dispatch($op)) {
 223
 224       return $code->($self, $ast);
 225
 226     }
 227     croak "'$op' is not a valid AST type in an expression with " . dump($ast)
 228       if $ast->{-type} ne 'expr';
 229
 230     croak "'$op' is not a valid operator in an expression with " . dump($ast);
 231
 232   }
 233
 234   method _binop(AST $ast) {
 235     my ($lhs, $rhs) = @{$ast->{args}};
 236     my $op = $ast->{op};
 237
 238     join (' ', $self->_expr($lhs),
 239                $self->binop_mapping($op) || croak("Unknown binary operator $op"),
 240                $self->_expr($rhs)
 241     );
 242   }
 243
 244   method _in(AST $ast) {
 245
 246     my ($field,@values) = @{$ast->{args}};
 247
 248     my $not = ($ast->{op} =~ /^not_/) ? " NOT" : "";
 249
 250     return $self->_false unless @values;
 251
 252     return $self->_expr($field) .
 253            $not .
 254            " IN (" .
 255            join(", ", map { $self->dispatch($_) } @values ) .
 256            ")";
 257   }
 258
 259   method _generic_func(ArrayRef $ast) {
 260   }
 261
 262   # 'constants' that are portable across DBs
 263   method _false($ast?) { "0 = 1" }
 264   method _true($ast?) { "1 = 1" }
 265
 266 }