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 QuoteChars AST HashAST ArrayAST/;
  14   use Devel::PartialDump qw/dump/;
  15
  16   clean;
  17
  18   our $VERSION = '2.000000';
  19
  20   our $AST_VERSION = '1';
  21
  22   # Operator precedence for bracketing
  23   our %PRIO = (
  24     and => 10,
  25     or  => 50
  26   );
  27
  28   our %BINOP_MAP = (
  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     coerece => 1,
  83     required => 1,
  84   );
  85
  86   has list_separator => (
  87     is => 'rw',
  88     isa => Str,
  89     default => ', ',
  90     required => 1,
  91   );
  92
  93   has quote_chars => (
  94     is => 'rw',
  95     isa => QuoteChars,
  96     coerece => 1,
  97     predicate => 'is_quoting',
  98     clearer => 'disable_quoting',
  99   );
 100
 101   has binds => (
 102     isa => ArrayRef,
 103     is => 'ro',
 104     clearer => '_clear_binds',
 105     lazy => 1,
 106     default => sub { [ ] },
 107     metaclass => 'Collection::Array',
 108     provides => {
 109       push => 'add_bind',
 110     }
 111   );
 112
 113   # TODO: once MXMS supports %args, use that here
 114   method create(ClassName $class: Int $ver) {
 115     croak "AST version $ver is greater than supported version of $AST_VERSION"
 116       if $ver > $AST_VERSION;
 117
 118     my $name = "${class}::AST::v$ver";
 119     Class::MOP::load_class($name);
 120
 121     return $name->new(ast_version => $ver);
 122   }
 123
 124   # Main entry point
 125   method generate(ClassName $class: HashAST $ast) {
 126     my $ver = $ast->{-ast_version};
 127     croak "SQL::Abstract AST version not specified"
 128       unless defined $ver;
 129
 130     # TODO: once MXMS supports %args, use that here
 131     my $self = $class->create($ver);
 132
 133     return ($self->dispatch($ast), $self->binds);
 134   }
 135
 136   method reset() {
 137     $self->_clear_binds();
 138   }
 139
 140   method dispatch (AST $ast) {
 141     # I want multi methods!
 142     my $tag;
 143     if (is_ArrayAST($ast)) {
 144       confess "FIX: " . dump($ast);
 145     } else {
 146       $tag = "_" . $ast->{-type};
 147     }
 148
 149     my $meth = $self->can($tag) || croak "Unknown tag '$tag'";
 150     return $meth->($self, $ast);
 151   }
 152
 153 };