package SQL::Abstract; # see doc at end of file
-# LDNOTE : this code is heavy refactoring from original SQLA.
-# Several design decisions will need discussion during
-# the test / diffusion / acceptance phase; those are marked with flag
-# 'LDNOTE' (note by laurent.dami AT free.fr)
-
use strict;
use warnings;
use Carp ();
use List::Util ();
use Scalar::Util ();
+use Exporter 'import';
+our @EXPORT_OK = qw(is_plain_value is_literal_value);
+
+BEGIN {
+ if ($] < 5.009_005) {
+ require MRO::Compat;
+ }
+ else {
+ require mro;
+ }
+
+ *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
+ ? sub () { 0 }
+ : sub () { 1 }
+ ;
+}
+
#======================================================================
# GLOBALS
#======================================================================
-our $VERSION = '1.73';
+our $VERSION = '1.81_01';
# This would confuse some packagers
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
{regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'},
{regex => qr/^ ident $/ix, handler => '_where_op_IDENT'},
{regex => qr/^ value $/ix, handler => '_where_op_VALUE'},
+ {regex => qr/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'},
);
# unaryish operators - key maps to handler
{ regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
{ regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
{ regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
- { regex => qr/^ value $/ix, handler => '_where_op_VALUE' },
+ { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
);
#======================================================================
Carp::croak "[$func] Fatal: ", @_;
}
+sub is_literal_value ($) {
+ ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
+ : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
+ : undef;
+}
+
+# FIXME XSify - this can be done so much more efficiently
+sub is_plain_value ($) {
+ no strict 'refs';
+ ! length ref $_[0] ? \($_[0])
+ : (
+ ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
+ and
+ exists $_[0]->{-value}
+ ) ? \($_[0]->{-value})
+ : (
+ # reuse @_ for even moar speedz
+ defined ( $_[1] = Scalar::Util::blessed $_[0] )
+ and
+ # deliberately not using Devel::OverloadInfo - the checks we are
+ # intersted in are much more limited than the fullblown thing, and
+ # this is a very hot piece of code
+ (
+ # simply using ->can('(""') can leave behind stub methods that
+ # break actually using the overload later (see L<perldiag/Stub
+ # found while resolving method "%s" overloading "%s" in package
+ # "%s"> and the source of overload::mycan())
+ #
+ # either has stringification which DBI SHOULD prefer out of the box
+ grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
+ or
+ # has nummification or boolification, AND fallback is *not* disabled
+ (
+ SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
+ and
+ (
+ grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
+ or
+ grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
+ )
+ and
+ (
+ # no fallback specified at all
+ ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
+ or
+ # fallback explicitly undef
+ ! defined ${"$_[3]::()"}
+ or
+ # explicitly true
+ !! ${"$_[3]::()"}
+ )
+ )
+ )
+ ) ? \($_[0])
+ : undef;
+}
+
+
#======================================================================
# NEW
$opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
# how to return bind vars
- # LDNOTE: changed nwiger code : why this 'delete' ??
- # $opt{bindtype} ||= delete($opt{bind_type}) || 'normal';
$opt{bindtype} ||= 'normal';
# default comparison is "=", but can be overridden
$opt{cmp} ||= '=';
- # try to recognize which are the 'equality' and 'unequality' ops
- # (temporary quickfix, should go through a more seasoned API)
- $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
- $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
+ # try to recognize which are the 'equality' and 'inequality' ops
+ # (temporary quickfix (in 2007), should go through a more seasoned API)
+ $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix;
+ $opt{inequality_op} = qr/^( != | <> )$/ix;
+
+ $opt{like_op} = qr/^ (is\s+)? r?like $/xi;
+ $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi;
# SQL booleans
$opt{sqltrue} ||= '1=1';
$opt{unary_ops} ||= [];
push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
- # rudimentary saniy-check for user supplied bits treated as functions/operators
+ # rudimentary sanity-check for user supplied bits treated as functions/operators
# If a purported function matches this regular expression, an exception is thrown.
# Literal SQL is *NOT* subject to this check, only functions (and column names
# when quoting is not in effect)
return wantarray ? ($sql, @bind) : $sql;
}
-sub _insert_returning {
+# Used by DBIx::Class::SQLMaker->insert
+sub _insert_returning { shift->_returning(@_) }
+
+sub _returning {
my ($self, $options) = @_;
my $f = $options->{returning};
$self->{bindtype} ne 'columns'
or belch "can't do 'columns' bindtype when called with arrayref";
- # fold the list of values into a hash of column name - value pairs
- # (where the column names are artificially generated, and their
- # lexicographical ordering keep the ordering of the original list)
- my $i = "a"; # incremented values will be in lexicographical order
- my $data_in_hash = { map { ($i++ => $_) } @$data };
-
- return $self->_insert_values($data_in_hash);
+ my (@values, @all_bind);
+ foreach my $value (@$data) {
+ my ($values, @bind) = $self->_insert_value(undef, $value);
+ push @values, $values;
+ push @all_bind, @bind;
+ }
+ my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ return ($sql, @all_bind);
}
sub _insert_ARRAYREFREF { # literal SQL with bind
my (@values, @all_bind);
foreach my $column (sort keys %$data) {
- my $v = $data->{$column};
+ my ($values, @bind) = $self->_insert_value($column, $data->{$column});
+ push @values, $values;
+ push @all_bind, @bind;
+ }
+ my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ return ($sql, @all_bind);
+}
- $self->_SWITCH_refkind($v, {
+sub _insert_value {
+ my ($self, $column, $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;
- }
- },
+ my (@values, @all_bind);
+ $self->_SWITCH_refkind($v, {
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$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;
- },
+ }
+ },
- # 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);
- },
+ ARRAYREFREF => sub { # literal SQL with bind
+ my ($sql, @bind) = @${$v};
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @values, $sql;
+ push @all_bind, @bind;
+ },
- SCALARREF => sub { # literal SQL without bind
- push @values, $$v;
- },
+ # 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);
+ },
- SCALAR_or_UNDEF => sub {
- 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);
+ },
- }
+ });
- my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ my $sql = join(", ", @values);
return ($sql, @all_bind);
}
sub update {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+ my $where = shift;
+ my $options = shift;
# first build the 'SET' part of the sql statement
my (@set, @all_bind);
push @all_bind, @where_bind;
}
+ if ($options->{returning}) {
+ my ($returning_sql, @returning_bind) = $self->_update_returning ($options);
+ $sql .= $returning_sql;
+ push @all_bind, @returning_bind;
+ }
+
return wantarray ? ($sql, @all_bind) : $sql;
}
+sub _update_returning { shift->_returning(@_) }
# order by?
if ($order) {
- $sql .= $self->_order_by($order);
+ my ($order_sql, @order_bind) = $self->_order_by($order);
+ $sql .= $order_sql;
+ push @bind, @order_bind;
}
return wantarray ? ($sql, @bind) : $sql;
my ($sql, @bind) = $self->$method($where, $logic);
- # DBIx::Class directly calls _recurse_where in scalar context, so
- # we must implement it, even if not in the official API
- return wantarray ? ($sql, @bind) : $sql;
+ # DBIx::Class used to call _recurse_where in scalar context
+ # something else might too...
+ if (wantarray) {
+ return ($sql, @bind);
+ }
+ else {
+ belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
+ return $sql;
+ }
}
my (@sql_clauses, @all_bind);
# need to use while() so can shift() for pairs
- while (my $el = shift @clauses) {
+ while (@clauses) {
+ my $el = shift @clauses;
+
+ $el = undef if (defined $el and ! length $el);
# switch according to kind of $el and get corresponding ($sql, @bind)
my ($sql, @bind) = $self->_SWITCH_refkind($el, {
},
HASHREF => sub {$self->_recurse_where($el, 'and') if %$el},
- # LDNOTE : previous SQLA code for hashrefs was creating a dirty
- # side-effect: the first hashref within an array would change
- # the global logic to 'AND'. So [ {cond1, cond2}, [cond3, cond4] ]
- # was interpreted as "(cond1 AND cond2) OR (cond3 AND cond4)",
- # whereas it should be "(cond1 AND cond2) OR (cond3 OR cond4)".
SCALARREF => sub { ($$el); },
- SCALAR => sub {# top-level arrayref with scalars, recurse in pairs
- $self->_recurse_where({$el => shift(@clauses)})},
+ SCALAR => sub {
+ # top-level arrayref with scalars, recurse in pairs
+ $self->_recurse_where({$el => shift(@clauses)})
+ },
- UNDEF => sub {puke "not supported : UNDEF in arrayref" },
+ UNDEF => sub {puke "Supplying an empty left hand side argument is not supported in array-pairs" },
});
if ($sql) {
$s = "($s)" unless (
List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}
or
- defined($self->{_nested_func_lhs}) && ($self->{_nested_func_lhs} eq $k)
+ ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k )
);
($s, @b);
}
else {
+ if (! length $k) {
+ if (is_literal_value ($v) ) {
+ belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
+ }
+ else {
+ puke "Supplying an empty left hand side argument is not supported in hash-pairs";
+ }
+ }
+
my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
$self->$method($k, $v);
}
sub _where_unary_op {
my ($self, $op, $rhs) = @_;
+ # top level special ops are illegal in general
+ # this includes the -ident/-value ops (dual purpose unary and special)
+ puke "Illegal use of top-level '-$op'"
+ if ! defined $self->{_nested_func_lhs} and List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}};
+
if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) {
my $handler = $op_entry->{handler};
my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
SCALAR => sub {
- puke "Illegal use of top-level '$op'"
- unless $self->{_nested_func_lhs};
+ puke "Illegal use of top-level '-$op'"
+ unless defined $self->{_nested_func_lhs};
return (
$self->_convert('?'),
sub _where_op_IDENT {
my $self = shift;
my ($op, $rhs) = splice @_, -2;
- if (ref $rhs) {
- puke "-$op takes a single scalar argument (a quotable identifier)";
+ 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 '=')
# 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->_convert($self->_quote($lhs)) . ' IS NULL'
+ : undef
+ ;
+ }
+
my @bind =
$self->_bindtype (
- ($lhs || $self->{_nested_func_lhs}),
+ ( defined $lhs ? $lhs : $self->{_nested_func_lhs} ),
$rhs,
)
;
return $self->_recurse_where(\@distributed, $logic);
}
else {
- # LDNOTE : not sure of this one. What does "distribute over nothing" mean?
$self->_debug("empty ARRAY($k) means 0=1");
return ($self->{sqlfalse});
}
my ($self, $k, $v, $logic) = @_;
$logic ||= 'and';
- local $self->{_nested_func_lhs} = $self->{_nested_func_lhs};
+ local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs}
+ ? $self->{_nested_func_lhs}
+ : $k
+ ;
my ($all_sql, @all_bind);
$self->_assert_pass_injection_guard($op);
+ # fixup is_not
+ $op =~ s/^is_not/IS NOT/i;
+
# so that -not_foo works correctly
$op =~ s/^not_/NOT /i;
+ # another retarded special case: foo => { $op => { -value => undef } }
+ if (ref $val eq 'HASH' and keys %$val == 1 and exists $val->{-value} and ! defined $val->{-value} ) {
+ $val = undef;
+ }
+
my ($sql, @bind);
# CASE: col-value logic modifiers
},
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
- my $is = ($op =~ $self->{equality_op}) ? 'is' :
- ($op =~ $self->{inequality_op}) ? 'is not' :
- puke "unexpected operator '$orig_op' with undef operand";
+ my $is =
+ $op =~ /^not$/i ? 'is not' # legacy
+ : $op =~ $self->{equality_op} ? 'is'
+ : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
+ : $op =~ $self->{inequality_op} ? 'is not'
+ : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
+ : puke "unexpected operator '$orig_op' with undef operand";
+
$sql = $self->_quote($k) . $self->_sqlcase(" $is null");
},
FALLBACK => sub { # CASE: col => {op/func => $stuff}
-
- # retain for proper column type bind
- $self->{_nested_func_lhs} ||= $k;
-
($sql, @bind) = $self->_where_unary_op ($op, $val);
$sql = join (' ',
return ($all_sql, @all_bind);
}
+sub _where_field_IS {
+ my ($self, $k, $op, $v) = @_;
+
+ my ($s) = $self->_SWITCH_refkind($v, {
+ UNDEF => sub {
+ join ' ',
+ $self->_convert($self->_quote($k)),
+ map { $self->_sqlcase($_)} ($op, 'null')
+ },
+ FALLBACK => sub {
+ puke "$op can only take undef as argument";
+ },
+ });
+ $s;
+}
sub _where_field_op_ARRAYREF {
my ($self, $k, $op, $vals) = @_;
shift @vals;
}
+ # a long standing API wart - an attempt to change this behavior during
+ # the 1.50 series failed *spectacularly*. Warn instead and leave the
+ # behavior as is
+ if (
+ @vals > 1
+ and
+ (!$logic or $logic eq 'OR')
+ and
+ ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} )
+ ) {
+ my $o = uc($op);
+ belch "A multi-element arrayref as an argument to the inequality op '$o' "
+ . 'is technically equivalent to an always-true 1=1 (you probably wanted '
+ . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
+ ;
+ }
+
# distribute $op over each remaining member of @vals, append logic if exists
return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
- # LDNOTE : had planned to change the distribution logic when
- # $op =~ $self->{inequality_op}, because of Morgan laws :
- # with {field => {'!=' => [22, 33]}}, it would be ridiculous to generate
- # WHERE field != 22 OR field != 33 : the user probably means
- # WHERE field != 22 AND field != 33.
- # To do this, replace the above to roughly :
- # my $logic = ($op =~ $self->{inequality_op}) ? 'AND' : 'OR';
- # return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
-
}
else {
# try to DWIM on equality operators
- # LDNOTE : not 100% sure this is the correct thing to do ...
- return ($self->{sqlfalse}) if $op =~ $self->{equality_op};
- return ($self->{sqltrue}) if $op =~ $self->{inequality_op};
-
- # otherwise
- puke "operator '$op' applied on an empty array (field '$k')";
+ return
+ $op =~ $self->{equality_op} ? $self->{sqlfalse}
+ : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse}
+ : $op =~ $self->{inequality_op} ? $self->{sqltrue}
+ : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue}
+ : puke "operator '$op' applied on an empty array (field '$k')";
}
}
$placeholder = $self->_convert('?');
$op = $self->_sqlcase($op);
+ my $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
+
my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
ARRAYREFREF => sub {
my ($s, @b) = @$$vals;
return $$vals;
},
ARRAYREF => sub {
- puke "special op 'between' accepts an arrayref with exactly two values"
- if @$vals != 2;
+ puke $invalid_args if @$vals != 2;
my (@all_sql, @all_bind);
foreach my $val (@$vals) {
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);
- }
+ },
+ FALLBACK => sub {
+ puke $invalid_args,
+ },
});
push @all_sql, $sql;
push @all_bind, @bind;
);
},
FALLBACK => sub {
- puke "special op 'between' accepts an arrayref with two values, or a single literal scalarref/arrayref-ref";
+ puke $invalid_args,
},
});
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);
},
UNDEF => sub {
- return $self->_sqlcase('null');
+ puke(
+ 'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
+ . "-$op operator was given an undef-containing list: !!!AUDIT YOUR CODE "
+ . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
+ . 'will emit the logically correct SQL instead of raising this exception)'
+ );
},
});
push @all_sql, $sql;
return ("$label $op ( $sql )", @bind);
},
+ UNDEF => sub {
+ puke "Argument passed to the '$op' operator can not be undefined";
+ },
+
FALLBACK => sub {
- puke "special op 'in' requires an arrayref (or scalarref/arrayref-ref)";
+ puke "special op $op requires an arrayref (or scalarref/arrayref-ref)";
},
});
# adding them back in the corresponding method
sub _open_outer_paren {
my ($self, $sql) = @_;
- $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
- return $sql;
+
+ while ( my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs ) {
+
+ # there are closing parens inside, need the heavy duty machinery
+ # to reevaluate the extraction starting from $sql (full reevaluation)
+ if ( $inner =~ /\)/ ) {
+ require Text::Balanced;
+
+ my (undef, $remainder) = do {
+ # idiotic design - writes to $@ but *DOES NOT* throw exceptions
+ local $@;
+ Text::Balanced::extract_bracketed( $sql, '()', qr/\s*/ );
+ };
+
+ # the entire expression needs to be a balanced bracketed thing
+ # (after an extract no remainder sans trailing space)
+ last if defined $remainder and $remainder =~ /\S/;
+ }
+
+ $sql = $inner;
+ }
+
+ $sql;
}
SCALARREF => sub {$$arg}, # literal SQL, no quoting
HASHREF => sub {
- return () unless %$arg;
-
- my ($direction, $nulls, $val);
- foreach my $key (keys %$arg) {
- if ( $key =~ /^-(desc|asc)/i ) {
- puke "hash passed to _order_by must have exactly one of -desc or -asc"
- if defined $direction;
- $direction = $1;
- $val = $arg->{$key};
- } elsif ($key =~ /^-nulls$/i) {
- $nulls = $arg->{$key};
- puke "invalid value for -nulls" unless $nulls =~ /^(?:first|last)$/i;
- } else {
- puke "invalid key in hash passed to _order_by";
- }
+ # get first pair in 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)";
}
- puke "hash passed to _order_by must have exactly one of -desc or -asc"
- unless defined $direction;
+
+ my $direction = $1;
my @ret;
for my $c ($self->_order_by_chunks ($val)) {
},
});
- $sql .= ' ' . $self->_sqlcase($direction);
- $sql .= ' ' . $self->_sqlcase("nulls $nulls")
- if defined $nulls;
+ $sql = $sql . ' ' . $self->_sqlcase($direction);
push @ret, [ $sql, @bind];
}
return '' unless defined $_[1];
return ${$_[1]} if ref($_[1]) eq 'SCALAR';
- unless ($_[0]->{quote_char}) {
- $_[0]->_assert_pass_injection_guard($_[1]);
- return $_[1];
- }
+ $_[0]->{quote_char} or
+ ($_[0]->_assert_pass_injection_guard($_[1]), return $_[1]);
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}";
- }
+ my ($l, $r) =
+ !$qref ? ($_[0]->{quote_char}, $_[0]->{quote_char})
+ : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
+ : puke "Unsupported quote_char format: $_[0]->{quote_char}";
+
+ my $esc = $_[0]->{escape_char} || $r;
# parts containing * are naturally unquoted
return join( $_[0]->{name_sep}||'', map
- { $_ eq '*' ? $_ : $l . $_ . $r }
+ +( $_ 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] )
);
}
# Conversion, if applicable
-sub _convert ($) {
+sub _convert {
#my ($self, $arg) = @_;
-
-# LDNOTE : modified the previous implementation below because
-# it was not consistent : the first "return" is always an array,
-# the second "return" is context-dependent. Anyway, _convert
-# seems always used with just a single argument, so make it a
-# scalar function.
-# return @_ unless $self->{convert};
-# my $conv = $self->_sqlcase($self->{convert});
-# my @ret = map { $conv.'('.$_.')' } @_;
-# return wantarray ? @ret : $ret[0];
if ($_[0]->{convert}) {
return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
}
}
# And bindtype
-sub _bindtype (@) {
+sub _bindtype {
#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;
-
# called often - tighten code
return $_[0]->{bindtype} eq 'columns'
? map {[$_[1], $_]} @_[2 .. $#_]
my $sql = SQL::Abstract->new;
- my($stmt, @bind) = $sql->select($table, \@fields, \%where, \@order);
+ my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order);
my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
$sth->execute(@bind);
# Just generate the WHERE clause
- my($stmt, @bind) = $sql->where(\%where, \@order);
+ my($stmt, @bind) = $sql->where(\%where, $order);
# Return values in the same order, for hashed queries
# See PERFORMANCE section for more details
my %data = (
name => 'Bill',
- date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
+ date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ],
);
The first value in the array is the actual SQL. Any other values are
Easy, eh?
-=head1 FUNCTIONS
+=head1 METHODS
-The functions are simple. There's one for each major SQL operation,
+The methods are simple. There's one for every major SQL operation,
and a constructor you use first. The arguments are specified in a
-similar order to each function (table, then fields, then a where
+similar order for each method (table, then fields, then a where
clause) to try and simplify things.
-
-
-
=head2 new(option => 'value')
The C<new()> function takes a list of options and values, and returns
WHERE name like 'nwiger' AND email like 'nate@wiger.org'
-You can also override the comparsion on an individual basis - see
+You can also override the comparison on an individual basis - see
the huge section on L</"WHERE CLAUSES"> at the bottom.
=item sqltrue, sqlfalse
sub called C<bind_fields()> or something and reuse it repeatedly. You still
get a layer of abstraction over manual SQL specification.
-Note that if you set L</bindtype> to C<columns>, the C<\[$sql, @bind]>
+Note that if you set L</bindtype> to C<columns>, the C<\[ $sql, @bind ]>
construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
will expect the bind values in this format.
Quoting is useful if you have tables or columns names that are reserved
words in your database's SQL dialect.
+=item escape_char
+
+This is the character that will be used to escape L</quote_char>s appearing
+in an identifier before it has been quoted.
+
+The parameter default in case of a single L</quote_char> character is the quote
+character itself.
+
+When opening-closing-style quoting is used (L</quote_char> is an arrayref)
+this parameter defaults to the B<closing (right)> L</quote_char>. Occurences
+of the B<opening (left)> L</quote_char> within the identifier are currently left
+untouched. The default for opening-closing-style quotes may change in future
+versions, thus you are B<strongly encouraged> to specify the escape character
+explicitly.
+
=item name_sep
This is the character that separates a table and column name. It is
=back
-=head2 update($table, \%fieldvals, \%where)
+=head2 update($table, \%fieldvals, \%where, \%options)
This takes a table, hashref of field/value pairs, and an optional
hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
L</"Inserting and Updating SQL"> for information on how to insert
with those data types.
+The optional C<\%options> hash reference may contain additional
+options to generate the update SQL. Currently supported options
+are:
+
+=over 4
+
+=item returning
+
+See the C<returning> option to
+L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
+
+=back
+
=head2 select($source, $fields, $where, $order)
This returns a SQL SELECT statement and associated list of bind values, as
The argument can be either an arrayref (interpreted as a list
of field names, will be joined by commas and quoted), or a
plain scalar (literal SQL, not quoted).
-Please observe that this API is not as flexible as for
-the first argument C<$table>, for backwards compatibility reasons.
+Please observe that this API is not as flexible as that of
+the first argument C<$source>, for backwards compatibility reasons.
=item $where
This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
It returns an SQL DELETE statement and list of bind values.
-=head2 where(\%where, \@order)
+=head2 where(\%where, $order)
This is used to generate just the WHERE clause. For example,
if you have an arbitrary data structure and know what the
You get the idea. Strings get their case twiddled, but everything
else remains verbatim.
+=head1 EXPORTABLE FUNCTIONS
+
+=head2 is_plain_value
+
+Determines if the supplied argument is a plain value as understood by this
+module:
+
+=over
+
+=item * The value is C<undef>
+
+=item * The value is a non-reference
+
+=item * The value is an object with stringification overloading
+
+=item * The value is of the form C<< { -value => $anything } >>
+
+=back
+
+On failure returns C<undef>, on sucess returns a B<scalar> reference
+to the original supplied argument.
+
+=over
+
+=item * Note
+
+The stringification overloading detection is rather advanced: it takes
+into consideration not only the presence of a C<""> overload, but if that
+fails also checks for enabled
+L<autogenerated versions of C<"">|overload/Magic Autogeneration>, based
+on either C<0+> or C<bool>.
+
+Unfortunately testing in the field indicates that this
+detection B<< may tickle a latent bug in perl versions before 5.018 >>,
+but only when very large numbers of stringifying objects are involved.
+At the time of writing ( Sep 2014 ) there is no clear explanation of
+the direct cause, nor is there a manageably small test case that reliably
+reproduces the problem.
+
+If you encounter any of the following exceptions in B<random places within
+your application stack> - this module may be to blame:
+
+ Operation "ne": no method found,
+ left argument in overloaded package <something>,
+ right argument in overloaded package <something>
+
+or perhaps even
+
+ Stub found while resolving method "???" overloading """" in package <something>
+
+If you fall victim to the above - please attempt to reduce the problem
+to something that could be sent to the L<SQL::Abstract developers
+|DBIx::Class/GETTING HELP/SUPPORT>
+(either publicly or privately). As a workaround in the meantime you can
+set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true
+value, which will most likely eliminate your problem (at the expense of
+not being able to properly detect exotic forms of stringification).
+
+This notice and environment variable will be removed in a future version,
+as soon as the underlying problem is found and a reliable workaround is
+devised.
+
+=back
+
+=head2 is_literal_value
+
+Determines if the supplied argument is a literal value as understood by this
+module:
+
+=over
+
+=item * C<\$sql_string>
+
+=item * C<\[ $sql_string, @bind_values ]>
+
+=back
+
+On failure returns C<undef>, on sucess returns an B<array> reference
+containing the unpacked version of the supplied literal SQL and bind values.
+
=head1 WHERE CLAUSES
=head2 Introduction
@bind = ('2', '5', 'nwiger');
If you want to include literal SQL (with or without bind values), just use a
-scalar reference or array reference as the value:
+scalar reference or reference to an arrayref as the value:
my %where = (
date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
Which would generate:
- $stmt = "WHERE date_entered > "to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
+ $stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
@bind = ('11/26/2008');
Because, in Perl you I<can't> do this:
- priority => { '!=', 2, '!=', 1 }
+ priority => { '!=' => 2, '!=' => 1 }
As the second C<!=> key will obliterate the first. The solution
is to use the special C<-modifier> form inside an arrayref:
)";
@bind = ('2000');
-
+Finally, if the argument to C<-in> is not a reference, it will be
+treated as a single-element array.
Another pair of operators is C<-between> and C<-not_between>,
used with an arrayref of two values:
my %where = (
-and => [
-bool => 'one',
- -bool => 'two',
- -bool => 'three',
- -not_bool => 'four',
+ -not_bool => { two=> { -rlike => 'bar' } },
+ -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] },
],
);
Would give you:
- WHERE one AND two AND three AND NOT four
+ WHERE
+ one
+ AND
+ (NOT two RLIKE ?)
+ AND
+ (NOT ( three = ? OR three > ? ))
=head2 Nested conditions, -and/-or prefixes
That would yield:
- WHERE ( user = ? AND (
- ( workhrs > ? AND geo = ? )
- OR ( workhrs < ? OR geo = ? )
- ) )
+ $stmt = "WHERE ( user = ?
+ AND ( ( workhrs > ? AND geo = ? )
+ OR ( workhrs < ? OR geo = ? ) ) )";
+ @bind = ('nwiger', '20', 'ASIA', '50', 'EURO');
=head3 Algebraic inconsistency, for historical reasons
historical reasons. So be careful : the two examples below would
seem algebraically equivalent, but they are not
- {col => [-and => {-like => 'foo%'}, {-like => '%bar'}]}
+ { col => [ -and =>
+ { -like => 'foo%' },
+ { -like => '%bar' },
+ ] }
# yields : WHERE ( ( col LIKE ? AND col LIKE ? ) )
- [-and => {col => {-like => 'foo%'}, {col => {-like => '%bar'}}]]
+ [ -and =>
+ { col => { -like => 'foo%' } },
+ { col => { -like => '%bar' } },
+ ]
# yields : WHERE ( ( col LIKE ? OR col LIKE ? ) )
array => [1, 2, 3]
);
-the result would porbably be not what you wanted:
+the result would probably not be what you wanted:
$stmt = 'WHERE array = ? OR array = ? OR array = ?';
@bind = (1, 2, 3);
in Postgres you can use something like this:
my %where = (
- date_column => \[q/= date '2008-09-30' - ?::integer/, 10/]
+ date_column => \[ "= date '2008-09-30' - ?::integer", 10 ]
)
This would create:
@bind = ('10');
Note that you must pass the bind values in the same format as they are returned
-by L</where>. That means that if you set L</bindtype> to C<columns>, you must
-provide the bind values in the C<< [ column_meta => value ] >> format, where
-C<column_meta> is an opaque scalar value; most commonly the column name, but
-you can use any scalar value (including references and blessed references),
-L<SQL::Abstract> will simply pass it through intact. So if C<bindtype> is set
-to C<columns> the above example will look like:
+by L<where|/where(\%where, $order)>. This means that if you set L</bindtype>
+to C<columns>, you must provide the bind values in the
+C<< [ column_meta => value ] >> format, where C<column_meta> is an opaque
+scalar value; most commonly the column name, but you can use any scalar value
+(including references and blessed references), L<SQL::Abstract> will simply
+pass it through intact. So if C<bindtype> is set to C<columns> the above
+example will look like:
my %where = (
- date_column => \[q/= date '2008-09-30' - ?::integer/, [ dummy => 10 ]/]
+ date_column => \[ "= date '2008-09-30' - ?::integer", [ {} => 10 ] ]
)
Literal SQL is especially useful for nesting parenthesized clauses in the
=head1 ORDER BY CLAUSES
Some functions take an order by clause. This can either be a scalar (just a
-column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
-optionally with C<< -nulls => 'first' >> or C<< -nulls => 'last' >>,
-or an array of either of the two previous forms. Examples:
-
- Given | Will Generate
- ----------------------------------------------------------
- |
- \'colA DESC' | ORDER BY colA DESC
- |
- 'colA' | ORDER BY colA
- |
- [qw/colA colB/] | ORDER BY colA, colB
- |
- {-asc => 'colA'} | ORDER BY colA ASC
- |
- {-desc => 'colB'} | ORDER BY colB DESC
- |
- { |
- -asc => 'colA', | ORDER BY colA ASC NULLS LAST
- -nulls => 'last', |
- } |
- |
- ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
- |
- { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC
- |
- { |
- -asc => [qw/colA colB/] | ORDER BY colA ASC NULLS FIRST,
- -nulls => 'first' | colB ASC NULLS FIRST
- } |
- |
- [ |
- { -asc => 'colA' }, | ORDER BY colA ASC, colB DESC,
- { -desc => [qw/colB/], | colC ASC, colD ASC
- { -asc => [qw/colC colD/],|
- ] |
- ===========================================================
+column name), a hashref of C<< { -desc => 'col' } >> or C<< { -asc => 'col' }
+>>, a scalarref, an arrayref-ref, or an arrayref of any of the previous
+forms. Examples:
+
+ Given | Will Generate
+ ---------------------------------------------------------------
+ |
+ 'colA' | ORDER BY colA
+ |
+ [qw/colA colB/] | ORDER BY colA, colB
+ |
+ {-asc => 'colA'} | ORDER BY colA ASC
+ |
+ {-desc => 'colB'} | ORDER BY colB DESC
+ |
+ ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
+ |
+ { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC
+ |
+ \'colA DESC' | ORDER BY colA DESC
+ |
+ \[ 'FUNC(colA, ?)', $x ] | ORDER BY FUNC(colA, ?)
+ | /* ...with $x bound to ? */
+ |
+ [ |
+ { -asc => 'colA' }, | ORDER BY colA ASC, colB DESC,
+ { -desc => [qw/colB/] }, | colC ASC, colD ASC,
+ { -asc => [qw/colC colD/] },| colE DESC, FUNC(colF, ?)
+ \'colE DESC', | /* ...with $x bound to ? */
+ \[ 'FUNC(colF, ?)', $x ], |
+ ] |
+ ===============================================================
the expected return is C<< ($sql, @bind) >>.
When supplied with a method name, it is simply called on the
-L<SQL::Abstract/> object as:
+L<SQL::Abstract> object as:
$self->$method_name ($field, $op, $arg)
Where:
- $op is the part that matched the handler regex
$field is the LHS of the operator
+ $op is the part that matched the handler regex
$arg is the RHS
When supplied with a coderef, it is called as:
the expected return is C<< $sql >>.
When supplied with a method name, it is simply called on the
-L<SQL::Abstract/> object as:
+L<SQL::Abstract> object as:
$self->$method_name ($op, $arg)
#!/usr/bin/perl
+ use warnings;
+ use strict;
+
use CGI::FormBuilder;
use SQL::Abstract;
use these three modules together to write complex database query
apps in under 50 lines.
-=head1 REPO
+=head1 HOW TO CONTRIBUTE
+
+Contributions are always welcome, in all usable forms (we especially
+welcome documentation improvements). The delivery methods include git-
+or unified-diff formatted patches, GitHub pull requests, or plain bug
+reports either via RT or the Mailing list. Contributors are generally
+granted full access to the official repository after their first several
+patches pass successful review.
+
+This project is maintained in a git repository. The code and related tools are
+accessible at the following locations:
=over
-=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
+=item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
+
+=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
+
+=item * GitHub mirror: L<https://github.com/dbsrgits/sql-abstract>
-=item * git: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
+=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/SQL-Abstract.git>
=back
=item *
-support for literal SQL through the C<< \ [$sql, bind] >> syntax.
+support for literal SQL through the C<< \ [ $sql, @bind ] >> syntax.
=item *
projects / dbsrgits/SQL-Abstract.git / blobdiff