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