# GLOBALS
#======================================================================
-our $VERSION = '1.64_01';
+our $VERSION = '1.71';
# This would confuse some packagers
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
# special operators (-in, -between). May be extended/overridden by user.
# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
my @BUILTIN_SPECIAL_OPS = (
- {regex => qr/^(not )?between$/i, handler => '_where_field_BETWEEN'},
- {regex => qr/^(not )?in$/i, handler => '_where_field_IN'},
+ {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'},
+ {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'},
);
# unaryish operators - key maps to handler
my @BUILTIN_UNARY_OPS = (
# the digits are backcompat stuff
- { regex => qr/^and (?: \s? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^or (?: \s? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^nest (?: \s? \d+ )? $/xi, handler => '_where_op_NEST' },
- { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
+ { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+ { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+ { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
+ { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
);
#======================================================================
},
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 $self->{_nested_func_lhs} = $k;
+ my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
+
+ push @set, "$label = $sql";
+ push @all_bind, @bind;
+ },
SCALAR_or_UNDEF => sub {
push @set, "$label = ?";
push @all_bind, $self->_bindtype($k, $v);
# skip empty elements, otherwise get invalid trailing AND stuff
ARRAYREF => sub {$self->_recurse_where($el) if @$el},
- ARRAYREFREF => sub { @{${$el}} if @{${$el}}},
+ ARRAYREFREF => sub {
+ my ($s, @b) = @$$el;
+ $self->_assert_bindval_matches_bindtype(@b);
+ ($s, @b);
+ },
HASHREF => sub {$self->_recurse_where($el, 'and') if %$el},
# LDNOTE : previous SQLA code for hashrefs was creating a dirty
sub _where_ARRAYREFREF {
my ($self, $where) = @_;
- my ($sql, @bind) = @{${$where}};
-
+ my ($sql, @bind) = @$$where;
+ $self->_assert_bindval_matches_bindtype(@bind);
return ($sql, @bind);
}
if ($k =~ /^-./) {
# put the operator in canonical form
my $op = $k;
- $op =~ s/^-//; # remove initial dash
- $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
+ $op = substr $op, 1; # remove initial dash
$op =~ s/^\s+|\s+$//g;# remove leading/trailing space
+ $op =~ s/\s+/ /g; # compress whitespace
- $self->_debug("Unary OP(-$op) within hashref, recursing...");
+ # so that -not_foo works correctly
+ $op =~ s/^not_/NOT /i;
- my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}};
- if (my $handler = $op_entry->{handler}) {
- if (not ref $handler) {
- if ($op =~ s/\s?\d+$//) {
- belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
- . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
- }
- $self->$handler ($op, $v);
- }
- elsif (ref $handler eq 'CODE') {
- $handler->($self, $op, $v);
- }
- else {
- puke "Illegal handler for operator $k - expecting a method name or a coderef";
- }
- }
- else {
- $self->debug("Generic unary OP: $k - recursing as function");
- my ($sql, @bind) = $self->_where_func_generic ($op, $v);
- $sql = "($sql)" unless $self->{_nested_func_lhs} eq $k; # top level vs nested
- ($sql, @bind);
- }
+ $self->_debug("Unary OP(-$op) within hashref, recursing...");
+ my ($s, @b) = $self->_where_unary_op ($op, $v);
+
+ # top level vs nested
+ # we assume that handled unary ops will take care of their ()s
+ $s = "($s)" unless (
+ List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}
+ or
+ defined($self->{_nested_func_lhs}) && ($self->{_nested_func_lhs} eq $k)
+ );
+ ($s, @b);
}
else {
my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
}
-sub _where_func_generic {
+sub _where_unary_op {
my ($self, $op, $rhs) = @_;
+ if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) {
+ my $handler = $op_entry->{handler};
+
+ if (not ref $handler) {
+ if ($op =~ s/ [_\s]? \d+ $//x ) {
+ belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
+ . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
+ }
+ return $self->$handler ($op, $rhs);
+ }
+ elsif (ref $handler eq 'CODE') {
+ return $handler->($self, $op, $rhs);
+ }
+ else {
+ puke "Illegal handler for operator $op - expecting a method name or a coderef";
+ }
+ }
+
+ $self->debug("Generic unary OP: $op - recursing as function");
+
my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
SCALAR => sub {
puke "Illegal use of top-level '$op'"
sub _where_op_BOOL {
my ($self, $op, $v) = @_;
- my ( $prefix, $suffix ) = ( $op =~ /\bnot\b/i )
- ? ( '(NOT ', ')' )
- : ( '', '' );
-
- my ($sql, @bind) = do {
- $self->_SWITCH_refkind($v, {
- SCALAR => sub { # interpreted as SQL column
- $self->_convert($self->_quote($v));
- },
+ my ($s, @b) = $self->_SWITCH_refkind($v, {
+ SCALAR => sub { # interpreted as SQL column
+ $self->_convert($self->_quote($v));
+ },
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
+ UNDEF => sub {
+ puke "-$op => undef not supported";
+ },
- FALLBACK => sub {
- $self->_recurse_where ($v);
- },
- });
- };
+ FALLBACK => sub {
+ $self->_recurse_where ($v);
+ },
+ });
- return (
- join ('', $prefix, $sql, $suffix),
- @bind,
- );
+ $s = "(NOT $s)" if $op =~ /^not/i;
+ ($s, @b);
}
# put the operator in canonical form
my $op = $orig_op;
- $op =~ s/^-//; # remove initial dash
- $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
+
+ # FIXME - we need to phase out dash-less ops
+ $op =~ s/^-//; # remove possible initial dash
$op =~ s/^\s+|\s+$//g;# remove leading/trailing space
+ $op =~ s/\s+/ /g; # compress whitespace
+
+ # so that -not_foo works correctly
+ $op =~ s/^not_/NOT /i;
my ($sql, @bind);
# retain for proper column type bind
$self->{_nested_func_lhs} ||= $k;
- ($sql, @bind) = $self->_where_func_generic ($op, $val);
+ ($sql, @bind) = $self->_where_unary_op ($op, $val);
$sql = join (' ',
$self->_convert($self->_quote($k)),
sub _where_hashpair_ARRAYREFREF {
my ($self, $k, $v) = @_;
$self->_debug("REF($k) means literal SQL: @${$v}");
- my ($sql, @bind) = @${$v};
+ my ($sql, @bind) = @$$v;
$self->_assert_bindval_matches_bindtype(@bind);
$sql = $self->_quote($k) . " " . $sql;
return ($sql, @bind );
my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
ARRAYREFREF => sub {
- return @$$vals;
+ my ($s, @b) = @$$vals;
+ $self->_assert_bindval_matches_bindtype(@b);
+ ($s, @b);
},
SCALARREF => sub {
return $$vals;
foreach my $val (@$vals) {
my ($sql, @bind) = $self->_SWITCH_refkind($val, {
SCALAR => sub {
- return ($placeholder, ($val));
+ return ($placeholder, $val);
},
SCALARREF => sub {
- return ($self->_convert($$val), ());
+ return $$val;
},
ARRAYREFREF => sub {
my ($sql, @bind) = @$$val;
- return ($self->_convert($sql), @bind);
+ $self->_assert_bindval_matches_bindtype(@bind);
+ return ($sql, @bind);
},
+ HASHREF => sub {
+ my ($func, $arg, @rest) = %$val;
+ puke ("Only simple { -func => arg } functions accepted as sub-arguments to BETWEEN")
+ if (@rest or $func !~ /^ \- (.+)/x);
+ local $self->{_nested_func_lhs} = $k;
+ $self->_where_unary_op ($1 => $arg);
+ }
});
push @all_sql, $sql;
push @all_bind, @bind;
my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
ARRAYREF => sub { # list of choices
if (@$vals) { # nonempty list
- my $placeholders = join ", ", (($placeholder) x @$vals);
- my $sql = "$label $op ( $placeholders )";
- my @bind = $self->_bindtype($k, @$vals);
+ my (@all_sql, @all_bind);
+
+ for my $val (@$vals) {
+ my ($sql, @bind) = $self->_SWITCH_refkind($val, {
+ SCALAR => sub {
+ return ($placeholder, $val);
+ },
+ SCALARREF => sub {
+ return $$val;
+ },
+ ARRAYREFREF => sub {
+ my ($sql, @bind) = @$$val;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ return ($sql, @bind);
+ },
+ HASHREF => sub {
+ my ($func, $arg, @rest) = %$val;
+ puke ("Only simple { -func => arg } functions accepted as sub-arguments to IN")
+ if (@rest or $func !~ /^ \- (.+)/x);
+ local $self->{_nested_func_lhs} = $k;
+ $self->_where_unary_op ($1 => $arg);
+ }
+ });
+ push @all_sql, $sql;
+ push @all_bind, @bind;
+ }
- return ($sql, @bind);
+ return (
+ sprintf ('%s %s ( %s )',
+ $label,
+ $op,
+ join (', ', @all_sql)
+ ),
+ $self->_bindtype($k, @all_bind),
+ );
}
else { # empty list : some databases won't understand "IN ()", so DWIM
my $sql = ($op =~ /\bnot\b/i) ? $self->{sqltrue} : $self->{sqlfalse};
map { $self->_order_by_chunks ($_ ) } @$arg;
},
- ARRAYREFREF => sub { [ @$$arg ] },
+ ARRAYREFREF => sub {
+ my ($s, @b) = @$$arg;
+ $self->_assert_bindval_matches_bindtype(@b);
+ [ $s, @b ];
+ },
SCALAR => sub {$self->_quote($arg)},
HASHREF => sub {
# get first pair in hash
- my ($key, $val) = each %$arg;
+ my ($key, $val, @rest) = %$arg;
return () unless $key;
- if ( (keys %$arg) > 1 or not $key =~ /^-(desc|asc)/i ) {
+ if ( @rest or not $key =~ /^-(desc|asc)/i ) {
puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
}
# UTILITY FUNCTIONS
#======================================================================
+# highly optimized, as it's called way too often
sub _quote {
- my $self = shift;
- my $label = shift;
+ # my ($self, $label) = @_;
- $label or puke "can't quote an empty label";
+ return '' unless defined $_[1];
+ return ${$_[1]} if ref($_[1]) eq 'SCALAR';
- # left and right quote characters
- my ($ql, $qr, @other) = $self->_SWITCH_refkind($self->{quote_char}, {
- SCALAR => sub {($self->{quote_char}, $self->{quote_char})},
- ARRAYREF => sub {@{$self->{quote_char}}},
- UNDEF => sub {()},
- });
- not @other
- or puke "quote_char must be an arrayref of 2 values";
-
- # no quoting if no quoting chars
- $ql or return $label;
-
- # no quoting for literal SQL
- return $$label if ref($label) eq 'SCALAR';
+ return $_[1] unless $_[0]->{quote_char};
- # separate table / column (if applicable)
- my $sep = $self->{name_sep} || '';
- my @to_quote = $sep ? split /\Q$sep\E/, $label : ($label);
-
- # do the quoting, except for "*" or for `table`.*
- my @quoted = map { $_ eq '*' ? $_: $ql.$_.$qr} @to_quote;
+ my $qref = ref $_[0]->{quote_char};
+ my ($l, $r);
+ if (!$qref) {
+ ($l, $r) = ( $_[0]->{quote_char}, $_[0]->{quote_char} );
+ }
+ elsif ($qref eq 'ARRAY') {
+ ($l, $r) = @{$_[0]->{quote_char}};
+ }
+ else {
+ puke "Unsupported quote_char format: $_[0]->{quote_char}";
+ }
- # reassemble and return.
- return join $sep, @quoted;
+ # parts containing * are naturally unquoted
+ return join( $_[0]->{name_sep}||'', map
+ { $_ eq '*' ? $_ : $l . $_ . $r }
+ ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
+ );
}
# Conversion, if applicable
sub _convert ($) {
- my ($self, $arg) = @_;
+ #my ($self, $arg) = @_;
# LDNOTE : modified the previous implementation below because
# it was not consistent : the first "return" is always an array,
# my $conv = $self->_sqlcase($self->{convert});
# my @ret = map { $conv.'('.$_.')' } @_;
# return wantarray ? @ret : $ret[0];
- if ($self->{convert}) {
- my $conv = $self->_sqlcase($self->{convert});
- $arg = $conv.'('.$arg.')';
+ if ($_[0]->{convert}) {
+ return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
}
- return $arg;
+ return $_[1];
}
# And bindtype
sub _bindtype (@) {
- my $self = shift;
- my($col, @vals) = @_;
+ #my ($self, $col, @vals) = @_;
#LDNOTE : changed original implementation below because it did not make
# sense when bindtype eq 'columns' and @vals > 1.
# return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
- return $self->{bindtype} eq 'columns' ? map {[$col, $_]} @vals : @vals;
+ # called often - tighten code
+ return $_[0]->{bindtype} eq 'columns'
+ ? map {[$_[1], $_]} @_[2 .. $#_]
+ : @_[2 .. $#_]
+ ;
}
# Dies if any element of @bind is not in [colname => value] format
# if bindtype is 'columns'.
sub _assert_bindval_matches_bindtype {
- my ($self, @bind) = @_;
-
+# my ($self, @bind) = @_;
+ my $self = shift;
if ($self->{bindtype} eq 'columns') {
- foreach my $val (@bind) {
- if (!defined $val || ref($val) ne 'ARRAY' || @$val != 2) {
- die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
+ for (@_) {
+ if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
+ puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
}
}
}
# Fix SQL case, if so requested
sub _sqlcase {
- my $self = shift;
-
# LDNOTE: if $self->{case} is true, then it contains 'lower', so we
# don't touch the argument ... crooked logic, but let's not change it!
- return $self->{case} ? $_[0] : uc($_[0]);
+ return $_[0]->{case} ? $_[1] : uc($_[1]);
}
sub _refkind {
my ($self, $data) = @_;
- my $suffix = '';
- my $ref;
- my $n_steps = 0;
- while (1) {
- # blessed objects are treated like scalars
- $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
- $n_steps += 1 if $ref;
- last if $ref ne 'REF';
- $data = $$data;
- }
+ return 'UNDEF' unless defined $data;
- my $base = $ref || (defined $data ? 'SCALAR' : 'UNDEF');
+ # blessed objects are treated like scalars
+ my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
- return $base . ('REF' x $n_steps);
-}
+ return 'SCALAR' unless $ref;
+ my $n_steps = 1;
+ while ($ref eq 'REF') {
+ $data = $$data;
+ $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
+ $n_steps++ if $ref;
+ }
+ return ($ref||'SCALAR') . ('REF' x $n_steps);
+}
sub _try_refkind {
my ($self, $data) = @_;
my @try = ($self->_refkind($data));
push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF';
push @try, 'FALLBACK';
- return @try;
+ return \@try;
}
sub _METHOD_FOR_refkind {
my ($self, $meth_prefix, $data) = @_;
my $method;
- for ($self->_try_refkind($data)) {
+ for (@{$self->_try_refkind($data)}) {
$method = $self->can($meth_prefix."_".$_)
and last;
}
my ($self, $data, $dispatch_table) = @_;
my $coderef;
- for ($self->_try_refkind($data)) {
+ for (@{$self->_try_refkind($data)}) {
$coderef = $dispatch_table->{$_}
and last;
}
A field associated to an empty arrayref will be considered a
logical false and will generate 0=1.
+=head2 Tests for NULL values
+
+If the value part is C<undef> then this is converted to SQL <IS NULL>
+
+ my %where = (
+ user => 'nwiger',
+ status => undef,
+ );
+
+becomes:
+
+ $stmt = "WHERE user = ? AND status IS NULL";
+ @bind = ('nwiger');
+
=head2 Specific comparison operators
If you want to specify a different type of operator for your comparison,
If you wish to test against boolean columns or functions within your
database you can use the C<-bool> and C<-not_bool> operators. For
example to test the column C<is_user> being true and the column
-<is_enabled> being false you would use:-
+C<is_enabled> being false you would use:-
my %where = (
-bool => 'is_user',
$stmt = "WHERE priority < ? AND is_ready";
@bind = ('2');
+Literal SQL is also the only way to compare 2 columns to one another:
+
+ my %where = (
+ priority => { '<', 2 },
+ requestor => \'= submittor'
+ );
+
+which creates:
+
+ $stmt = "WHERE priority < ? AND requestor = submitter";
+ @bind = ('2');
=head2 Literal SQL with placeholders and bind values (subqueries)
around. On subsequent queries, simply use the C<values> function provided
by this module to return your values in the correct order.
+However this depends on the values having the same type - if, for
+example, the values of a where clause may either have values
+(resulting in sql of the form C<column = ?> with a single bind
+value), or alternatively the values might be C<undef> (resulting in
+sql of the form C<column IS NULL> with no bind value) then the
+caching technique suggested will not work.
=head1 FORMBUILDER
use these three modules together to write complex database query
apps in under 50 lines.
+=head1 REPO
+
+=over
+
+=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git>
+
+=item * git: L<git://git.shadowcat.co.uk/dbsrgits/DBIx-Class.git>
+
+=back
=head1 CHANGES
projects / dbsrgits/SQL-Abstract.git / blobdiff