lib/SQL/Abstract2.pm

   1 package SQL::Abstract2;
   2
   3 use Moose;
   4 has known_ops => (is => 'rw', isa => 'HashRef', lazy_build => 1);
   5 has use_value_placeholders =>
   6   (
   7    is => 'rw',
   8    isa => 'Bool',
   9    required => 1,
  10    default => 1
  11   );
  12 has value_placeholder_char =>
  13   (
  14    is => 'rw',
  15    isa => 'Str',
  16    required => 1,
  17    default => sub {"?"},
  18   );
  19 has value_quote_char =>
  20   (
  21    is => 'rw',
  22    isa => 'Str',
  23    required => 1,
  24    default => sub {"'"},
  25   );
  26
  27 has name_quote_char =>
  28   (
  29    is => 'rw',
  30    isa => 'Str',
  31    required => 1,
  32    default => sub {'`'},
  33   );
  34
  35 has name_separator =>
  36   (
  37    is => 'rw',
  38    isa => 'Str',
  39    required => 1,
  40    default => sub {'.'},
  41   );
  42
  43 has logical_group_open_char =>
  44   (
  45    is => 'rw',
  46    isa => 'Str',
  47    required => 1,
  48    default => sub {'('},
  49   );
  50
  51 has logical_group_close_char =>
  52   (
  53    is => 'rw',
  54    isa => 'Str',
  55    required => 1,
  56    default => sub {')'},
  57   );
  58
  59
  60 sub _build_known_ops {
  61   my %known =
  62     (
  63      'in' => {handler => 'handle_op_in'},
  64      'date_add' => {handler => 'handle_op_date_add_sub'},
  65      'date_sub' => {handler => 'handle_op_date_add_sub'},
  66      'and' => {handler => 'handle_op_grouping'},
  67      'xor' => {handler => 'handle_op_grouping'},
  68      'or'  => {handler => 'handle_op_grouping'},
  69      'name'  => {handler => 'handle_op_name', args_min => 1},
  70      'between' => {
  71                    handler => 'handle_op_between',
  72                    args_min => 3,
  73                    args_max => 3,
  74                   },
  75      'value' => {
  76                  handler => 'handle_op_value',
  77                  args_min => 1,
  78                  args_max => 1
  79                 },
  80      'asc' => {
  81                  handler => 'handle_op_asc_desc',
  82                  args_min => 1,
  83                  args_max => 1
  84                 },
  85      'desc' => {
  86                  handler => 'handle_op_asc_desc',
  87                  args_min => 1,
  88                  args_max => 1
  89                 },
  90      '=' => {
  91              args_min => 2,
  92              args_max => 2,
  93              handler => 'handle_op_null_aware_equality',
  94             },
  95      '!=' => {
  96               args_min => 2,
  97               args_max => 2,
  98               handler => 'handle_op_null_aware_equality',
  99              },
 100      'is' => {
 101               args_min => 2,
 102               args_max => 2,
 103               handler => 'handle_op_is',
 104              },
 105      'where' => {
 106                  args_min => 1,
 107                  args_max => 1,
 108                  handler => 'handle_op_sql_word_and_args'
 109                 },
 110     );
 111
 112   foreach my $bin_op (qw^ > < >= <= + - * / % <> <=> ^) {
 113     $known{$bin_op} = {
 114                        args_min => 2,
 115                        args_max => 2,
 116                        handler => 'simple_binary_op',
 117                       };
 118   }
 119   for my $word ('fields', 'from', 'order by', 'group by'){
 120     $known{$word} = { handler => 'handle_op_sql_word_and_list' };
 121   }
 122   for my $word (qw/insert update select delete having/, 'replace into'){
 123     $known{$word} = { handler => 'handle_op_sql_word_and_args' };
 124   }
 125   for my $join ('join','left join','right join','inner join', 'cross join',
 126                 'straight_join','left outer join','right outer join',
 127                 'natural join', 'natural left join', 'natural left outer join',
 128                 'straight join', 'natural right join', 'natural right outer join',
 129                ){
 130     $known{$join} = { handler => 'handle_op_join' };
 131   }
 132   return \%known;
 133 }
 134
 135 sub handle_op_asc_desc {
 136   my($self, $op, $args, $bind_vars) = @_;
 137   return join(' ', $self->handle_op($args->[0], $bind_vars), uc($op));
 138 }
 139
 140 sub handle_op_limit {
 141   my($self, $op, $args, $bind_vars) = @_;
 142   return $self->handle_op_sql_word_and_list('LIMIT', $args, $bind_vars)
 143 }
 144
 145 sub handle_op_join {
 146   my($self, $op, $args, $bind_vars) = @_;
 147   my @args = @$args;
 148   my $join_type = uc $op;
 149   my $table = $self->handle_op( shift(@args), $bind_vars);
 150   if(@args){
 151     return join(" ", $join_type, $table, $self->handle_op(shift(@args), $bind_vars))
 152   } else {
 153     join(" ", $join_type, $table);
 154   }
 155 }
 156
 157 sub handle_op_sql_list {
 158   my($self, $op, $args, $bind_vars) = @_;
 159   my @quoted_args = map{ $self->handle_op($_, $bind_vars) } @$args;
 160   return join ', ', @quoted_args;
 161 }
 162
 163 sub handle_op_sql_word_and_list {
 164   my($self, $op, $args, $bind_vars) = @_;
 165   return join ' ', uc($op), $self->handle_op_sql_list($op, $args, $bind_vars);
 166 }
 167
 168 sub handle_op_sql_word_and_args {
 169   my($self, $op, $args, $bind_vars) = @_;
 170   return join ' ', uc($op), map { $self->handle_op($_, $bind_vars) } @$args;
 171 }
 172
 173 sub handle_op_grouping {
 174   my($self, $op, $args, $bind_vars) = @_;
 175   my $sep = uc $op;
 176   my @pieces = map { $self->handle_op($_, $bind_vars) } @$args;
 177   if(@pieces > 1){
 178     return join("",
 179                 $self->logical_group_open_char,
 180                 (join " ${sep} ", @pieces),
 181                 $self->logical_group_close_char,
 182                );
 183   }
 184   return shift @pieces;
 185 }
 186
 187 sub handle_op_null_aware_equality {
 188   my($self, $op, $args, $bind_vars) = @_;
 189
 190   my($name, $value);
 191   if ($args->[0]->[0] eq '-name' && $args->[1]->[0] eq '-value') {
 192     ($name, $value) = @{$args}[0,1];
 193   } elsif ($args->[1]->[0] eq '-name' && $args->[0]->[0] eq '-value') {
 194     ($name, $value) = @{$args}[1,0];
 195   }
 196   if (defined($value) && !defined($value->[1])) {
 197     my $is_op = $op eq '=' ? 'is' : 'is not';
 198     return $self->handle_op_is($is_op, [$name, $value], $bind_vars);
 199   }
 200   return $self->simple_binary_op($op, $args, $bind_vars);
 201 }
 202
 203 sub handle_op_date_add_sub {
 204  my($self, $op, $args, $bind_vars) = @_;
 205   if ($op =~ /add/i) {
 206     $op = 'DATE_ADD';
 207   } elsif ($op =~ /sub/i) {
 208     $op = 'DATE_SUB';
 209   }
 210   my($date, $interval, $measure) = @$args;
 211   $date = $self->maybe_quote_value($date, $bind_vars);
 212   return "${op}($date, INTERVAL $interval $measure)";
 213 }
 214
 215 sub handle_op_between {
 216   my($self, $op, $args, $bind_vars) = @_;
 217   my @args = @$args; #these are here so we don't destroy the refs given to us
 218   my $left_side = $self->handle_op(shift(@args), $bind_vars);
 219   my $sql = $op =~ /not(?:_|\w*)between/i ? 'NOT BETWEEN' : 'BETWEEN';
 220   return join ' ', $left_side, $sql, $self->simple_binary_op('AND', \@args, $bind_vars);
 221 }
 222
 223 sub handle_op_in {
 224   my($self, $op, $args, $bind_vars) = @_;
 225   my @args = @$args;
 226   my $left_side = $self->handle_op(shift(@args), $bind_vars);
 227   my $sql = $op =~ /not(?:_|\w*)in/i ? 'NOT IN' : 'IN';
 228   return join(" ", $left_side, $self->simple_function_op($sql, \@args, $bind_vars));
 229 }
 230
 231 sub handle_op_is {
 232   my($self, $op, $args, $bind_vars) = @_;
 233   my $sql = $op =~ /is(?:_|\w*)not/i ? 'IS NOT' : 'IS';
 234   return $self->simple_binary_op($sql, $args, $bind_vars);
 235 }
 236
 237 sub simple_binary_op {
 238   my($self, $op, $args, $bind_vars) = @_;
 239   $op = uc $op;
 240   my @arg_strs =  map{ $self->handle_op($_, $bind_vars) } @$args;
 241   return join(" ${op} ", @arg_strs);
 242 }
 243
 244 sub simple_function_op {
 245   my($self, $op, $args, $bind_vars) = @_;
 246   my $arg_str = $self->handle_op_sql_list($op, $args, $bind_vars);
 247   my $function = uc $op;
 248   return "${function}(${arg_str})";
 249 }
 250
 251 sub handle_op_value {
 252   my ($self, $op, $args, $bind_vars) = @_;
 253   return $self->maybe_quote_value($args->[0], $bind_vars);
 254 }
 255 sub handle_op_name {
 256   my ($self, $op, $args, $bind_vars) = @_;
 257   return $self->maybe_quote_name(@$args);
 258 }
 259
 260 sub handle_op {
 261   my ($self, $frame, $bind_vars) = @_;
 262   use Data::Dumper;
 263   confess( Dumper($frame) ) unless ref $frame;
 264   my ($needle, $op, $args);
 265   ($op, @$args) = @$frame;
 266
 267   if ($op =~/^-((?:not\s*)?(.+?))$/) {
 268     #bye bye leadin / trailing whitespace, keep needle lc for simplicity
 269     $op = $1;
 270     $needle = lc $2;
 271     ($op) = ($op =~ /^\s*(.+?)\s*$/);
 272     ($needle) = ($needle =~ /^\s*(.+?)\s*$/);
 273   }
 274   my $op_info;
 275   if ( exists $self->known_ops->{$op} ) {
 276     $op_info = $self->known_ops->{$op};
 277   } elsif(defined $needle) {
 278     if ( exists $self->known_ops->{$needle} ) {
 279       $op_info = $self->known_ops->{$needle};
 280     } elsif ( ($needle =~ /^\w+$/) && (my $coderef = $self->can("handle_op_${needle}"))) {
 281       return $self->$coderef($op, $args, $bind_vars)
 282     } else {
 283       return $self->simple_function_op($op, $args, $bind_vars);
 284     }
 285   } else {
 286     use Data::Dumper;
 287     print Dumper $op;
 288     die("Failed to find handle '${op}'");
 289   }
 290
 291   #arg checking
 292   if (exists $op_info->{args_min}) {
 293     my $min = $op_info->{args_min};
 294     die("Operator ${op} needs a minimum of ${min} arguments")
 295       unless $min <= @$args;
 296   }
 297   if (exists $op_info->{args_max}) {
 298     my $max = $op_info->{args_max};
 299     die("Operator ${op} can only have up to ${max} arguments")
 300      unless $max >= @$args;
 301   }
 302
 303   my $handler = $op_info->{handler};
 304   if ( ref($handler) eq 'CODE' ) {
 305     return $handler->($op, $args, $bind_vars);
 306   } elsif (my $coderef = $self->can($handler)) {
 307     $self->$coderef($op, $args, $bind_vars);
 308   } else {
 309     die("can not use handler ${handler}");
 310   }
 311 }
 312
 313 sub maybe_quote_value{
 314   my($self, $value, $bind_vars) = @_;
 315   return $$value if ref($value) eq 'SCALAR';
 316   if ( $self->use_value_placeholders ){
 317     push @$bind_vars, $value;
 318     return $self->value_placeholder_char;
 319   }
 320   return 'NULL' unless defined $value;
 321   return $value if Scalar::Util::looks_like_number( $value );
 322   my $q = $self->value_quote_char;
 323   return join "", $q, $value, $q;
 324 }
 325
 326 sub maybe_quote_name{
 327   my($self, @parts) = @_;
 328   my $q = $self->name_quote_char;
 329   my $as;
 330   if(ref($parts[-1]) eq 'ARRAY' && $parts[-1]->[0] eq '-as'){
 331     $as = pop(@parts)->[1];
 332     $as = ref($as) eq 'SCALAR' ? $$as : join("", $q, $as, $q);
 333   }
 334   @parts = map { ref($_) eq 'SCALAR' ? $$_ : join("", $q, $_, $q) } @parts;
 335   my $name = join($self->name_separator, @parts);
 336   return join ' AS ', grep { defined } ($name, $as); #XXX make 'AS' an attribute
 337 }
 338
 339 __PACKAGE__->meta->make_immutable;
 340
 341 1;
 342
 343 __END__;