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