use MooseX::Declare;
-use MooseX::Method::Signatures;
class SQL::Abstract {
use Moose::Util::TypeConstraints;
use MooseX::Types -declare => [qw/NameSeparator/];
- use MooseX::Types::Moose qw/ArrayRef Str/;
+ use MooseX::Types::Moose qw/ArrayRef Str Int HashRef/;
use MooseX::AttributeHelpers;
- use namespace::clean -except => ['meta'];
+ clean;
subtype NameSeparator,
as ArrayRef[Str];
or => 50
);
- our %OP_MAP = (
+ our %BINOP_MAP = (
'>' => '>',
'<' => '<',
'==' => '=',
'!=' => '!=',
+ # LIKE is always "field LIKE <value>"
+ '-like' => 'IN',
+ '-not_like' => 'NOT LIKE',
+ );
+
+ has where_dispatch_table => (
+ is => 'ro',
+ lazy_build => 1,
+ );
+
+ has binop_map => (
+ is => 'ro',
+ lazy_build => 1,
+ isa => HashRef,
+ metaclass => 'Collection::ImmutableHash',
+ provides => {
+ exists => 'is_valid_binop',
+ get => 'binop_mapping',
+ keys => 'binary_operators'
+ }
+ );
+
+ sub _build_binop_map { return {%BINOP_MAP} };
+
+ method _build_where_dispatch_table {
+ my $binop = $self->can('_binop');
+ return {
+ map { $_ => $binop } $self->binary_operators
+ }
+ }
+
+ has ast_version => (
+ is => 'ro',
+ isa => Int,
+ required => 1
);
has name_separator => (
has binds => (
isa => ArrayRef,
+ is => 'ro',
+ clearer => '_clear_binds',
+ lazy => 1,
default => sub { [ ] },
metaclass => 'Collection::Array',
provides => {
push => 'add_bind',
- get => 'binds'
}
);
- method generate (Object|ClassName $self: ArrayRef $ast) {
- $self = $self->new unless blessed($self);
+ # TODO: once MXMS supports %args, use that here
+ method create(ClassName $class: Int $ver) {
+ croak "AST version $ver is greater than supported version of $AST_VERSION"
+ if $ver > $AST_VERSION;
- local $_ = $ast->[0];
- s/^-/_/ or croak "Unknown type tag '$_'";
- my $meth = $self->can($_) || \&_generic_func;
- return $meth->($self, $ast);
- }
+ my $name = "${class}::AST::v$ver";
+ Class::MOP::load_class($name);
- method _select(ArrayRef $ast) {
-
+ return $name->new(ast_version => $ver);
}
- method _name(ArrayRef $ast) {
- my (undef, @names) = @$ast;
+ # Main entry point
+ method generate(ClassName $class: ArrayRef $ast) {
+ croak "SQL::Abstract AST version not specified"
+ unless ($ast->[0] eq '-ast_version');
- my $sep = $self->name_separator;
+ my (undef, $ver) = splice(@$ast, 0, 2);
- return $sep->[0] .
- join( $sep->[1] . $sep->[0], @names ) .
- $sep->[1]
- if (@$sep > 1);
+ # TODO: once MXMS supports %args, use that here
+ my $self = $class->create($ver);
- return join($sep->[0], @names);
+ return ($self->dispatch($ast), $self->binds);
}
- method _list(ArrayRef $ast) {
- my (undef, @items) = @$ast;
-
- return join(
- $self->list_separator,
- map { $self->generate($_) } @items);
+ method reset() {
+ $self->_clear_binds();
}
- method _alias(ArrayRef $ast) {
- my (undef, $alias, $as) = @$ast;
-
- return $self->generate($alias) . " AS $as";
-
- }
+ method dispatch (ArrayRef $ast) {
- method _value(ArrayRef $ast) {
- my ($undef, $value) = @$ast;
-
- $self->add_bind($value);
- return "?";
- }
-
- method _where(ArrayRef $ast) {
- my (undef, @clauses) = @$ast;
-
- return 'WHERE ' . $self->_recurse_where(\@clauses);
- }
-
- method _recurse_where($clauses) {
-
- my $OP = 'AND';
- my $prio = $PRIO{and};
- my $first = $clauses->[0];
-
- if (!ref $first && $first =~ /^-(and|or)$/) {
- $OP = uc($1);
- $prio = $PRIO{$1};
- shift @$clauses;
- }
-
- my @output;
- foreach (@$clauses) {
- croak "invalid component in where clause" unless ArrayRef->check($_);
- my $op = $_->[0];
-
- unless (substr($op, 0, 1) eq '-') {
- # A simple comparison op (==, >, etc.)
-
- push @output, $self->_binop(@$_);
-
- } elsif ($op =~ /^-(and|or)$/) {
- my $sub_prio = $PRIO{$1};
-
- if ($sub_prio <= $prio) {
- push @output, $self->_recurse_where($_);
- } else {
- push @output, '(' . $self->_recurse_where($_) . ')';
- }
- } else {
- push @output, $self->generate($_);
- }
- }
-
- return join(" $OP ", @output);
- }
-
- method _binop($op, $lhs, $rhs) {
- join (' ', $self->generate($lhs),
- $OP_MAP{$op} || croak("Unknown binary operator $op"),
- $self->generate($rhs)
- );
- }
-
- method _generic_func(ArrayRef $ast) {
+ local $_ = $ast->[0];
+ s/^-/_/ or croak "Unknown type tag '$_'";
+
+ my $meth = $self->can($_) || croak "Unknown tag '$_'";
+ return $meth->($self, $ast);
}
-
};