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