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/;
  12   use Devel::PartialDump qw/dump/;
  13
  14   our $VERSION = '2.000000';
  15
  16   our $AST_VERSION = '1';
  17
  18   # Operator precedence for bracketing
  19   our %PRIO = (
  20     and => 10,
  21     or  => 50
  22   );
  23
  24   our %BINOP_MAP = (
  25
  26     '+' => '+',
  27     '-' => '-',
  28     '/' => '/',
  29     '*' => '*',
  30
  31     '>' => '>',
  32     '>=' => '>=',
  33     '<' => '<',
  34     '<=' => '<=',
  35     '==' => '=',
  36     '!=' => '!=',
  37     # LIKE is always "field LIKE <value>"
  38     'like' => 'LIKE',
  39     'not_like' => 'NOT LIKE',
  40   );
  41
  42   has expr_dispatch_table => (
  43     is => 'ro',
  44     lazy => 1,
  45     builder => '_build_expr_dispatch_table',
  46     isa => HashRef[CodeRef],
  47     metaclass => 'Collection::ImmutableHash',
  48     provides => {
  49       get => 'lookup_expr_dispatch'
  50     }
  51   );
  52
  53   has binop_map => (
  54     is => 'ro',
  55     lazy => 1,
  56     builder => '_build_binops',
  57     isa => HashRef,
  58     metaclass => 'Collection::ImmutableHash',
  59     provides => {
  60       exists => 'is_valid_binop',
  61       get => 'binop_mapping',
  62       keys => 'binary_operators'
  63     }
  64   );
  65
  66   # List of default binary operators (for in where clauses)
  67   sub _build_binops { return {%BINOP_MAP} };
  68
  69   method _build_expr_dispatch_table {
  70     my $binop = $self->can('_binop') or croak "InternalError: $self can't do _binop!";
  71     return {
  72       map { $_ => $binop } $self->binary_operators
  73     }
  74   }
  75
  76   has ast_version => (
  77     is => 'ro',
  78     isa => Int,
  79     required => 1
  80   );
  81
  82   has ident_separator => (
  83     is => 'rw',
  84     isa => NameSeparator,
  85     default => '.',
  86     required => 1,
  87   );
  88
  89   has list_separator => (
  90     is => 'rw',
  91     isa => Str,
  92     default => ', ',
  93     required => 1,
  94   );
  95
  96   has quote_chars => (
  97     is => 'rw',
  98     isa => QuoteChars,
  99     predicate => 'is_quoting',
 100     clearer => 'disable_quoting',
 101     coerce => 1,
 102   );
 103
 104   has binds => (
 105     isa => ArrayRef,
 106     is => 'ro',
 107     clearer => '_clear_binds',
 108     lazy => 1,
 109     default => sub { [ ] },
 110     metaclass => 'Collection::Array',
 111     provides => {
 112       push => 'add_bind',
 113     }
 114   );
 115
 116   # TODO: once MXMS supports %args, use that here
 117   # TODO: improve this so you can pass other args
 118   method create(ClassName $class: Int $ver) {
 119     croak "AST version $ver is greater than supported version of $AST_VERSION"
 120       if $ver > $AST_VERSION;
 121
 122     my $name = "${class}::AST::v$ver";
 123     Class::MOP::load_class($name);
 124
 125     return $name->new(ast_version => $ver);
 126   }
 127
 128   # Main entry point
 129   method generate(ClassName $class: AST $ast) {
 130     my $ver = $ast->{-ast_version};
 131     croak "SQL::Abstract AST version not specified"
 132       unless defined $ver;
 133
 134     # TODO: once MXMS supports %args, use that here
 135     my $self = $class->create($ver);
 136
 137     return ($self->dispatch($ast), $self->binds);
 138   }
 139
 140   method reset() {
 141     $self->_clear_binds();
 142   }
 143
 144   method dispatch (AST $ast) {
 145
 146     my $tag = "_" . $ast->{-type};
 147
 148     my $meth = $self->can($tag) || croak "Unknown tag '$tag'";
 149     return $meth->($self, $ast);
 150   }
 151
 152 };
 153
 154 __END__
 155
 156 =head1 NAME
 157
 158 SQL::Abstract - AST based re-implementation of SQL::Abstract
 159
 160 =head1 LICENSE
 161
 162 =head1 AUTHORS
 163
 164 Ash Berlin C<< <ash@cpan.org> >>
 165
 166 =head1 LICENSE
 167
 168 This program is free software; you can redistribute it and/or modify it under
 169 the same terms as Perl itself.
 170