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