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
  32   }
  33
  34   method _where(ArrayAST $ast) {
  35     my (undef, @clauses) = @$ast;
  36
  37     return 'WHERE ' . $self->_recurse_where(\@clauses);
  38   }
  39
  40   method _order_by(ArrayAST $ast) {
  41     my (undef, @clauses) = @$ast;
  42
  43     my @output;
  44
  45     for (@clauses) {
  46       if ($_->[0] =~ /^-(asc|desc)$/) {
  47         my $o = $1;
  48         push @output, $self->dispatch($_->[1]) . " " . uc($o);
  49         next;
  50       }
  51       push @output, $self->dispatch($_);
  52     }
  53
  54     return "ORDER BY " . join(", ", @output);
  55   }
  56
  57   method _name(ArrayAST $ast) {
  58     my (undef, @names) = @$ast;
  59
  60     my $sep = $self->name_separator;
  61
  62     return $sep->[0] .
  63            join( $sep->[1] . $sep->[0], @names ) .
  64            $sep->[1]
  65               if (@$sep > 1);
  66
  67     return join($sep->[0], @names);
  68   }
  69
  70   method _join(HashAST $ast) {
  71
  72     my $output = 'JOIN ' . $self->dispatch($ast->{tablespec});
  73
  74     $output .= exists $ast->{on}
  75              ? ' ON (' . $self->_recurse_where( $ast->{on} )
  76              : ' USING (' .$self->dispatch($ast->{using} || croak "No 'on' or 'join' clause passed to -join");
  77
  78     $output .= ")";
  79     return $output;
  80
  81   }
  82
  83   method _list(ArrayAST $ast) {
  84     my (undef, @items) = @$ast;
  85
  86     return join(
  87       $self->list_separator,
  88       map { $self->dispatch($_) } @items);
  89   }
  90
  91   method _alias(ArrayAST $ast) {
  92     my (undef, $alias, $as) = @$ast;
  93
  94     return $self->dispatch($alias) . " AS $as";
  95
  96   }
  97
  98   method _value(ArrayAST $ast) {
  99     my ($undef, $value) = @$ast;
 100
 101     $self->add_bind($value);
 102     return "?";
 103   }
 104
 105   method _recurse_where(ArrayRef $clauses) {
 106
 107     my $OP = 'AND';
 108     my $prio = $SQL::Abstract::PRIO{and};
 109     my $first = $clauses->[0];
 110
 111     if (!ref $first) {
 112       if ($first =~ /^-(and|or)$/) {
 113         $OP = uc($1);
 114         $prio = $SQL::Abstract::PRIO{$1};
 115         shift @$clauses;
 116       } else {
 117         # If first is not a ref, and its not -and or -or, then $clauses
 118         # contains just a single clause
 119         $clauses = [ $clauses ];
 120       }
 121     }
 122
 123     my $dispatch_table = $self->where_dispatch_table;
 124
 125     my @output;
 126     foreach (@$clauses) {
 127       croak "invalid component in where clause: $_" unless is_ArrayRef($_);
 128       my $op = $_->[0];
 129
 130       if ($op =~ /^-(and|or)$/) {
 131         my $sub_prio = $SQL::Abstract::PRIO{$1};
 132
 133         if ($sub_prio <= $prio) {
 134           push @output, $self->_recurse_where($_);
 135         } else {
 136           push @output, '(' . $self->_recurse_where($_) . ')';
 137         }
 138       } else {
 139         push @output, $self->_where_component($_);
 140       }
 141     }
 142
 143     return join(" $OP ", @output);
 144   }
 145
 146   method _where_component(ArrayRef $ast) {
 147     my $op = $ast->[0];
 148
 149     if (my $code = $self->lookup_where_dispatch($op)) {
 150
 151       return $code->($self, $ast);
 152
 153     }
 154     croak "'$op' is not a valid clause in a where AST"
 155       if $op =~ /^-/;
 156
 157     croak "'$op' is not a valid operator";
 158
 159   }
 160
 161
 162   method _binop(ArrayRef $ast) {
 163     my ($op, $lhs, $rhs) = @$ast;
 164
 165     join (' ', $self->_where_component($lhs),
 166                $self->binop_mapping($op) || croak("Unknown binary operator $op"),
 167                $self->_where_component($rhs)
 168     );
 169   }
 170
 171   method _in(ArrayAST $ast) {
 172     my ($tag, $field, @values) = @$ast;
 173
 174     my $not = $tag =~ /^-not/ ? " NOT" : "";
 175
 176     return $self->_false if @values == 0;
 177     return $self->_where_component($field) .
 178            $not.
 179            " IN (" .
 180            join(", ", map { $self->dispatch($_) } @values ) .
 181            ")";
 182   }
 183
 184   method _generic_func(ArrayRef $ast) {
 185   }
 186
 187   # 'constants' that are portable across DBs
 188   method _false($ast?) { "0 = 1" }
 189   method _true($ast?) { "1 = 1" }
 190
 191 }