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