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(ArrayAST $ast) {
  70     my (undef, @clauses) = @$ast;
  71
  72     my @output;
  73
  74     for (@clauses) {
  75       if ($_->[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(ArrayAST $ast) {
  87     my (undef, @names) = @$ast;
  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(ArrayAST $ast) {
 125     my (undef, @items) = @$ast;
 126
 127     return join(
 128       $self->list_separator,
 129       map { $self->dispatch($_) } @items);
 130   }
 131
 132   method _alias(ArrayAST $ast) {
 133     my (undef, $alias, $as) = @$ast;
 134
 135     confess "Not enough paremeters to -alias"
 136       unless defined $as;
 137
 138     # TODO: Maybe we want qq{ AS "$as"} here
 139     return $self->dispatch($alias) . " AS $as";
 140
 141   }
 142
 143   method _value(ArrayAST $ast) {
 144     my ($undef, $value) = @$ast;
 145
 146     $self->add_bind($value);
 147     return "?";
 148   }
 149
 150   method _recurse_where(ArrayRef $clauses) {
 151
 152     my $OP = 'AND';
 153     my $prio = $SQL::Abstract::PRIO{and};
 154     my $first = $clauses->[0];
 155
 156     if (!ref $first) {
 157       if ($first =~ /^-(and|or)$/) {
 158         $OP = uc($1);
 159         $prio = $SQL::Abstract::PRIO{$1};
 160         shift @$clauses;
 161       } else {
 162         # If first is not a ref, and its not -and or -or, then $clauses
 163         # contains just a single clause
 164         $clauses = [ $clauses ];
 165       }
 166     }
 167
 168     my $dispatch_table = $self->where_dispatch_table;
 169
 170     my @output;
 171     foreach (@$clauses) {
 172       croak "invalid component in where clause: $_" unless is_ArrayRef($_);
 173       my $op = $_->[0];
 174
 175       if ($op =~ /^-(and|or)$/) {
 176         my $sub_prio = $SQL::Abstract::PRIO{$1};
 177
 178         if ($sub_prio <= $prio) {
 179           push @output, $self->_recurse_where($_);
 180         } else {
 181           push @output, '(' . $self->_recurse_where($_) . ')';
 182         }
 183       } else {
 184         push @output, $self->_where_component($_);
 185       }
 186     }
 187
 188     return join(" $OP ", @output);
 189   }
 190
 191   method _where_component(ArrayRef $ast) {
 192     my $op = $ast->[0];
 193
 194     if (my $code = $self->lookup_where_dispatch($op)) {
 195
 196       return $code->($self, $ast);
 197
 198     }
 199     croak "'$op' is not a valid clause in a where AST"
 200       if $op =~ /^-/;
 201
 202     croak "'$op' is not a valid operator";
 203
 204   }
 205
 206
 207   method _binop(ArrayRef $ast) {
 208     my ($op, $lhs, $rhs) = @$ast;
 209
 210     join (' ', $self->_where_component($lhs),
 211                $self->binop_mapping($op) || croak("Unknown binary operator $op"),
 212                $self->_where_component($rhs)
 213     );
 214   }
 215
 216   method _in(ArrayAST $ast) {
 217     my ($tag, $field, @values) = @$ast;
 218
 219     my $not = $tag =~ /^-not/ ? " NOT" : "";
 220
 221     return $self->_false if @values == 0;
 222     return $self->_where_component($field) .
 223            $not.
 224            " IN (" .
 225            join(", ", map { $self->dispatch($_) } @values ) .
 226            ")";
 227   }
 228
 229   method _generic_func(ArrayRef $ast) {
 230   }
 231
 232   # 'constants' that are portable across DBs
 233   method _false($ast?) { "0 = 1" }
 234   method _true($ast?) { "1 = 1" }
 235
 236 }