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