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