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