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