# GLOBALS
#======================================================================
-our $VERSION = '1.67';
+our $VERSION = '1.72';
# 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' },
);
#======================================================================
# special operators
$opt{special_ops} ||= [];
+ # regexes are applied in order, thus push after user-defines
push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
# unary operators
$opt{unary_ops} ||= [];
push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
+ # rudimentary saniy-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)
+
+ # FIXME
+ # need to guard against ()'s in column names too, but this will break tons of
+ # hacks... ideas anyone?
+ $opt{injection_guard} ||= qr/
+ \;
+ |
+ ^ \s* go \s
+ /xmi;
+
return bless \%opt, $class;
}
+sub _assert_pass_injection_guard {
+ if ($_[1] =~ $_[0]->{injection_guard}) {
+ my $class = ref $_[0];
+ puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
+ . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
+ . "{injection_guard} attribute to ${class}->new()"
+ }
+}
+
#======================================================================
# INSERT methods
my ($sql, @bind) = $self->$method($data);
$sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
- if (my $ret = $options->{returning}) {
- $sql .= $self->_insert_returning ($ret);
+ if ($options->{returning}) {
+ my ($s, @b) = $self->_insert_returning ($options);
+ $sql .= $s;
+ push @bind, @b;
}
return wantarray ? ($sql, @bind) : $sql;
}
sub _insert_returning {
- my ($self, $fields) = @_;
+ my ($self, $options) = @_;
+
+ my $f = $options->{returning};
- my $f = $self->_SWITCH_refkind($fields, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$fields;},
- SCALAR => sub {$self->_quote($fields)},
- SCALARREF => sub {$$fields},
+ my $fieldlist = $self->_SWITCH_refkind($f, {
+ ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
+ SCALAR => sub {$self->_quote($f)},
+ SCALARREF => sub {$$f},
});
- return join (' ', $self->_sqlcase(' returning'), $f);
+ return $self->_sqlcase(' returning ') . $fieldlist;
}
sub _insert_HASHREF { # explicit list of fields and then values
},
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);
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 (defined($self->{_nested_func_lhs}) && ($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");
+
+ $self->_assert_pass_injection_guard($op);
+
my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
SCALAR => sub {
puke "Illegal use of top-level '$op'"
},
SCALARREF => sub {
- puke "-$op => \\\$scalar not supported, use -nest => ...";
+ puke "-$op => \\\$scalar makes little sense, use " .
+ ($op =~ /^or/i
+ ? '[ \$scalar, \%rest_of_conditions ] instead'
+ : '-and => [ \$scalar, \%rest_of_conditions ] instead'
+ );
},
ARRAYREFREF => sub {
- puke "-$op => \\[..] not supported, use -nest => ...";
+ puke "-$op => \\[...] makes little sense, use " .
+ ($op =~ /^or/i
+ ? '[ \[...], \%rest_of_conditions ] instead'
+ : '-and => [ \[...], \%rest_of_conditions ] instead'
+ );
},
SCALAR => sub { # permissively interpreted as SQL
- puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
+ puke "-$op => \$value makes little sense, use -bool => \$value instead";
},
UNDEF => sub {
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
+
+ $self->_assert_pass_injection_guard($op);
+
+ # 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)),
foreach my $val (@$vals) {
my ($sql, @bind) = $self->_SWITCH_refkind($val, {
SCALAR => sub {
- return ($placeholder, ($val));
+ return ($placeholder, $self->_bindtype($k, $val) );
},
SCALARREF => sub {
- return ($self->_convert($$val), ());
+ return $$val;
},
ARRAYREFREF => sub {
my ($sql, @bind) = @$$val;
$self->_assert_bindval_matches_bindtype(@bind);
- return ($self->_convert($sql), @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;
return (
(join $and, @all_sql),
- $self->_bindtype($k, @all_bind),
+ @all_bind
);
},
FALLBACK => sub {
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);
+ },
+ UNDEF => sub {
+ return $self->_sqlcase('null');
+ },
+ });
+ 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};
ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$from;},
SCALAR => sub {$self->_quote($from)},
SCALARREF => sub {$$from},
- ARRAYREFREF => sub {join ', ', @$from;},
});
}
return '' unless defined $_[1];
return ${$_[1]} if ref($_[1]) eq 'SCALAR';
- return $_[1] unless $_[0]->{quote_char};
+ unless ($_[0]->{quote_char}) {
+ $_[0]->_assert_pass_injection_guard($_[1]);
+ return $_[1];
+ }
my $qref = ref $_[0]->{quote_char};
my ($l, $r);
SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
+=item injection_guard
+
+A regular expression C<qr/.../> that is applied to any C<-function> and unquoted
+column name specified in a query structure. This is a safety mechanism to avoid
+injection attacks when mishandling user input e.g.:
+
+ my %condition_as_column_value_pairs = get_values_from_user();
+ $sqla->select( ... , \%condition_as_column_value_pairs );
+
+If the expression matches an exception is thrown. Note that literal SQL
+supplied via C<\'...'> or C<\['...']> is B<not> checked in any way.
+
+Defaults to checking for C<;> and the C<GO> keyword (TransactSQL)
+
=item array_datatypes
When this option is true, arrayrefs in INSERT or UPDATE are
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,
my %where => (
user => 'nwiger',
- priority => [ {'=', 2}, {'!=', 1} ]
+ priority => [ { '=', 2 }, { '>', 5 } ]
);
Which would generate:
- $stmt = "WHERE user = ? AND priority = ? OR priority != ?";
- @bind = ('nwiger', '2', '1');
+ $stmt = "WHERE ( priority = ? OR priority > ? ) AND user = ?";
+ @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:
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',
@bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
-There is also a special C<-nest>
-operator which adds an additional set of parens, to create a subquery.
-For example, to get something like this:
-
- $stmt = "WHERE user = ? AND ( workhrs > ? OR geo = ? )";
- @bind = ('nwiger', '20', 'ASIA');
-
-You would do:
-
- my %where = (
- user => 'nwiger',
- -nest => [ workhrs => {'>', 20}, geo => 'ASIA' ],
- );
-
-
-Finally, clauses in hashrefs or arrayrefs can be
-prefixed with an C<-and> or C<-or> to change the logic
-inside :
+Clauses in hashrefs or arrayrefs can be prefixed with an C<-and> or C<-or>
+to change the logic inside :
my @where = (
-and => [
user => 'nwiger',
- -nest => [
- -and => [workhrs => {'>', 20}, geo => 'ASIA' ],
- -and => [workhrs => {'<', 50}, geo => 'EURO' ]
+ [
+ -and => [ workhrs => {'>', 20}, geo => 'ASIA' ],
+ -or => { workhrs => {'<', 50}, geo => 'EURO' },
],
],
);
That would yield:
- WHERE ( user = ? AND
- ( ( workhrs > ? AND geo = ? )
- OR ( workhrs < ? AND geo = ? ) ) )
-
+ WHERE ( user = ? AND (
+ ( workhrs > ? AND geo = ? )
+ OR ( workhrs < ? OR geo = ? )
+ ) )
=head2 Algebraic inconsistency, for historical reasons
$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)
my ($sub_stmt, @sub_bind)
= $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
- my %where = (
+ my %where = ( -and => [
foo => 1234,
- -nest => \["EXISTS ($sub_stmt)" => @sub_bind],
- );
+ \["EXISTS ($sub_stmt)" => @sub_bind],
+ ]);
which yields
C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
what we wanted here.
-Another use of the subquery technique is when some SQL clauses need
-parentheses, as it often occurs with some proprietary SQL extensions
-like for example fulltext expressions, geospatial expressions,
-NATIVE clauses, etc. Here is an example of a fulltext query in MySQL :
-
- my %where = (
- -nest => \["MATCH (col1, col2) AGAINST (?)" => qw/apples/]
- );
-
Finally, here is an example where a subquery is used
for expressing unary negation:
$sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
my %where = (
lname => {like => '%son%'},
- -nest => \["NOT ($sub_stmt)" => @sub_bind],
+ \["NOT ($sub_stmt)" => @sub_bind],
);
This yields
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/SQL-Abstract.git>
+
+=item * git: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
+
+=back
=head1 CHANGES
Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
Dan Kubb (support for "quote_char" and "name_sep")
Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
- Laurent Dami (internal refactoring, multiple -nest, extensible list of special operators, literal SQL)
+ Laurent Dami (internal refactoring, extensible list of special operators, literal SQL)
Norbert Buchmuller (support for literal SQL in hashpair, misc. fixes & tests)
Peter Rabbitson (rewrite of SQLA::Test, misc. fixes & tests)
Oliver Charles (support for "RETURNING" after "INSERT")
projects / dbsrgits/SQL-Abstract.git / blobdiff