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 NameSeparator QuoteChars/;
   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   # TODO: a metaclass trait to automatically use this on vistior construction
  51   has quote_char => (
  52     is => 'rw',
  53     isa => QuoteChars,
  54     coerce => 1,
  55     predicate => "has_quote_chars"
  56   );
  57
  58   has name_sep => (
  59     is => 'rw',
  60     isa => NameSeparator,
  61     predicate => "has_name_sep"
  62   );
  63
  64   method _build_visitor() {
  65     my %args = (
  66       ast_version => 1
  67     );
  68     $args{quote_chars} = $self->quote_char
  69       if $self->has_quote_chars;
  70     $args{ident_separator} = $self->name_sep
  71       if $self->has_name_sep;
  72
  73     # TODO: this needs improving along with SQL::A::create
  74     my $visitor = SQL::Abstract::AST::v1->new(%args);
  75   }
  76
  77   method select(Str|ArrayRef|ScalarRef $from, ArrayRef|Str $fields,
  78                 WhereType $where?,
  79                 WhereType $order?)
  80   {
  81     my $ast = $self->select_ast($from,$fields,$where,$order);
  82
  83     return ($self->visitor->dispatch($ast), @{$self->visitor->binds});
  84   }
  85
  86   method update(Str|ArrayRef|ScalarRef $from,
  87                 HashRef $fields, WhereType $where? )
  88   {
  89     my $ast = $self->update_ast($from,$fields,$where);
  90
  91     return ($self->visitor->dispatch($ast), @{$self->visitor->binds});
  92   }
  93
  94   method update_ast(Str|ArrayRef|ScalarRef $from,
  95                     HashRef $fields, WhereType $where? )
  96   {
  97     my (@columns, @values);
  98     my $ast = {
  99       -type => 'update',
 100       tablespec => $self->tablespec($from),
 101       columns => \@columns,
 102       values => \@values
 103     };
 104
 105     for (keys %$fields) {
 106       push @columns, $self->mk_name(0, $_);
 107       push @values, { -type => 'value', value => $fields->{$_} };
 108     }
 109
 110     return $ast;
 111   }
 112
 113   method select_ast(Str|ArrayRef|ScalarRef $from, ArrayRef|Str $fields,
 114                 WhereType $where?,
 115                 WhereType $order?)
 116   {
 117     my $ast = {
 118       -type => 'select',
 119       columns => [
 120         map {
 121           $self->mk_name(0, $_)
 122         } ( is_Str($fields) ? $fields : @$fields )
 123       ],
 124       tablespec => $self->tablespec($from)
 125     };
 126
 127
 128     $ast->{where} = $self->recurse_where($where)
 129       if defined $where;
 130
 131     if (defined $order) {
 132       my @order = is_ArrayRef($order) ? @$order : $order;
 133       $ast->{order_by} = [ map { $self->mk_name(0, $_) } @order ];
 134     }
 135
 136     return $ast;
 137   }
 138
 139   method where(WhereType $where,
 140                WhereType $order?)
 141   {
 142     my $ret = "";
 143
 144     if ($where) {
 145       my $ast = $self->recurse_where($where);
 146       $ret .= "WHERE " . $self->visitor->_expr($ast);
 147     }
 148
 149     return $ret;
 150   }
 151
 152
 153   # method mk_name(Bool $use_convert, Str @names) {
 154   sub mk_name {
 155     my ($self, $use_convert, @names) = @_;
 156
 157     @names = split /\Q@{[$self->name_sep]}\E/, $names[0]
 158       if (@names == 1 && $self->has_name_sep);
 159
 160     my $ast = { -type => 'identifier', elements => [ @names ] };
 161
 162     return $ast
 163       unless $use_convert && $self->has_field_convertor;
 164
 165     return $self->apply_convert($ast);
 166   }
 167
 168   method tablespec(Str|ArrayRef|ScalarRef $from) {
 169     return $self->mk_name(0, $from)
 170       if is_Str($from);
 171
 172     return {
 173       -type => 'list',
 174       args => [ map {
 175         $self->mk_name(0, $_)
 176       } @$from ]
 177     };
 178   }
 179
 180   method recurse_where(WhereType $ast, LogicEnum $logic?) returns (AST) {
 181     return $self->recurse_where_hash($logic || 'AND', $ast) if is_HashRef($ast);
 182     return $self->recurse_where_array($logic || 'OR', $ast) if is_ArrayRef($ast);
 183     croak "Unknown where clause type " . dump($ast);
 184   }
 185
 186   # Deals with where({ .... }) case
 187   method recurse_where_hash(LogicEnum $logic, HashRef $ast) returns (AST) {
 188     my @args;
 189     my $ret = {
 190       -type => 'expr',
 191       op => lc $logic,
 192       args => \@args
 193     };
 194
 195     for my $key ( sort keys %$ast ) {
 196       my $value = $ast->{$key};
 197
 198       if ($key =~ /^-(or|and)$/) {
 199         my $val = $self->recurse_where($value, uc $1);
 200         if ($val->{op} eq $ret->{op}) {
 201           push @args, @{$val->{args}};
 202         }
 203         else {
 204           push @args, $val;
 205         }
 206         next;
 207       }
 208
 209       push @args, $self->field($key, $value);
 210     }
 211
 212     return $args[0] if @args == 1;
 213
 214     return $ret;
 215   }
 216
 217   # Deals with where([ .... ]) case
 218   method recurse_where_array(LogicEnum $logic, ArrayRef $ast) returns (AST) {
 219     my @args;
 220     my $ret = {
 221       -type => 'expr',
 222       op => lc $logic,
 223       args => \@args
 224     };
 225     my @nodes = @$ast;
 226
 227     while (my $key = shift @nodes) {
 228       if ($key =~ /^-(or|and)$/) {
 229         my $value = shift @nodes
 230           or confess "missing value after $key at " . dump($ast);
 231
 232         my $val = $self->recurse_where($value, uc $1);
 233         if ($val->{op} eq $ret->{op}) {
 234           push @args, @{$val->{args}};
 235         }
 236         else {
 237           push @args, $val;
 238         }
 239         next;
 240       }
 241
 242       push @args, $self->recurse_where($key);
 243     }
 244
 245     return $args[0] if @args == 1;
 246
 247     return $ret;
 248   }
 249
 250   # { field => { .... } } case
 251   method field_hash(Str $key, HashRef $value) returns (AST) {
 252     my ($op, @rest) = keys %$value;
 253
 254     confess "Don't know how to handle " . dump($value) . " (too many keys)"
 255       if @rest;
 256
 257     $value = $value->{$op};
 258
 259     my $ret = {
 260       -type => 'expr',
 261       op => $op,
 262       args => [
 263         $self->mk_name(1, $key)
 264       ],
 265     };
 266     $ret->{op} = $op;
 267
 268     # TODO: Validate the op?
 269     # 'word_like' operator
 270     if ($op =~ /^-?(?:(not)[_ ])?([a-z_]+)$/i) {
 271       $ret->{op} = lc $2;
 272       $ret->{op} = "not_" . $ret->{op} if $1;
 273
 274
 275       if (is_ArrayRef($value)) {
 276         push @{$ret->{args}}, $self->value($_) for @{$value};
 277         return $ret;
 278       }
 279     }
 280
 281     # Cases like:
 282     #   field => { '!=' =>  [ 'a','b','c'] }
 283     #   field => { '<' =>  [ 'a','b','c'] }
 284     #
 285     # *not* when op is a work or function operator - basic cmp operator only
 286     if (is_ArrayRef($value)) {
 287       local $self->{cmp} = $op;
 288
 289       my $ast = {
 290         -type => 'expr',
 291         op => 'or',
 292         args => [ map {
 293           $self->field($key, $_)
 294         } @{$value} ]
 295       };
 296       return $ast;
 297     }
 298
 299
 300     push @{$ret->{args}}, $self->value($value);
 301     return $ret;
 302   }
 303
 304   # Handle [ { ... }, { ... } ]
 305   method field_array(Str $key, ArrayRef $value) {
 306     # Return an or clause, sort of.
 307     return {
 308       -type => 'expr',
 309       op => 'or',
 310       args => [ map {
 311           $self->field($key, $_)
 312       } @$value ]
 313     };
 314   }
 315
 316   method field(Str $key, $value) returns (AST) {
 317
 318     if (is_HashRef($value)) {
 319       return $self->field_hash($key, $value);
 320     }
 321     elsif (is_ArrayRef($value)) {
 322       return $self->field_array($key, $value);
 323     }
 324
 325     my $ret = {
 326       -type => 'expr',
 327       op => $CMP_MAP{$self->cmp} || $self->cmp,
 328       args => [
 329         $self->mk_name(1, $key),
 330         $self->value($value)
 331       ],
 332     };
 333
 334     return $ret;
 335   }
 336
 337   method value($value) returns (AST) {
 338     return $self->apply_convert( { -type => 'value', value => $value })
 339       if is_Str($value);
 340
 341     confess "Don't know how to handle terminal value " . dump($value);
 342   }
 343
 344   method apply_convert(AST $ast) {
 345     return $ast unless $self->has_field_convertor;
 346
 347     return {
 348       -type => 'expr',
 349       op => $self->convert,
 350       args => [ $ast ]
 351     };
 352   }
 353
 354
 355 }
 356
 357 =head1 NAME
 358
 359 SQL::Abstract::Compant - compatibility layer for SQL::Abstrct v 1.xx
 360
 361 =head1 DESCRIPTION
 362
 363 This class attempts to maintain the original behaviour of version 1 of
 364 SQL::Abstract. It does this by internally converting to an AST and then using
 365 the standard AST visitor.
 366
 367 If so desired, you can get hold of this transformed AST somehow. This is aimed
 368 at libraries such as L<DBIx::Class> that use SQL::Abstract-style arrays or
 369 hashes as part of their public interface.
 370
 371 =head1 AUTHOR
 372
 373 Ash Berlin C<< <ash@cpan.org> >>
 374
 375 =cut
 376
 377 1;