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