X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=e21f4cae3128a19189b50e98a0d18357c8b17cc7;hb=HEAD;hp=d1dc0211553295e0f06e8dd20888207de13fbe2c;hpb=5bf8c024d27e974336be6ece34f1d4f0cf998fce;p=dbsrgits%2FSQL-Abstract-2.0-ish.git

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index d1dc021..e21f4ca 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -1,6 +1,4 @@
 use MooseX::Declare;
-use MooseX::Method::Signatures;
-
 
 class SQL::Abstract {
 
@@ -8,18 +6,10 @@ class SQL::Abstract {
   use Data::Dump qw/pp/;
 
   use Moose::Util::TypeConstraints;
-  use MooseX::Types -declare => [qw/NameSeparator/];
-  use MooseX::Types::Moose qw/ArrayRef Str/;
+  use MooseX::Types::Moose qw/ArrayRef Str Int HashRef CodeRef/;
   use MooseX::AttributeHelpers;
-
-  use namespace::clean -except => ['meta'];
-
-  subtype NameSeparator,
-    as ArrayRef[Str];
-    #where { @$_ == 1 ||| @$_ == 2 },
-    #message { "Name separator must be one or two elements" };
-
-  coerce NameSeparator, from Str, via { [ $_ ] };
+  use SQL::Abstract::Types qw/NameSeparator QuoteChars AST/;
+  use Devel::PartialDump qw/dump/;
 
   our $VERSION = '2.000000';
 
@@ -31,18 +21,68 @@ class SQL::Abstract {
     or  => 50
   );
 
-  our %OP_MAP = (
+  our %BINOP_MAP = (
+
+    '+' => '+',
+    '-' => '-',
+    '/' => '/',
+    '*' => '*',
+
     '>' => '>',
+    '>=' => '>=',
     '<' => '<',
+    '<=' => '<=',
     '==' => '=',
     '!=' => '!=',
+    # LIKE is always "field LIKE <value>"
+    'like' => 'LIKE',
+    'not_like' => 'NOT LIKE',
+  );
+
+  has expr_dispatch_table => (
+    is => 'ro',
+    lazy => 1,
+    builder => '_build_expr_dispatch_table',
+    isa => HashRef[CodeRef],
+    metaclass => 'Collection::ImmutableHash',
+    provides => {
+      get => 'lookup_expr_dispatch'
+    }
+  );
+
+  has binop_map => (
+    is => 'ro',
+    lazy => 1,
+    builder => '_build_binops',
+    isa => HashRef,
+    metaclass => 'Collection::ImmutableHash',
+    provides => {
+      exists => 'is_valid_binop',
+      get => 'binop_mapping',
+      keys => 'binary_operators'
+    }
+  );
+
+  # List of default binary operators (for in where clauses)
+  sub _build_binops { return {%BINOP_MAP} };
+
+  method _build_expr_dispatch_table {
+    my $binop = $self->can('_binop') or croak "InternalError: $self can't do _binop!";
+    return {
+      map { $_ => $binop } $self->binary_operators
+    }
+  }
+
+  has ast_version => (
+    is => 'ro',
+    isa => Int,
+    required => 1
   );
 
-  has name_separator => ( 
+  has ident_separator => ( 
     is => 'rw', 
     isa => NameSeparator,
-    default => sub { ['.'] },
-    coerece => 1,
+    default => '.',
     required => 1,
   );
 
@@ -53,138 +93,78 @@ class SQL::Abstract {
     required => 1,
   );
 
+  has quote_chars => (
+    is => 'rw', 
+    isa => QuoteChars,
+    predicate => 'is_quoting',
+    clearer => 'disable_quoting', 
+    coerce => 1,
+  );
+
   has binds => (
     isa => ArrayRef,
     is => 'ro',
+    clearer => '_clear_binds',
+    lazy => 1,
     default => sub { [ ] },
     metaclass => 'Collection::Array',
     provides => {
       push => 'add_bind',
-      clear => '_clear_binds',
     }
   );
 
-  method generate (Object|ClassName $self: ArrayRef $ast) {
-    my $class_meth = !blessed($self);
-    $self = $self->new if $class_meth;
-
-    local $_ = $ast->[0];
-    s/^-/_/g or croak "Unknown type tag '$_'";
-    my $meth = $self->can($_) || \&_generic_func;
-    return $class_meth
-         ? ($meth->($self, $ast), $self->binds)
-         : $meth->($self, $ast);
-  }
-
-  method _select(ArrayRef $ast) {
-    
-  }
-
-  method _where(ArrayRef $ast) {
-    my (undef, @clauses) = @$ast;
-  
-    return 'WHERE ' . $self->_recurse_where(\@clauses);
-  }
+  # TODO: once MXMS supports %args, use that here
+  # TODO: improve this so you can pass other args
+  method create(ClassName $class: Int $ver) {
+    croak "AST version $ver is greater than supported version of $AST_VERSION"
+      if $ver > $AST_VERSION;
 
-  method _order_by(ArrayRef $ast) {
-    my (undef, @clauses) = @$ast;
-
-    my @output;
-   
-    for (@clauses) {
-      if ($_->[0] =~ /^-(asc|desc)$/) {
-        my $o = $1;
-        push @output, $self->generate($_->[1]) . " " . uc($o);
-        next;
-      }
-      push @output, $self->generate($_);
-    }
+    my $name = "${class}::AST::v$ver";
+    Class::MOP::load_class($name);
 
-    return "ORDER BY " . join(", ", @output);
+    return $name->new(ast_version => $ver);
   }
 
-  method _name(ArrayRef $ast) {
-    my (undef, @names) = @$ast;
-
-    my $sep = $self->name_separator;
+  # Main entry point
+  method generate(ClassName $class: AST $ast) {
+    my $ver = $ast->{-ast_version};
+    croak "SQL::Abstract AST version not specified"
+      unless defined $ver;
 
-    return $sep->[0] . 
-           join( $sep->[1] . $sep->[0], @names ) . 
-           $sep->[1]
-              if (@$sep > 1);
+    # TODO: once MXMS supports %args, use that here
+    my $self = $class->create($ver);
 
-    return join($sep->[0], @names);
+    return ($self->dispatch($ast), $self->binds);
   }
 
-  method _list(ArrayRef $ast) {
-    my (undef, @items) = @$ast;
-
-    return join(
-      $self->list_separator,
-      map { $self->generate($_) } @items);
+  method reset() {
+    $self->_clear_binds();
   }
 
-  method _alias(ArrayRef $ast) {
-    my (undef, $alias, $as) = @$ast;
-
-    return $self->generate($alias) . " AS $as";
+  method dispatch (AST $ast) {
 
+    my $tag = "_" . $ast->{-type};
+    
+    my $meth = $self->can($tag) || croak "Unknown tag '$tag'";
+    return $meth->($self, $ast);
   }
 
-  method _value(ArrayRef $ast) {
-    my ($undef, $value) = @$ast;
+};
 
-    $self->add_bind($value);
-    return "?";
-  }
+__END__
 
-  method _recurse_where($clauses) {
+=head1 NAME
 
-    my $OP = 'AND';
-    my $prio = $PRIO{and};
-    my $first = $clauses->[0];
+SQL::Abstract - AST based re-implementation of SQL::Abstract
 
-    if (!ref $first && $first =~ /^-(and|or)$/) {
-      $OP = uc($1);
-      $prio = $PRIO{$1};
-      shift @$clauses;
-    }
+=head1 LICENSE
 
-    my @output;
-    foreach (@$clauses) {
-      croak "invalid component in where clause" unless ArrayRef->check($_);
-      my $op = $_->[0];
-
-      unless (substr($op, 0, 1) eq '-') {
-        # A simple comparison op (==, >, etc.)
-        
-        push @output, $self->_binop(@$_);
-        
-      } elsif ($op =~ /^-(and|or)$/) {
-        my $sub_prio = $PRIO{$1}; 
-
-        if ($sub_prio <= $prio) {
-          push @output, $self->_recurse_where($_);
-        } else {
-          push @output, '(' . $self->_recurse_where($_) . ')';
-        }
-      } else {
-        push @output, $self->generate($_);
-      }
-    }
+=head1 AUTHORS
 
-    return join(" $OP ", @output);
-  }
+Ash Berlin C<< <ash@cpan.org> >>
 
-  method _binop($op, $lhs, $rhs) {
-    join (' ', $self->generate($lhs), 
-               $OP_MAP{$op} || croak("Unknown binary operator $op"),
-               $self->generate($rhs)
-    );
-  }
+=head1 LICENSE
 
-  method _generic_func(ArrayRef $ast) {
-  }
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
 
-
-};