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