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 => 1,
  40     builder => '_build_where_dispatch_table',
  41     isa => HashRef[CodeRef],
  42     metaclass => 'Collection::ImmutableHash',
  43     provides => {
  44       get => 'lookup_where_dispatch'
  45     }
  46   );
  47
  48   has binop_map => (
  49     is => 'ro',
  50     lazy => 1,
  51     builder => '_build_binops',
  52     isa => HashRef,
  53     metaclass => 'Collection::ImmutableHash',
  54     provides => {
  55       exists => 'is_valid_binop',
  56       get => 'binop_mapping',
  57       keys => 'binary_operators'
  58     }
  59   );
  60
  61   # List of default binary operators (for in where clauses)
  62   sub _build_binops { return {%BINOP_MAP} };
  63
  64   method _build_where_dispatch_table {
  65     my $binop = $self->can('_binop') or croak "InternalError: $self can't do _binop!";
  66     return {
  67       map { $_ => $binop } $self->binary_operators
  68     }
  69   }
  70
  71   has ast_version => (
  72     is => 'ro',
  73     isa => Int,
  74     required => 1
  75   );
  76
  77   has name_separator => (
  78     is => 'rw',
  79     isa => NameSeparator,
  80     default => sub { ['.'] },
  81     coerece => 1,
  82     required => 1,
  83   );
  84
  85   has list_separator => (
  86     is => 'rw',
  87     isa => Str,
  88     default => ', ',
  89     required => 1,
  90   );
  91
  92   has binds => (
  93     isa => ArrayRef,
  94     is => 'ro',
  95     clearer => '_clear_binds',
  96     lazy => 1,
  97     default => sub { [ ] },
  98     metaclass => 'Collection::Array',
  99     provides => {
 100       push => 'add_bind',
 101     }
 102   );
 103
 104   # TODO: once MXMS supports %args, use that here
 105   method create(ClassName $class: Int $ver) {
 106     croak "AST version $ver is greater than supported version of $AST_VERSION"
 107       if $ver > $AST_VERSION;
 108
 109     my $name = "${class}::AST::v$ver";
 110     Class::MOP::load_class($name);
 111
 112     return $name->new(ast_version => $ver);
 113   }
 114
 115   # Main entry point
 116   method generate(ClassName $class: AST $ast) {
 117     croak "SQL::Abstract AST version not specified"
 118       unless ($ast->[0] eq '-ast_version');
 119
 120     my (undef, $ver) = splice(@$ast, 0, 2);
 121
 122     # TODO: once MXMS supports %args, use that here
 123     my $self = $class->create($ver);
 124
 125     return ($self->dispatch($ast), $self->binds);
 126   }
 127
 128   method reset() {
 129     $self->_clear_binds();
 130   }
 131
 132   method dispatch (AST $ast) {
 133     # I want multi methods!
 134     my $tag;
 135     if (is_ArrayAST($ast)) {
 136       ($tag = $ast->[0]) =~ s/^-/_/;
 137     } else {
 138       $tag = "_" . $ast->{-type};
 139     }
 140
 141     my $meth = $self->can($tag) || croak "Unknown tag '$tag'";
 142     return $meth->($self, $ast);
 143   }
 144
 145 };