lib/SQL/Abstract/Compat.pm

   1 use MooseX::Declare;
   2
   3 class SQL::Abstract::Compat {
   4
   5   use Moose::Util::TypeConstraints;
   6   use MooseX::Types::Moose qw/Str ScalarRef ArrayRef HashRef/;
   7   use SQL::Abstract::Types::Compat ':all';
   8   use SQL::Abstract::Types qw/AST/;
   9   use SQL::Abstract::AST::v1;
  10   use Data::Dump qw/pp/;
  11   use Devel::PartialDump qw/dump/;
  12   use Carp qw/croak/;
  13
  14   class_type 'SQL::Abstract';
  15   clean;
  16
  17   has logic => (
  18     is => 'rw',
  19     isa => LogicEnum,
  20     default => 'AND',
  21     coerce => 1,
  22     required => 1,
  23   );
  24
  25   has visitor => (
  26     is => 'rw',
  27     isa => 'SQL::Abstract',
  28     clearer => 'clear_visitor',
  29     lazy => 1,
  30     builder => '_build_visitor',
  31   );
  32
  33   has cmp => (
  34     is => 'rw',
  35     isa => 'Str',
  36     default => '=',
  37     required => 1,
  38   );
  39
  40   our %CMP_MAP = (
  41     '=' => '==',
  42   );
  43
  44   has convert => (
  45     is => 'rw',
  46     isa => 'Str',
  47     predicate => 'has_field_convertor'
  48   );
  49
  50   method select(Str|ArrayRef|ScalarRef $from, ArrayRef|Str $fields,
  51                 WhereType $where?,
  52                 WhereType $order?)
  53   {
  54     my $ast = $self->select_ast($from,$fields,$where,$order);
  55
  56     return ($self->visitor->dispatch($ast), $self->visitor->binds);
  57   }
  58   method select_ast(Str|ArrayRef|ScalarRef $from, ArrayRef|Str $fields,
  59                 WhereType $where?,
  60                 WhereType $order?)
  61   {
  62     my $ast = {
  63       -type => 'select',
  64       columns => [
  65         map {
  66           $self->mk_name(0, $_)
  67         } ( is_Str($fields) ? $fields : @$fields )
  68       ],
  69       tablespec => $self->tablespec($from)
  70     };
  71
  72
  73     $ast->{where} = $self->recurse_where($where)
  74       if defined $where;
  75     return $ast;
  76   }
  77
  78   method where(WhereType $where,
  79                WhereType $order?)
  80   {
  81     my $ret = "";
  82
  83     if ($where) {
  84       my $ast = $self->recurse_where($where);
  85       $ret .= "WHERE " . $self->visitor->_expr($ast);
  86     }
  87
  88     return $ret;
  89   }
  90
  91   method _build_visitor() {
  92     return SQL::Abstract->create(1);
  93   }
  94
  95   sub mk_name {
  96     my ($self, $use_convert) = (shift,shift);
  97     my $ast = { -type => 'name', args => [ @_ ] };
  98
  99     return $ast
 100       unless $use_convert && $self->has_field_convertor;
 101
 102     return $self->apply_convert($ast);
 103   }
 104
 105   method tablespec(Str|ArrayRef|ScalarRef $from) {
 106     return $self->mk_name(0, $from)
 107       if is_Str($from);
 108   }
 109
 110   method recurse_where(WhereType $ast, LogicEnum $logic?) returns (AST) {
 111     return $self->recurse_where_hash($logic || 'AND', $ast) if is_HashRef($ast);
 112     return $self->recurse_where_array($logic || 'OR', $ast) if is_ArrayRef($ast);
 113     croak "Unknown where clause type " . dump($ast);
 114   }
 115
 116   method recurse_where_hash(LogicEnum $logic, HashRef $ast) returns (AST) {
 117     my @args;
 118     my $ret = {
 119       -type => 'expr',
 120       op => lc $logic,
 121       args => \@args
 122     };
 123
 124     for my $key ( sort keys %$ast ) {
 125       my $value = $ast->{$key};
 126
 127       if ($key =~ /^-(or|and)$/) {
 128         my $val = $self->recurse_where($value, uc $1);
 129         if ($val->{op} eq $ret->{op}) {
 130           push @args, @{$val->{args}};
 131         }
 132         else {
 133           push @args, $val;
 134         }
 135         next;
 136       }
 137
 138       push @args, $self->field($key, $value);
 139     }
 140
 141     return $args[0] if @args == 1;
 142
 143     return $ret;
 144   }
 145
 146   method recurse_where_array(LogicEnum $logic, ArrayRef $ast) returns (AST) {
 147     my @args;
 148     my $ret = {
 149       -type => 'expr',
 150       op => lc $logic,
 151       args => \@args
 152     };
 153     my @nodes = @$ast;
 154
 155     while (my $key = shift @nodes) {
 156       if ($key =~ /^-(or|and)$/) {
 157         my $value = shift @nodes
 158           or confess "missing value after $key at " . dump($ast);
 159
 160         my $val = $self->recurse_where($value, uc $1);
 161         if ($val->{op} eq $ret->{op}) {
 162           push @args, @{$val->{args}};
 163         }
 164         else {
 165           push @args, $val;
 166         }
 167         next;
 168       }
 169
 170       push @args, $self->recurse_where($key);
 171     }
 172
 173     return $args[0] if @args == 1;
 174
 175     return $ret;
 176   }
 177
 178   method field_hash(Str $key, HashRef $value) returns (AST) {
 179     my ($op, @rest) = keys %$value;
 180
 181     confess "Don't know how to handle " . dump($value) . " (too many keys)"
 182       if @rest;
 183
 184     $value = $value->{$op};
 185
 186     my $ret = {
 187       -type => 'expr',
 188       op => $op,
 189       args => [
 190         $self->mk_name(1, $key)
 191       ],
 192     };
 193     $ret->{op} = $op;
 194
 195     # TODO: Validate the op?
 196     # 'word_like' operator
 197     if ($op =~ /^-?(?:(not)[_ ])?([a-z_]+)$/i) {
 198       $ret->{op} = lc $2;
 199       $ret->{op} = "not_" . $ret->{op} if $1;
 200
 201
 202       if (is_ArrayRef($value)) {
 203         push @{$ret->{args}}, $self->value($_) for @{$value};
 204         return $ret;
 205       }
 206     }
 207
 208     # Cases like:
 209     #   field => { '!=' =>  [ 'a','b','c'] }
 210     #   field => { '<' =>  [ 'a','b','c'] }
 211     #
 212     # *not* when op is a work or function operator - basic cmp operator only
 213     if (is_ArrayRef($value)) {
 214       local $self->{cmp} = $op;
 215
 216       my $ast = {
 217         -type => 'expr',
 218
 219         # Handle e => { '!=', [qw(f g)] }.
 220         # SQLA treats this as a 'DWIM' since e != f AND e != g doesn't make sense
 221         op => $op eq '!=' ? 'or' : 'and',
 222         args => [ map {
 223           $self->field($key, $_)
 224         } @{$value} ]
 225       };
 226       return $ast;
 227     }
 228
 229
 230     push @{$ret->{args}}, $self->value($value);
 231     return $ret;
 232   }
 233
 234   # Handle [ { ... }, { ... } ]
 235   method field_array(Str $key, ArrayRef $value) {
 236     # Return an or clause, sort of.
 237     return {
 238       -type => 'expr',
 239       op => 'or',
 240       args => [ map {
 241           $self->field($key, $_)
 242       } @$value ]
 243     };
 244   }
 245
 246   method field(Str $key, $value) returns (AST) {
 247
 248     if (is_HashRef($value)) {
 249       return $self->field_hash($key, $value);
 250     }
 251     elsif (is_ArrayRef($value)) {
 252       return $self->field_array($key, $value);
 253     }
 254
 255     my $ret = {
 256       -type => 'expr',
 257       op => $CMP_MAP{$self->cmp} || $self->cmp,
 258       args => [
 259         $self->mk_name(1, $key),
 260         $self->value($value)
 261       ],
 262     };
 263
 264     return $ret;
 265   }
 266
 267   method value($value) returns (AST) {
 268     return $self->apply_convert( { -type => 'value', value => $value })
 269       if is_Str($value);
 270
 271     confess "Don't know how to handle terminal value " . dump($value);
 272   }
 273
 274   method apply_convert(AST $ast) {
 275     return $ast unless $self->has_field_convertor;
 276
 277     return {
 278       -type => 'expr',
 279       op => $self->convert,
 280       args => [ $ast ]
 281     };
 282   }
 283
 284
 285 }
 286
 287 =head1 NAME
 288
 289 SQL::Abstract::Compant - compatibility layer for SQL::Abstrct v 1.xx
 290
 291 =head1 DESCRIPTION
 292
 293 This class attempts to maintain the original behaviour of version 1 of
 294 SQL::Abstract. It does this by internally converting to an AST and then using
 295 the standard AST visitor.
 296
 297 If so desired, you can get hold of this transformed AST somehow. This is aimed
 298 at libraries such as L<DBIx::Class> that use SQL::Abstract-style arrays or
 299 hashes as part of their public interface.
 300
 301 =head1 AUTHOR
 302
 303 Ash Berlin C<< <ash@cpan.org> >>
 304
 305 =cut
 306
 307 1;