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 ArrayAST HashAST/;
  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(HashAST $ast) {
  35     # Default to requiring columns and from
  36     # Once TCs give better errors, make this a SelectAST type
  37     for (qw/columns from/) {
  38       confess "$_ key is required (and must be an AST) to select"
  39         unless is_ArrayAST($ast->{$_});
  40     }
  41
  42     # Check that columns is a -list
  43     confess "columns key should be a -list AST, not " . $ast->{columns}[0]
  44       unless $ast->{columns}[0] eq '-list';
  45
  46     my @output = (
  47       "SELECT",
  48       $self->dispatch($ast->{columns}),
  49       "FROM",
  50       $self->dispatch($ast->{from})
  51     );
  52
  53     for (qw/join/) {
  54       if (exists $ast->{$_}) {
  55         my $sub_ast = $ast->{$_};
  56         $sub_ast->{-type} = "$_" if is_HashRef($sub_ast);
  57         confess "$_ option is not an AST"
  58           unless is_AST($sub_ast);
  59
  60         push @output, $self->dispatch($sub_ast);
  61       }
  62     }
  63
  64     return join(' ', @output);
  65   }
  66
  67   method _where(ArrayAST $ast) {
  68     my (undef, @clauses) = @$ast;
  69
  70     return 'WHERE ' . $self->_recurse_where(\@clauses);
  71   }
  72
  73   method _order_by(AST $ast) {
  74     my @clauses = @{$ast->{order_by}};
  75
  76     my @output;
  77
  78     for (@clauses) {
  79       if (is_ArrayRef($_) && $_->[0] =~ /^-(asc|desc)$/) {
  80         my $o = $1;
  81         push @output, $self->dispatch($_->[1]) . " " . uc($o);
  82         next;
  83       }
  84       push @output, $self->dispatch($_);
  85     }
  86
  87     return "ORDER BY " . join(", ", @output);
  88   }
  89
  90   method _name(AST $ast) {
  91     my @names = @{$ast->{args}};
  92
  93     my $sep = $self->name_separator;
  94     my $quote = $self->is_quoting
  95               ? $self->quote_chars
  96               : [ '' ];
  97
  98     my $join = $quote->[-1] . $sep . $quote->[0];
  99
 100     # We dont want to quote * in [qw/me */]: `me`.* is the desired output there
 101     # This means you can't have a field called `*`. I am willing to accept this
 102     # situation, cos thats a really stupid thing to want.
 103     my $post;
 104     $post = pop @names if $names[-1] eq '*';
 105
 106     my $ret =
 107       $quote->[0] .
 108       join( $join, @names ) .
 109       $quote->[-1];
 110
 111     $ret .= $sep . $post if defined $post;
 112     return $ret;
 113   }
 114
 115   method _join(HashRef $ast) {
 116
 117     my $output = 'JOIN ' . $self->dispatch($ast->{tablespec});
 118
 119     $output .= exists $ast->{on}
 120              ? ' ON (' . $self->_recurse_where( $ast->{on} )
 121              : ' USING (' .$self->dispatch($ast->{using} || croak "No 'on' or 'join' clause passed to -join");
 122
 123     $output .= ")";
 124     return $output;
 125
 126   }
 127
 128   method _list(AST $ast) {
 129     my @items = @{$ast->{args}};
 130
 131     return join(
 132       $self->list_separator,
 133       map { $self->dispatch($_) } @items);
 134   }
 135
 136   method _alias(AST $ast) {
 137
 138     # TODO: Maybe we want qq{ AS "$as"} here
 139     return $self->dispatch($ast->{ident}) . " AS " . $ast->{as};
 140
 141   }
 142
 143   method _value(HashAST $ast) {
 144
 145     $self->add_bind($ast->{value});
 146     return "?";
 147   }
 148
 149   # Perhaps badly named. handles 'and' and 'or' clauses
 150   method _recurse_where(HashAST $ast) {
 151
 152     my $op = $ast->{op};
 153
 154     my $OP = uc $op;
 155     my $prio = $SQL::Abstract::PRIO{$op};
 156
 157     my $dispatch_table = $self->expr_dispatch_table;
 158
 159     my @output;
 160     foreach ( @{$ast->{args}} ) {
 161       croak "invalid component in where clause: $_" unless is_HashAST($_);
 162
 163       if ($_->{-type} eq 'expr' && $_->{op} =~ /^(and|or)$/) {
 164         my $sub_prio = $SQL::Abstract::PRIO{$1};
 165
 166         if ($sub_prio <= $prio) {
 167           push @output, $self->_recurse_where($_);
 168         } else {
 169           push @output, '(' . $self->_recurse_where($_) . ')';
 170         }
 171       } else {
 172         push @output, $self->_expr($_);
 173       }
 174     }
 175
 176     return join(" $OP ", @output);
 177   }
 178
 179   method _expr(HashAST $ast) {
 180     my $op = $ast->{-type};
 181
 182     $op = $ast->{op} if $op eq 'expr';
 183
 184     if (my $code = $self->lookup_expr_dispatch($op)) {
 185
 186       return $code->($self, $ast);
 187
 188     }
 189     croak "'$op' is not a valid AST type in an expression with " . dump($ast)
 190       if $ast->{-type} ne 'expr';
 191
 192     croak "'$op' is not a valid operator in an expression with " . dump($ast);
 193
 194   }
 195
 196   method _binop(HashAST $ast) {
 197     my ($lhs, $rhs) = @{$ast->{args}};
 198     my $op = $ast->{op};
 199
 200     join (' ', $self->_expr($lhs),
 201                $self->binop_mapping($op) || croak("Unknown binary operator $op"),
 202                $self->_expr($rhs)
 203     );
 204   }
 205
 206   method _in(HashAST $ast) {
 207
 208     my ($field,@values) = @{$ast->{args}};
 209
 210     my $not = ($ast->{op} =~ /^not_/) ? " NOT" : "";
 211
 212     return $self->_false unless @values;
 213
 214     return $self->_expr($field) .
 215            $not .
 216            " IN (" .
 217            join(", ", map { $self->dispatch($_) } @values ) .
 218            ")";
 219   }
 220
 221   method _generic_func(ArrayRef $ast) {
 222   }
 223
 224   # 'constants' that are portable across DBs
 225   method _false($ast?) { "0 = 1" }
 226   method _true($ast?) { "1 = 1" }
 227
 228 }