^ \s* go \s
/xmi;
+ $opt{node_types} = +{
+ map +("-$_" => '_render_'.$_),
+ qw(op func value bind ident literal)
+ };
+
+ $opt{expand_unary} = {};
+
return bless \%opt, $class;
}
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)
# top level special ops are illegal in general
puke "Illegal use of top-level '-$op'"
if List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+ return { -op => [ $op, $v ] };
+ }
}
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]}) {
+ if (my $custom = $self->{expand_unary}{$k}) {
return $self->$custom($v);
}
+ if ($self->{node_types}{$k}) {
+ return { $k => $v };
+ }
if (
ref($v) eq 'HASH'
and keys %$v == 1
return $self->_expand_expr_hashpair($k => { $self->{cmp} => undef });
}
if (!ref($v) or Scalar::Util::blessed($v)) {
+ my $d = our $Default_Scalar_To;
return +{
-op => [
$self->{cmp},
{ -ident => $k },
- { -bind => [ $k, $v ] }
+ ($d ? { $d => $v } : { -bind => [ $k, $v ] })
]
};
}
] };
}
if ($vk eq 'ident') {
- if (! defined $vv or ref $vv) {
- puke "-$vk requires a single plain scalar argument (a quotable identifier)";
+ if (! defined $vv or (ref($vv) and ref($vv) eq 'ARRAY')) {
+ puke "-$vk requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
}
return +{ -op => [
$self->{cmp},
if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{user_special_ops}}) {
return { -op => [ $vk, { -ident => $k }, $vv ] };
}
+ if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{unary_ops}}) {
+ return { -op => [
+ $self->{cmp},
+ { -ident => $k },
+ { -op => [ $vk, $vv ] }
+ ] };
+ }
if (ref($vv) eq 'ARRAY') {
my ($logic, @values) = (
(defined($vv->[0]) and $vv->[0] =~ /^-(and|or)$/i)
my ($self, $expr) = @_;
my ($k, $v, @rest) = %$expr;
die "No" if @rest;
- my %op = map +("-$_" => '_render_'.$_),
- qw(op func value bind ident literal);
- if (my $meth = $op{$k}) {
+ if (my $meth = $self->{node_types}{$k}) {
return $self->$meth($v);
}
die "notreached: $k";
unless my ($k) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
return $self->${\($us->{handler})}($k, $op, $args[1]);
}
+ if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+ return $self->${\($us->{handler})}($op, $args[0]);
+ }
my $final_op = $op =~ /^(?:is|not)_/ ? join(' ', split '_', $op) : $op;
if (@args == 1 and $op !~ /^(and|or)$/) {
my ($expr_sql, @bind) = $self->_render_expr($args[0]);
} 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 (
return (@exp > 1 ? { -op => [ ',', @exp ] } : $exp[0]);
};
- local $self->{custom_expansions} = {
- asc => sub { shift->$expander(asc => @_) },
- desc => sub { shift->$expander(desc => @_) },
- };
+ local @{$self->{expand_unary}}{qw(-asc -desc)} = (
+ sub { shift->$expander(asc => @_) },
+ sub { shift->$expander(desc => @_) },
+ );
my $expanded = $self->$expander(undef, $arg);
return wantarray ? ($final_sql, @bind) : $final_sql;
}
-sub _order_by_chunks {
- my ($self, $arg) = @_;
-
- if (ref($arg) eq 'ARRAY') {
- return map $self->_order_by_chunks($_), @$arg;
- }
- if (my $l = is_literal_value($arg)) {
- return +{ -literal => $l };
- }
- if (!ref($arg)) {
- return +{ -ident => $arg };
- }
- if (ref($arg) eq 'HASH') {
- my ($key, $val, @rest) = %$arg;
-
- return () unless $key;
-
- if (@rest or not $key =~ /^-(desc|asc)/i) {
- puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
- }
-
- my $dir = $1;
-
- map +{ -op => [ $dir, $_ ] }, $self->_order_by_chunks($val);
- };
-}
-
-
#======================================================================
# 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