my $f = $options->{returning};
- my $fieldlist = $self->_SWITCH_refkind($f, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
- SCALAR => sub {$self->_quote($f)},
- SCALARREF => sub {$$f},
- });
- return $self->_sqlcase(' returning ') . $fieldlist;
+ my ($sql, @bind) = $self->_render_expr(
+ $self->_expand_maybe_list_expr($f, undef, -ident)
+ );
+ return wantarray
+ ? $self->_sqlcase(' returning ') . $sql
+ : ($self->_sqlcase(' returning ').$sql, @bind);
}
sub _insert_HASHREF { # explicit list of fields and then values
sub _insert_value {
my ($self, $column, $v) = @_;
- my (@values, @all_bind);
- $self->_SWITCH_refkind($v, {
-
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # if array datatype are activated
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- }
- else { # else literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
- }
- },
-
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
- },
-
- # THINK: anything useful to do with a HASHREF ?
- HASHREF => sub { # (nothing, but old SQLA passed it through)
- #TODO in SQLA >= 2.0 it will die instead
- belch "HASH ref as bind value in insert is not supported";
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
-
- SCALARREF => sub { # literal SQL without bind
- push @values, $$v;
- },
-
- SCALAR_or_UNDEF => sub {
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
+ return $self->_render_expr(
+ $self->_expand_insert_value($column, $v)
+ );
+}
- });
+sub _expand_insert_value {
+ my ($self, $column, $v) = @_;
- my $sql = join(", ", @values);
- return ($sql, @all_bind);
+ if (ref($v) eq 'ARRAY') {
+ if ($self->{array_datatypes}) {
+ return +{ -bind => [ $column, $v ] };
+ }
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ return +{ -literal => $v };
+ }
+ if (ref($v) eq 'HASH') {
+ if (grep !/^-/, keys %$v) {
+ belch "HASH ref as bind value in insert is not supported";
+ return +{ -bind => [ $column, $v ] };
+ }
+ }
+ if (!defined($v)) {
+ return +{ -bind => [ $column, undef ] };
+ }
+ local our $Cur_Col_Meta = $column;
+ return $self->_expand_expr($v);
}
sub _update_set_values {
my ($self, $data) = @_;
- my (@set, @all_bind);
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
-
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # array datatype
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- }
- else { # literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- }
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALARREF => sub { # literal SQL without bind
- push @set, "$label = $$v";
- },
- HASHREF => sub {
- my ($op, $arg, @rest) = %$v;
-
- puke 'Operator calls in update must be in the form { -op => $arg }'
- if (@rest or not $op =~ /^\-(.+)/);
-
- local our $Cur_Col_Meta = $k;
- my ($sql, @bind) = $self->_render_expr(
- $self->_expand_expr_hashpair($op, $arg)
- );
-
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALAR_or_UNDEF => sub {
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- },
- });
- }
-
- # generate sql
- my $sql = join ', ', @set;
+ return $self->_render_expr(
+ $self->_expand_update_set_values($data),
+ );
+}
- return ($sql, @all_bind);
+sub _expand_update_set_values {
+ my ($self, $data) = @_;
+ $self->_expand_maybe_list_expr( [
+ map {
+ my ($k, $set) = @$_;
+ +{ -op => [ '=', { -ident => $k }, $set ] };
+ }
+ map {
+ my $k = $_;
+ my $v = $data->{$k};
+ (ref($v) eq 'ARRAY'
+ ? ($self->{array_datatypes}
+ ? [ $k, +{ -bind => [ $k, $v ] } ]
+ : [ $k, +{ -literal => $v } ])
+ : do {
+ local our $Cur_Col_Meta = $k;
+ [ $k, $self->_expand_expr($v) ]
+ }
+ );
+ } sort keys %$data
+ ] );
}
# So that subclasses can override UPDATE ... RETURNING separately from
sub _select_fields {
my ($self, $fields) = @_;
- return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields
- : $fields;
+ return $self->_render_expr(
+ $self->_expand_maybe_list_expr($fields, undef, '-ident')
+ );
}
#======================================================================
sub where {
my ($self, $where, $order) = @_;
+ local $self->{convert_where} = $self->{convert};
+
# where ?
my ($sql, @bind) = defined($where)
? $self->_recurse_where($where)
}
sub _expand_expr {
- my ($self, $expr, $logic) = @_;
+ my ($self, $expr, $logic, $default_scalar_to) = @_;
+ local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
return undef unless defined($expr);
if (ref($expr) eq 'HASH') {
if (keys %$expr > 1) {
return +{ -literal => $literal };
}
if (!ref($expr) or Scalar::Util::blessed($expr)) {
+ if (my $d = $Default_Scalar_To) {
+ return +{ $d => $expr };
+ }
if (my $m = our $Cur_Col_Meta) {
return +{ -bind => [ $m, $expr ] };
}
# top level special ops are illegal in general
puke "Illegal use of top-level '-$op'"
- if !(defined $self->{_nested_func_lhs})
- and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
+ if List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
}
if ($k eq '-value' and my $m = our $Cur_Col_Meta) {
return +{ -bind => [ $m, $v ] };
if ($k eq '-op' or $k eq '-ident' or $k eq '-value' or $k eq '-bind' or $k eq '-literal' or $k eq '-func') {
return { $k => $v };
}
+ if (my $custom = $self->{custom_expansions}{($k =~ /^-(.*)$/)[0]}) {
+ return $self->$custom($v);
+ }
if (
ref($v) eq 'HASH'
and keys %$v == 1
my ($self, $expr) = @_;
my ($k, $v, @rest) = %$expr;
die "No" if @rest;
- my %op = map +("-$_" => '_where_op_'.uc($_)),
+ my %op = map +("-$_" => '_render_'.$_),
qw(op func value bind ident literal);
if (my $meth = $op{$k}) {
- return $self->$meth(undef, $v);
+ return $self->$meth($v);
}
die "notreached: $k";
}
}
}
-sub _where_op_IDENT {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
- if (! defined $rhs or length ref $rhs) {
- puke "-$op requires a single plain scalar argument (a quotable identifier)";
- }
-
- # in case we are called as a top level special op (no '=')
- my $has_lhs = my $lhs = shift;
+sub _render_ident {
+ my ($self, $ident) = @_;
- $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
-
- return $has_lhs
- ? "$lhs = $rhs"
- : $rhs
- ;
+ return $self->_convert($self->_quote($ident));
}
-sub _where_op_VALUE {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
-
- # in case we are called as a top level special op (no '=')
- my $lhs = shift;
-
- # special-case NULL
- if (! defined $rhs) {
- return defined $lhs
- ? $self->_where_hashpair_HASHREF($lhs, { -is => undef })
- : undef
- ;
- }
-
- my @bind =
- $self->_bindtype(
- (defined $lhs ? $lhs : $self->{_nested_func_lhs}),
- $rhs,
- )
- ;
+sub _render_value {
+ my ($self, $value) = @_;
- return $lhs
- ? (
- $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
- @bind
- )
- : (
- $self->_convert('?'),
- @bind,
- )
- ;
+ return ($self->_convert('?'), $self->_bindtype(undef, $value));
}
-
-my %unop_postfix = map +($_ => 1), 'is null', 'is not null';
+my %unop_postfix = map +($_ => 1),
+ 'is null', 'is not null',
+ 'asc', 'desc',
+;
my %special = (
(map +($_ => do {
}), 'in', 'not in'),
);
-sub _where_op_OP {
- my ($self, undef, $v) = @_;
+sub _render_op {
+ my ($self, $v) = @_;
my ($op, @args) = @$v;
$op =~ s/^-// if length($op) > 1;
$op = lc($op);
- local $self->{_nested_func_lhs};
if (my $h = $special{$op}) {
return $self->$h(\@args);
}
} else {
my @parts = map [ $self->_render_expr($_) ], @args;
my ($final_sql) = map +($op =~ /^(and|or)$/ ? "(${_})" : $_), join(
- ' '.$self->_sqlcase($final_op).' ',
+ ($final_op eq ',' ? '' : ' ').$self->_sqlcase($final_op).' ',
map $_->[0], @parts
);
return (
die "unhandled";
}
-sub _where_op_FUNC {
- my ($self, undef, $rest) = @_;
+sub _render_func {
+ my ($self, $rest) = @_;
my ($func, @args) = @$rest;
my @arg_sql;
my @bind = map {
return ($self->_sqlcase($func).'('.join(', ', @arg_sql).')', @bind);
}
-sub _where_op_BIND {
- my ($self, undef, $bind) = @_;
+sub _render_bind {
+ my ($self, $bind) = @_;
return ($self->_convert('?'), $self->_bindtype(@$bind));
}
-sub _where_op_LITERAL {
- my ($self, undef, $literal) = @_;
+sub _render_literal {
+ my ($self, $literal) = @_;
$self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
return @$literal;
}
sub _order_by {
my ($self, $arg) = @_;
- my (@sql, @bind);
- for my $c ($self->_order_by_chunks($arg) ) {
- $self->_SWITCH_refkind($c, {
- SCALAR => sub { push @sql, $c },
- ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
- });
- }
-
- my $sql = @sql
- ? sprintf('%s %s',
- $self->_sqlcase(' order by'),
- join(', ', @sql)
- )
- : ''
- ;
-
- return wantarray ? ($sql, @bind) : $sql;
-}
-
-sub _order_by_chunks {
- my ($self, $arg) = @_;
-
- return $self->_SWITCH_refkind($arg, {
-
- ARRAYREF => sub {
- map { $self->_order_by_chunks($_ ) } @$arg;
- },
-
- ARRAYREFREF => sub {
- my ($s, @b) = @$$arg;
- $self->_assert_bindval_matches_bindtype(@b);
- [ $s, @b ];
- },
+ return '' unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
- SCALAR => sub {$self->_quote($arg)},
+ my $expander = sub {
+ my ($self, $dir, $expr) = @_;
+ my @exp = map +(defined($dir) ? { -op => [ $dir => $_ ] } : $_),
+ map $self->_expand_expr($_, undef, -ident),
+ ref($expr) eq 'ARRAY' ? @$expr : $expr;
+ return (@exp > 1 ? { -op => [ ',', @exp ] } : $exp[0]);
+ };
- UNDEF => sub {return () },
+ local $self->{custom_expansions} = {
+ asc => sub { shift->$expander(asc => @_) },
+ desc => sub { shift->$expander(desc => @_) },
+ };
- SCALARREF => sub {$$arg}, # literal SQL, no quoting
+ my $expanded = $self->$expander(undef, $arg);
- HASHREF => sub {
- # get first pair in hash
- my ($key, $val, @rest) = %$arg;
+ my ($sql, @bind) = $self->_render_expr($expanded);
- return () unless $key;
+ my $final_sql = $self->_sqlcase(' order by ').$sql;
- if (@rest or not $key =~ /^-(desc|asc)/i) {
- puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
- }
-
- my $direction = $1;
-
- my @ret;
- for my $c ($self->_order_by_chunks($val)) {
- my ($sql, @bind);
-
- $self->_SWITCH_refkind($c, {
- SCALAR => sub {
- $sql = $c;
- },
- ARRAYREF => sub {
- ($sql, @bind) = @$c;
- },
- });
-
- $sql = $sql . ' ' . $self->_sqlcase($direction);
-
- push @ret, [ $sql, @bind];
- }
-
- return @ret;
- },
- });
+ return wantarray ? ($final_sql, @bind) : $final_sql;
}
-
#======================================================================
# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
#======================================================================
sub _table {
my $self = shift;
my $from = shift;
- $self->_SWITCH_refkind($from, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
- SCALAR => sub {$self->_quote($from)},
- SCALARREF => sub {$$from},
- });
+ ($self->_render_expr(
+ $self->_expand_maybe_list_expr($from, undef, -ident)
+ ))[0];
}
# UTILITY FUNCTIONS
#======================================================================
+sub _expand_maybe_list_expr {
+ my ($self, $expr, $logic, $default) = @_;
+ my $e = do {
+ if (ref($expr) eq 'ARRAY') {
+ return { -op => [
+ ',', map $self->_expand_expr($_, $logic, $default), @$expr
+ ] } if @$expr > 1;
+ $expr->[0]
+ } else {
+ $expr
+ }
+ };
+ return $self->_expand_expr($e, $logic, $default);
+}
+
# highly optimized, as it's called way too often
sub _quote {
# my ($self, $label) = @_;
return '' unless defined $_[1];
return ${$_[1]} if ref($_[1]) eq 'SCALAR';
+ puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH';
- $_[0]->{quote_char} or
- ($_[0]->_assert_pass_injection_guard($_[1]), return $_[1]);
+ unless ($_[0]->{quote_char}) {
+ if (ref($_[1]) eq 'ARRAY') {
+ return join($_[0]->{name_sep}||'.', @{$_[1]});
+ } else {
+ $_[0]->_assert_pass_injection_guard($_[1]);
+ return $_[1];
+ }
+ }
my $qref = ref $_[0]->{quote_char};
my ($l, $r) =
my $esc = $_[0]->{escape_char} || $r;
# parts containing * are naturally unquoted
- return join($_[0]->{name_sep}||'', map
- +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ),
- ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
+ return join(
+ $_[0]->{name_sep}||'',
+ map +(
+ $_ eq '*'
+ ? $_
+ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r }
+ ),
+ (ref($_[1]) eq 'ARRAY'
+ ? @{$_[1]}
+ : (
+ $_[0]->{name_sep}
+ ? split (/\Q$_[0]->{name_sep}\E/, $_[1] )
+ : $_[1]
+ )
+ )
);
}
# Conversion, if applicable
sub _convert {
#my ($self, $arg) = @_;
- if ($_[0]->{convert}) {
- return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
+ if ($_[0]->{convert_where}) {
+ return $_[0]->_sqlcase($_[0]->{convert_where}) .'(' . $_[1] . ')';
}
return $_[1];
}
projects / scpubgit/Q-Branch.git / blobdiff