^ \s* go \s
/xmi;
+ $opt{node_types} = +{
+ map +("-$_" => '_render_'.$_),
+ qw(op func value bind ident literal)
+ };
+
+ $opt{expand_unary} = {};
+
return bless \%opt, $class;
}
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
# 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]);
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 '' 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]
+ )
+ )
);
}
projects / scpubgit/Q-Branch.git / blobdiff