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/;
  12   use MooseX::AttributeHelpers;
  13
  14   clean;
  15
  16   subtype NameSeparator,
  17     as ArrayRef[Str];
  18     #where { @$_ == 1 ||| @$_ == 2 },
  19     #message { "Name separator must be one or two elements" };
  20
  21   coerce NameSeparator, from Str, via { [ $_ ] };
  22
  23   our $VERSION = '2.000000';
  24
  25   our $AST_VERSION = '1';
  26
  27   # Operator precedence for bracketing
  28   our %PRIO = (
  29     and => 10,
  30     or  => 50
  31   );
  32
  33   our %BINOP_MAP = (
  34     '>' => '>',
  35     '<' => '<',
  36     '==' => '=',
  37     '!=' => '!=',
  38     # LIKE is always "field LIKE <value>"
  39     '-like' => 'IN',
  40     '-not_like' => 'NOT LIKE',
  41   );
  42
  43   has where_dispatch_table => (
  44     is => 'ro',
  45     lazy_build => 1,
  46   );
  47
  48   has binop_map => (
  49     is => 'ro',
  50     lazy_build => 1,
  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   sub _build_binop_map { return {%BINOP_MAP} };
  61
  62   method _build_where_dispatch_table {
  63     my $binop = $self->can('_binop');
  64     return {
  65       map { $_ => $binop } $self->binary_operators
  66     }
  67   }
  68
  69   has ast_version => (
  70     is => 'ro',
  71     isa => Int,
  72     required => 1
  73   );
  74
  75   has name_separator => (
  76     is => 'rw',
  77     isa => NameSeparator,
  78     default => sub { ['.'] },
  79     coerece => 1,
  80     required => 1,
  81   );
  82
  83   has list_separator => (
  84     is => 'rw',
  85     isa => Str,
  86     default => ', ',
  87     required => 1,
  88   );
  89
  90   has binds => (
  91     isa => ArrayRef,
  92     is => 'ro',
  93     clearer => '_clear_binds',
  94     lazy => 1,
  95     default => sub { [ ] },
  96     metaclass => 'Collection::Array',
  97     provides => {
  98       push => 'add_bind',
  99     }
 100   );
 101
 102   # TODO: once MXMS supports %args, use that here
 103   method create(ClassName $class: Int $ver) {
 104     croak "AST version $ver is greater than supported version of $AST_VERSION"
 105       if $ver > $AST_VERSION;
 106
 107     my $name = "${class}::AST::v$ver";
 108     Class::MOP::load_class($name);
 109
 110     return $name->new(ast_version => $ver);
 111   }
 112
 113   # Main entry point
 114   method generate(ClassName $class: ArrayRef $ast) {
 115     croak "SQL::Abstract AST version not specified"
 116       unless ($ast->[0] eq '-ast_version');
 117
 118     my (undef, $ver) = splice(@$ast, 0, 2);
 119
 120     # TODO: once MXMS supports %args, use that here
 121     my $self = $class->create($ver);
 122
 123     return ($self->dispatch($ast), $self->binds);
 124   }
 125
 126   method reset() {
 127     $self->_clear_binds();
 128   }
 129
 130   method dispatch (ArrayRef $ast) {
 131
 132     local $_ = $ast->[0];
 133     s/^-/_/ or croak "Unknown type tag '$_'";
 134
 135     my $meth = $self->can($_) || croak "Unknown tag '$_'";
 136     return $meth->($self, $ast);
 137   }
 138
 139 };