lib/SQL/Abstract.pm

   1 use MooseX::Declare;
   2 use MooseX::Method::Signatures;
   3
   4
   5 class SQL::Abstract {
   6
   7   use Carp qw/croak/;
   8   use Data::Dump qw/pp/;
   9
  10   use Moose::Util::TypeConstraints;
  11   use MooseX::Types -declare => [qw/NameSeparator/];
  12   use MooseX::Types::Moose qw/ArrayRef Str Int/;
  13   use MooseX::AttributeHelpers;
  14
  15   clean;
  16
  17   subtype NameSeparator,
  18     as ArrayRef[Str];
  19     #where { @$_ == 1 ||| @$_ == 2 },
  20     #message { "Name separator must be one or two elements" };
  21
  22   coerce NameSeparator, from Str, via { [ $_ ] };
  23
  24   our $VERSION = '2.000000';
  25
  26   our $AST_VERSION = '1';
  27
  28   # Operator precedence for bracketing
  29   our %PRIO = (
  30     and => 10,
  31     or  => 50
  32   );
  33
  34   our %OP_MAP = (
  35     '>' => '>',
  36     '<' => '<',
  37     '==' => '=',
  38     '!=' => '!=',
  39   );
  40
  41   has ast_version => (
  42     is => 'ro',
  43     isa => Int,
  44     required => 1
  45   );
  46
  47   has name_separator => (
  48     is => 'rw',
  49     isa => NameSeparator,
  50     default => sub { ['.'] },
  51     coerece => 1,
  52     required => 1,
  53   );
  54
  55   has list_separator => (
  56     is => 'rw',
  57     isa => Str,
  58     default => ', ',
  59     required => 1,
  60   );
  61
  62   has binds => (
  63     isa => ArrayRef,
  64     is => 'ro',
  65     default => sub { [ ] },
  66     metaclass => 'Collection::Array',
  67     provides => {
  68       push => 'add_bind',
  69       clear => '_clear_binds',
  70     }
  71   );
  72
  73   method BUILD( $ast ) {
  74     croak "AST version @{[$self->ast_version]} is greater than supported version of $AST_VERSION"
  75       if $self->ast_version > $AST_VERSION;
  76   }
  77
  78   # Main entry point
  79   method generate(ClassName $class: ArrayRef $ast) {
  80     croak "SQL::Abstract AST version not specified"
  81       unless ($ast->[0] eq '-ast_version');
  82
  83     my (undef, $ver) = splice(@$ast, 0, 2);
  84
  85     my $self = $class->new(ast_version => $ver);
  86
  87     return ($self->dispatch($ast), $self->binds);
  88   }
  89
  90   method dispatch (ArrayRef $ast) {
  91
  92     local $_ = $ast->[0];
  93     s/^-/_/g or croak "Unknown type tag '$_'";
  94     my $meth = $self->can($_) || \&_generic_func;
  95     return $meth->($self, $ast);
  96   }
  97
  98   method _select(ArrayRef $ast) {
  99
 100   }
 101
 102   method _where(ArrayRef $ast) {
 103     my (undef, @clauses) = @$ast;
 104
 105     return 'WHERE ' . $self->_recurse_where(\@clauses);
 106   }
 107
 108   method _order_by(ArrayRef $ast) {
 109     my (undef, @clauses) = @$ast;
 110
 111     my @output;
 112
 113     for (@clauses) {
 114       if ($_->[0] =~ /^-(asc|desc)$/) {
 115         my $o = $1;
 116         push @output, $self->dispatch($_->[1]) . " " . uc($o);
 117         next;
 118       }
 119       push @output, $self->dispatch($_);
 120     }
 121
 122     return "ORDER BY " . join(", ", @output);
 123   }
 124
 125   method _name(ArrayRef $ast) {
 126     my (undef, @names) = @$ast;
 127
 128     my $sep = $self->name_separator;
 129
 130     return $sep->[0] .
 131            join( $sep->[1] . $sep->[0], @names ) .
 132            $sep->[1]
 133               if (@$sep > 1);
 134
 135     return join($sep->[0], @names);
 136   }
 137
 138   method _join(ArrayRef $ast) {
 139
 140   }
 141
 142   method _list(ArrayRef $ast) {
 143     my (undef, @items) = @$ast;
 144
 145     return join(
 146       $self->list_separator,
 147       map { $self->dispatch($_) } @items);
 148   }
 149
 150   method _alias(ArrayRef $ast) {
 151     my (undef, $alias, $as) = @$ast;
 152
 153     return $self->dispatch($alias) . " AS $as";
 154
 155   }
 156
 157   method _value(ArrayRef $ast) {
 158     my ($undef, $value) = @$ast;
 159
 160     $self->add_bind($value);
 161     return "?";
 162   }
 163
 164   method _recurse_where($clauses) {
 165
 166     my $OP = 'AND';
 167     my $prio = $PRIO{and};
 168     my $first = $clauses->[0];
 169
 170     if (!ref $first && $first =~ /^-(and|or)$/) {
 171       $OP = uc($1);
 172       $prio = $PRIO{$1};
 173       shift @$clauses;
 174     }
 175
 176     my @output;
 177     foreach (@$clauses) {
 178       croak "invalid component in where clause" unless ArrayRef->check($_);
 179       my $op = $_->[0];
 180
 181       unless (substr($op, 0, 1) eq '-') {
 182         # A simple comparison op (==, >, etc.)
 183
 184         push @output, $self->_binop(@$_);
 185
 186       } elsif ($op =~ /^-(and|or)$/) {
 187         my $sub_prio = $PRIO{$1};
 188
 189         if ($sub_prio <= $prio) {
 190           push @output, $self->_recurse_where($_);
 191         } else {
 192           push @output, '(' . $self->_recurse_where($_) . ')';
 193         }
 194       } else {
 195         push @output, $self->dispatch($_);
 196       }
 197     }
 198
 199     return join(" $OP ", @output);
 200   }
 201
 202   method _binop($op, $lhs, $rhs) {
 203     join (' ', $self->dispatch($lhs),
 204                $OP_MAP{$op} || croak("Unknown binary operator $op"),
 205                $self->dispatch($rhs)
 206     );
 207   }
 208
 209   method _in($ast) {
 210     my (undef, $field, @values) = @$ast;
 211
 212     return $self->dispatch($field) .
 213            " IN (" .
 214            join(", ", map { $self->dispatch($_) } @values ) .
 215            ")";
 216   }
 217
 218   method _generic_func(ArrayRef $ast) {
 219   }
 220
 221
 222 };