lib/SQL/Abstract.pm

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