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/;
  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       between => $self->can('_between'),
  23       not_between => $self->can('_between'),
  24       and => $self->can('_recurse_where'),
  25       or => $self->can('_recurse_where'),
  26       map { +"$_" => $self->can("_$_") } qw/
  27         value
  28         identifier
  29         true
  30         false
  31         expr
  32       /
  33     };
  34   }
  35
  36   method _select(AST $ast) {
  37     # Default to requiring columns and from.
  38     # DB specific ones (i.e. mysql/Pg) can not require the FROM part with a bit
  39     # of refactoring
  40
  41     for (qw/columns tablespec/) {
  42       confess "'$_' is required in select AST with " . dump ($ast)
  43         unless exists $ast->{$_};
  44     }
  45
  46     # Check that columns is a -list
  47     confess "'columns' should be an array ref, not " . dump($ast->{columns})
  48       unless is_ArrayRef($ast->{columns});
  49
  50     my $cols = $self->_list({-type => 'list', args => $ast->{columns} });
  51
  52     my @output = (
  53       SELECT => $cols
  54     );
  55
  56     push @output, FROM => $self->dispatch($ast->{tablespec})
  57       if exists $ast->{tablespec};
  58
  59     if (exists $ast->{where}) {
  60       my $sub_ast = $ast->{where};
  61
  62       confess "$_ option is not an AST: " . dump($sub_ast)
  63         unless is_AST($sub_ast);
  64
  65       push @output, "WHERE", $self->_expr($sub_ast);
  66     }
  67
  68     for (qw/group_by having order_by/) {
  69       if (exists $ast->{$_}) {
  70         my $sub_ast = $ast->{$_};
  71
  72         confess "$_ option is not an AST or an ArrayRef: " . dump($sub_ast)
  73           unless is_AST($sub_ast) || is_ArrayRef($sub_ast);;
  74
  75         my $meth = "__$_";
  76         push @output, $self->$meth($sub_ast);
  77       }
  78     }
  79
  80     return join(' ', @output);
  81   }
  82
  83   method _update(AST $ast) {
  84
  85     for (qw/columns values tablespec/) {
  86       confess "'$_' is required in update AST with " . dump ($ast)
  87         unless exists $ast->{$_};
  88     }
  89
  90     my $table = $ast->{tablespec};
  91     confess 'update: tablespec must be an ident or an alias in ' . dump($ast)
  92       unless $table->{-type} =~ /^identifier|alias$/;
  93
  94     my @output = (
  95         'UPDATE',
  96         $self->dispatch($table),
  97         'SET'
  98     );
  99
 100     confess 'update: number of columns doesn\'t match values: ' . dump($ast)
 101       if @{$ast->{columns}} != @{$ast->{values}};
 102
 103     $DB::single = 1;
 104     my $list = {
 105       -type => 'list',
 106       args => [ map {
 107         { -type => 'expr',
 108           op => '==', # This should really be '=' but hmmmmmmmm
 109           args => [
 110             $ast->{columns}[$_],
 111             $ast->{values}[$_]
 112           ]
 113         }
 114       } 0..$#{$ast->{columns}} ]
 115     };
 116
 117     push @output, $self->dispatch($list);
 118
 119     return join(' ', @output);
 120
 121   }
 122
 123   method _join(HashRef $ast) {
 124
 125     # TODO: Validate join type
 126     my $type = $ast->{join_type} || "";
 127
 128     my @output = $self->dispatch($ast->{lhs});
 129
 130     push @output, uc $type if $type;
 131     push @output, "JOIN", $self->dispatch($ast->{rhs});
 132
 133     push @output,
 134         exists $ast->{on}
 135       ? ('ON', '(' . $self->_expr( $ast->{on} ) . ')' )
 136       : ('USING', '(' .$self->dispatch($ast->{using}
 137                         || croak "No 'on' or 'uinsg' clause passed to join cluase: " .
 138                                  dump($ast)
 139                         ) .
 140                   ')' );
 141
 142     return join(" ", @output);
 143
 144   }
 145
 146   method _ordering(AST $ast) {
 147
 148     my $output = $self->_expr($ast->{expr});
 149
 150     $output .= " " . uc $1
 151       if $ast->{direction} &&
 152          ( $ast->{direction} =~ /^(asc|desc)$/i
 153            || confess "Unknown ordering direction " . dump($ast)
 154          );
 155
 156     return $output;
 157   }
 158
 159   method _identifier(AST $ast) {
 160     my @names = @{$ast->{elements}};
 161
 162     my $sep = $self->ident_separator;
 163     my $quote = $self->is_quoting
 164               ? $self->quote_chars
 165               : [ '' ];
 166
 167     my $join = $quote->[-1] . $sep . $quote->[0];
 168
 169     # We dont want to quote * in [qw/me */]: `me`.* is the desired output there
 170     # This means you can't have a field called `*`. I am willing to accept this
 171     # situation, cos thats a really stupid thing to want.
 172     my $post;
 173     $post = pop @names if $names[-1] eq '*';
 174
 175     my $ret;
 176     $ret = $quote->[0] .
 177            join( $join, @names ) .
 178            $quote->[-1]
 179       if @names;
 180
 181     $ret = $ret
 182          ? $ret . $sep . $post
 183          : $post
 184       if defined $post;
 185
 186
 187     return $ret;
 188   }
 189
 190
 191   method _list(AST $ast) {
 192     return "" unless $ast->{args};
 193
 194     my @items = is_ArrayRef($ast->{args})
 195               ? @{$ast->{args}}
 196               : $ast->{args};
 197
 198     return join(
 199       $self->list_separator,
 200       map { $self->dispatch($_) } @items);
 201   }
 202
 203   # TODO: I think i want to parameterized AST type to get better validation
 204   method _alias(AST $ast) {
 205
 206     # TODO: Maybe we want qq{ AS "$as"} here
 207     return $self->dispatch($ast->{ident}) . " AS " . $ast->{as};
 208
 209   }
 210
 211   method _value(AST $ast) {
 212
 213     $self->add_bind($ast->{value});
 214     return "?";
 215   }
 216
 217   # Not dispatchable to.
 218   method __having($args) {
 219     return "HAVING " . $self->_list({-type => 'list', args => $args});
 220   }
 221
 222   method __group_by($args) {
 223     return "GROUP BY " . $self->_list({-type => 'list', args => $args});
 224   }
 225
 226   method __order_by($args) {
 227     return "ORDER BY " . $self->_list({-type => 'list', args => $args});
 228   }
 229
 230
 231   # Perhaps badly named. handles 'and' and 'or' clauses
 232   method _recurse_where(AST $ast) {
 233
 234     my $op = $ast->{op};
 235
 236     my $OP = uc $op;
 237     my $prio = $SQL::Abstract::PRIO{$op};
 238
 239     my $dispatch_table = $self->expr_dispatch_table;
 240
 241     my @output;
 242     foreach ( @{$ast->{args}} ) {
 243       croak "invalid component in where clause: $_" unless is_AST($_);
 244
 245       if ($_->{-type} eq 'expr' && $_->{op} =~ /^(and|or)$/) {
 246         my $sub_prio = $SQL::Abstract::PRIO{$1};
 247
 248         if ($sub_prio == $prio) {
 249           # When the element below has same priority, i.e. 'or' as a child of
 250           # 'or', dont produce extra brackets
 251           push @output, $self->_recurse_where($_);
 252         } else {
 253           push @output, '(' . $self->_recurse_where($_) . ')';
 254         }
 255       } else {
 256         push @output, $self->_expr($_);
 257       }
 258     }
 259
 260     return join(" $OP ", @output);
 261   }
 262
 263   method _expr(AST $ast) {
 264     my $op = $ast->{-type};
 265
 266     $op = $ast->{op} if $op eq 'expr';
 267
 268     if (my $code = $self->lookup_expr_dispatch($op)) {
 269
 270       return $code->($self, $ast);
 271
 272     }
 273     croak "'$op' is not a valid AST type in an expression with " . dump($ast)
 274       if $ast->{-type} ne 'expr';
 275
 276     # This is an attempt to do some form of validation on function names. This
 277     # might end up being a bad thing.
 278     croak "'$op' is not a valid operator in an expression with " . dump($ast)
 279       if $op =~ /\W/;
 280
 281     return $self->_generic_function_op($ast);
 282
 283   }
 284
 285   method _binop(AST $ast) {
 286     my ($lhs, $rhs) = @{$ast->{args}};
 287     my $op = $ast->{op};
 288
 289     # IS NOT? NULL
 290     if ($rhs->{-type} eq 'value' && !defined $rhs->{value} &&
 291         ($op eq '==' || $op eq '!='))
 292     {
 293       return $self->_expr($lhs) .
 294              ($op eq '==' ? " IS " : " IS NOT ") .
 295              "NULL";
 296     }
 297
 298     join (' ', $self->_expr($lhs),
 299                $self->binop_mapping($op) || croak("Unknown binary operator $op"),
 300                $self->_expr($rhs)
 301     );
 302   }
 303
 304   method _generic_function_op(AST $ast) {
 305     my $op = $ast->{op};
 306
 307     return "$op(" . $self->_list($ast) . ")";
 308   }
 309
 310   method _in(AST $ast) {
 311
 312     my ($field,@values) = @{$ast->{args}};
 313
 314     my $not = ($ast->{op} =~ /^not_/) ? " NOT" : "";
 315
 316     return $self->_false unless @values;
 317
 318     return $self->_expr($field) .
 319            $not .
 320            " IN (" .
 321            join(", ", map { $self->dispatch($_) } @values ) .
 322            ")";
 323   }
 324
 325   method _between(AST $ast) {
 326
 327     my ($field,@values) = @{$ast->{args}};
 328
 329     my $not = ($ast->{op} =~ /^not_/) ? " NOT" : "";
 330     croak "between requires 3 arguments: " . dump($ast)
 331       unless @values == 2;
 332
 333     # The brackets are to work round an issue with SQL::A::Test
 334     return "(" .
 335            $self->_expr($field) .
 336            $not .
 337            " BETWEEN " .
 338            join(" AND ", map { $self->dispatch($_) } @values ) .
 339            ")";
 340   }
 341
 342   # 'constants' that are portable across DBs
 343   method _false($ast?) { "0 = 1" }
 344   method _true($ast?) { "1 = 1" }
 345
 346 }