lib/SQL/Abstract.pm

   1 use MooseX::Declare;
   2
   3
   4 class SQL::Abstract {
   5
   6   use Carp qw/croak/;
   7   use Data::Dump qw/pp/;
   8
   9   use Moose::Util::TypeConstraints;
  10   use MooseX::Types -declare => [qw/NameSeparator/];
  11   use MooseX::Types::Moose qw/ArrayRef Str Int HashRef CodeRef/;
  12   use MooseX::AttributeHelpers;
  13
  14   clean;
  15
  16   subtype NameSeparator,
  17     as ArrayRef[Str];
  18     #where { @$_ == 1 ||| @$_ == 2 },
  19     #message { "Name separator must be one or two elements" };
  20
  21   coerce NameSeparator, from Str, via { [ $_ ] };
  22
  23   our $VERSION = '2.000000';
  24
  25   our $AST_VERSION = '1';
  26
  27   # Operator precedence for bracketing
  28   our %PRIO = (
  29     and => 10,
  30     or  => 50
  31   );
  32
  33   our %BINOP_MAP = (
  34     '>' => '>',
  35     '<' => '<',
  36     '==' => '=',
  37     '!=' => '!=',
  38     # LIKE is always "field LIKE <value>"
  39     '-like' => 'IN',
  40     '-not_like' => 'NOT LIKE',
  41   );
  42
  43   has where_dispatch_table => (
  44     is => 'ro',
  45     lazy_build => 1,
  46     isa => HashRef[CodeRef],
  47     metaclass => 'Collection::ImmutableHash',
  48     provides => {
  49       get => 'lookup_where_dispatch'
  50     }
  51   );
  52
  53   has binop_map => (
  54     is => 'ro',
  55     lazy_build => 1,
  56     isa => HashRef,
  57     metaclass => 'Collection::ImmutableHash',
  58     provides => {
  59       exists => 'is_valid_binop',
  60       get => 'binop_mapping',
  61       keys => 'binary_operators'
  62     }
  63   );
  64
  65   sub _build_binop_map { return {%BINOP_MAP} };
  66
  67   method _build_where_dispatch_table {
  68     my $binop = $self->can('_binop') or croak "InternalError: $self can't do _binop!";
  69     return {
  70       map { $_ => $binop } $self->binary_operators
  71     }
  72   }
  73
  74   has ast_version => (
  75     is => 'ro',
  76     isa => Int,
  77     required => 1
  78   );
  79
  80   has name_separator => (
  81     is => 'rw',
  82     isa => NameSeparator,
  83     default => sub { ['.'] },
  84     coerece => 1,
  85     required => 1,
  86   );
  87
  88   has list_separator => (
  89     is => 'rw',
  90     isa => Str,
  91     default => ', ',
  92     required => 1,
  93   );
  94
  95   has binds => (
  96     isa => ArrayRef,
  97     is => 'ro',
  98     clearer => '_clear_binds',
  99     lazy => 1,
 100     default => sub { [ ] },
 101     metaclass => 'Collection::Array',
 102     provides => {
 103       push => 'add_bind',
 104     }
 105   );
 106
 107   # TODO: once MXMS supports %args, use that here
 108   method create(ClassName $class: Int $ver) {
 109     croak "AST version $ver is greater than supported version of $AST_VERSION"
 110       if $ver > $AST_VERSION;
 111
 112     my $name = "${class}::AST::v$ver";
 113     Class::MOP::load_class($name);
 114
 115     return $name->new(ast_version => $ver);
 116   }
 117
 118   # Main entry point
 119   method generate(ClassName $class: ArrayRef $ast) {
 120     croak "SQL::Abstract AST version not specified"
 121       unless ($ast->[0] eq '-ast_version');
 122
 123     my (undef, $ver) = splice(@$ast, 0, 2);
 124
 125     # TODO: once MXMS supports %args, use that here
 126     my $self = $class->create($ver);
 127
 128     return ($self->dispatch($ast), $self->binds);
 129   }
 130
 131   method reset() {
 132     $self->_clear_binds();
 133   }
 134
 135   method dispatch (ArrayRef $ast) {
 136
 137     local $_ = $ast->[0];
 138     s/^-/_/ or croak "Unknown type tag '$_'";
 139
 140     my $meth = $self->can($_) || croak "Unknown tag '$_'";
 141     return $meth->($self, $ast);
 142   }
 143
 144 };