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 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' => 'LIKE',
  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 => '.',
  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 quote_chars => (
  93     is => 'rw',
  94     isa => QuoteChars,
  95     coerece => 1,
  96     predicate => 'is_quoting',
  97     clearer => 'disable_quoting',
  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     croak "SQL::Abstract AST version not specified"
 126       unless ($ast->[0] eq '-ast_version');
 127
 128     my (undef, $ver) = splice(@$ast, 0, 2);
 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       ($tag = $ast->[0]) =~ s/^-/_/;
 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 };