lib/SQL/Abstract.pm

   1 use MooseX::Declare;
   2 use MooseX::Method::Signatures;
   3
   4
   5 class SQL::Abstract {
   6
   7   use Carp qw/croak/;
   8   use Data::Dump qw/pp/;
   9
  10   use Moose::Util::TypeConstraints;
  11   use MooseX::Types -declare => [qw/NameSeparator/];
  12   use MooseX::Types::Moose qw/ArrayRef Str/;
  13   use MooseX::AttributeHelpers;
  14
  15   use namespace::clean -except => ['meta'];
  16
  17   subtype NameSeparator,
  18     as ArrayRef[Str];
  19     #where { @$_ == 1 ||| @$_ == 2 },
  20     #message { "Name separator must be one or two elements" };
  21
  22   coerce NameSeparator, from Str, via { [ $_ ] };
  23
  24   our $VERSION = '2.000000';
  25
  26   our $AST_VERSION = '1';
  27
  28   # Operator precedence for bracketing
  29   our %PRIO = (
  30     and => 10,
  31     or  => 50
  32   );
  33
  34   our %OP_MAP = (
  35     '>' => '>',
  36     '<' => '<',
  37     '==' => '=',
  38     '!=' => '!=',
  39   );
  40
  41   has name_separator => (
  42     is => 'rw',
  43     isa => NameSeparator,
  44     default => sub { ['.'] },
  45     coerece => 1,
  46     required => 1,
  47   );
  48
  49   has list_separator => (
  50     is => 'rw',
  51     isa => Str,
  52     default => ', ',
  53     required => 1,
  54   );
  55
  56   has binds => (
  57     isa => ArrayRef,
  58     is => 'ro',
  59     default => sub { [ ] },
  60     metaclass => 'Collection::Array',
  61     provides => {
  62       push => 'add_bind',
  63       clear => '_clear_binds',
  64     }
  65   );
  66
  67   method generate (Object|ClassName $self: ArrayRef $ast) {
  68     my $class_meth = !blessed($self);
  69     $self = $self->new if $class_meth;
  70
  71     local $_ = $ast->[0];
  72     s/^-/_/g or croak "Unknown type tag '$_'";
  73     my $meth = $self->can($_) || \&_generic_func;
  74     return $class_meth
  75          ? ($meth->($self, $ast), $self->binds)
  76          : $meth->($self, $ast);
  77   }
  78
  79   method _select(ArrayRef $ast) {
  80
  81   }
  82
  83   method _where(ArrayRef $ast) {
  84     my (undef, @clauses) = @$ast;
  85
  86     return 'WHERE ' . $self->_recurse_where(\@clauses);
  87   }
  88
  89   method _order_by(ArrayRef $ast) {
  90     my (undef, @clauses) = @$ast;
  91
  92     my @output;
  93
  94     for (@clauses) {
  95       if ($_->[0] =~ /^-(asc|desc)$/) {
  96         my $o = $1;
  97         push @output, $self->generate($_->[1]) . " " . uc($o);
  98         next;
  99       }
 100       push @output, $self->generate($_);
 101     }
 102
 103     return "ORDER BY " . join(", ", @output);
 104   }
 105
 106   method _name(ArrayRef $ast) {
 107     my (undef, @names) = @$ast;
 108
 109     my $sep = $self->name_separator;
 110
 111     return $sep->[0] .
 112            join( $sep->[1] . $sep->[0], @names ) .
 113            $sep->[1]
 114               if (@$sep > 1);
 115
 116     return join($sep->[0], @names);
 117   }
 118
 119   method _list(ArrayRef $ast) {
 120     my (undef, @items) = @$ast;
 121
 122     return join(
 123       $self->list_separator,
 124       map { $self->generate($_) } @items);
 125   }
 126
 127   method _alias(ArrayRef $ast) {
 128     my (undef, $alias, $as) = @$ast;
 129
 130     return $self->generate($alias) . " AS $as";
 131
 132   }
 133
 134   method _value(ArrayRef $ast) {
 135     my ($undef, $value) = @$ast;
 136
 137     $self->add_bind($value);
 138     return "?";
 139   }
 140
 141   method _recurse_where($clauses) {
 142
 143     my $OP = 'AND';
 144     my $prio = $PRIO{and};
 145     my $first = $clauses->[0];
 146
 147     if (!ref $first && $first =~ /^-(and|or)$/) {
 148       $OP = uc($1);
 149       $prio = $PRIO{$1};
 150       shift @$clauses;
 151     }
 152
 153     my @output;
 154     foreach (@$clauses) {
 155       croak "invalid component in where clause" unless ArrayRef->check($_);
 156       my $op = $_->[0];
 157
 158       unless (substr($op, 0, 1) eq '-') {
 159         # A simple comparison op (==, >, etc.)
 160
 161         push @output, $self->_binop(@$_);
 162
 163       } elsif ($op =~ /^-(and|or)$/) {
 164         my $sub_prio = $PRIO{$1};
 165
 166         if ($sub_prio <= $prio) {
 167           push @output, $self->_recurse_where($_);
 168         } else {
 169           push @output, '(' . $self->_recurse_where($_) . ')';
 170         }
 171       } else {
 172         push @output, $self->generate($_);
 173       }
 174     }
 175
 176     return join(" $OP ", @output);
 177   }
 178
 179   method _binop($op, $lhs, $rhs) {
 180     join (' ', $self->generate($lhs),
 181                $OP_MAP{$op} || croak("Unknown binary operator $op"),
 182                $self->generate($rhs)
 183     );
 184   }
 185
 186   method _generic_func(ArrayRef $ast) {
 187   }
 188
 189
 190 };