use MooseX::Declare;
-use MooseX::Method::Signatures;
-
class SQL::Abstract {
use Data::Dump qw/pp/;
use Moose::Util::TypeConstraints;
- use MooseX::Types -declare => ['NameSeparator'];
- use MooseX::Types::Moose qw/ArrayRef Str/;
-
- subtype NameSeparator,
- as ArrayRef[Str];
- #where { @$_ == 1 ||| @$_ == 2 },
- #message { "Name separator must be one or two elements" };
+ use MooseX::Types::Moose qw/ArrayRef Str Int HashRef CodeRef/;
+ use MooseX::AttributeHelpers;
+ use SQL::Abstract::Types qw/NameSeparator QuoteChars AST/;
+ use Devel::PartialDump qw/dump/;
- coerce NameSeparator, from Str, via { [ $_ ] };
+ clean;
our $VERSION = '2.000000';
our $AST_VERSION = '1';
+ # Operator precedence for bracketing
+ our %PRIO = (
+ and => 10,
+ or => 50
+ );
+
+ our %BINOP_MAP = (
+ '>' => '>',
+ '>=' => '>=',
+ '<' => '<',
+ '<=' => '<=',
+ '==' => '=',
+ '!=' => '!=',
+ # LIKE is always "field LIKE <value>"
+ '-like' => 'LIKE',
+ '-not_like' => 'NOT LIKE',
+ );
+
+ has expr_dispatch_table => (
+ is => 'ro',
+ lazy => 1,
+ builder => '_build_expr_dispatch_table',
+ isa => HashRef[CodeRef],
+ metaclass => 'Collection::ImmutableHash',
+ provides => {
+ get => 'lookup_expr_dispatch'
+ }
+ );
+
+ has binop_map => (
+ is => 'ro',
+ lazy => 1,
+ builder => '_build_binops',
+ isa => HashRef,
+ metaclass => 'Collection::ImmutableHash',
+ provides => {
+ exists => 'is_valid_binop',
+ get => 'binop_mapping',
+ keys => 'binary_operators'
+ }
+ );
+
+ # List of default binary operators (for in where clauses)
+ sub _build_binops { return {%BINOP_MAP} };
+
+ method _build_expr_dispatch_table {
+ my $binop = $self->can('_binop') or croak "InternalError: $self can't do _binop!";
+ return {
+ map { $_ => $binop } $self->binary_operators
+ }
+ }
+
+ has ast_version => (
+ is => 'ro',
+ isa => Int,
+ required => 1
+ );
+
has name_separator => (
is => 'rw',
isa => NameSeparator,
- default => sub { ['.'] },
- coerece => 1,
+ default => '.',
required => 1,
);
required => 1,
);
- method generate (ArrayRef $ast) {
- $self = new $self unless blessed($self);
+ has quote_chars => (
+ is => 'rw',
+ isa => QuoteChars,
+ predicate => 'is_quoting',
+ clearer => 'disable_quoting',
+ coerce => 1,
+ );
- local $_ = $ast->[0];
- s/^-/_/ or croak "Unknown type tag '$_'";
- return $self->$_($ast);
+ has binds => (
+ isa => ArrayRef,
+ is => 'ro',
+ clearer => '_clear_binds',
+ lazy => 1,
+ default => sub { [ ] },
+ metaclass => 'Collection::Array',
+ provides => {
+ push => 'add_bind',
+ }
+ );
+
+ # 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;
+
+ my $name = "${class}::AST::v$ver";
+ Class::MOP::load_class($name);
+
+ return $name->new(ast_version => $ver);
}
- method _name(ArrayRef[Str] $ast) {
- my (undef, @names) = @$ast;
+ # Main entry point
+ method generate(ClassName $class: AST $ast) {
+ my $ver = $ast->{-ast_version};
+ croak "SQL::Abstract AST version not specified"
+ unless defined $ver;
- my $sep = $self->name_separator;
+ # TODO: once MXMS supports %args, use that here
+ my $self = $class->create($ver);
- return $sep->[0] .
- join( $sep->[1] . $sep->[0], @names ) .
- $sep->[1]
- if (@$sep > 1);
+ return ($self->dispatch($ast), $self->binds);
+ }
- return join($sep->[0], @names);
+ method reset() {
+ $self->_clear_binds();
}
- method _list(ArrayRef $ast) {
- my (undef, @items) = @$ast;
+ method dispatch (AST $ast) {
- return join(
- $self->list_separator,
- map { $self->generate($_) } @items);
+ my $tag = "_" . $ast->{-type};
+ my $meth = $self->can($tag) || croak "Unknown tag '$tag'";
+ return $meth->($self, $ast);
}
};