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 Carp;
-use strict;
-use warnings;
+use Carp ();
use List::Util ();
use Scalar::Util ();
+use Module::Runtime qw(use_module);
+use Moo;
+use namespace::clean;
-#======================================================================
-# GLOBALS
-#======================================================================
-
-our $VERSION = '1.70';
+our $VERSION = '1.77';
# This would confuse some packagers
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
-our $AUTOLOAD;
-
-# 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 \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' },
-);
-
-#======================================================================
-# DEBUGGING AND ERROR REPORTING
-#======================================================================
-
-sub _debug {
- return unless $_[0]->{debug}; shift; # a little faster
- my $func = (caller(1))[3];
- warn "[$func] ", @_, "\n";
-}
-
sub belch (@) {
my($func) = (caller(1))[3];
- carp "[$func] Warning: ", @_;
+ Carp::carp "[$func] Warning: ", @_;
}
sub puke (@) {
my($func) = (caller(1))[3];
- croak "[$func] Fatal: ", @_;
+ Carp::croak "[$func] Fatal: ", @_;
}
+has converter => (is => 'lazy', clearer => 'clear_converter');
-#======================================================================
-# NEW
-#======================================================================
-
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
- my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
-
- # choose our case by keeping an option around
- delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
-
- # default logic for interpreting arrayrefs
- $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;
-
- # SQL booleans
- $opt{sqltrue} ||= '1=1';
- $opt{sqlfalse} ||= '0=1';
-
- # special operators
- $opt{special_ops} ||= [];
- push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
-
- # unary operators
- $opt{unary_ops} ||= [];
- push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
+has case => (
+ is => 'ro', coerce => sub { $_[0] eq 'lower' ? 'lower' : undef }
+);
- return bless \%opt, $class;
-}
+has logic => (
+ is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
+);
+has bindtype => (
+ is => 'ro', default => sub { 'normal' }
+);
+has cmp => (is => 'ro', default => sub { '=' });
-#======================================================================
-# INSERT methods
-#======================================================================
+has sqltrue => (is => 'ro', default => sub { '1=1' });
+has sqlfalse => (is => 'ro', default => sub { '0=1' });
-sub insert {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $options = shift;
+has special_ops => (is => 'ro', default => sub { [] });
+has unary_ops => (is => 'ro', default => sub { [] });
- my $method = $self->_METHOD_FOR_refkind("_insert", $data);
- my ($sql, @bind) = $self->$method($data);
- $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
+# FIXME
+# need to guard against ()'s in column names too, but this will break tons of
+# hacks... ideas anyone?
- if (my $ret = $options->{returning}) {
- $sql .= $self->_insert_returning ($ret);
+has injection_guard => (
+ is => 'ro',
+ default => sub {
+ qr/
+ \;
+ |
+ ^ \s* go \s
+ /xmi;
}
+);
- return wantarray ? ($sql, @bind) : $sql;
-}
-
-sub _insert_returning {
- my ($self, $fields) = @_;
-
- my $f = $self->_SWITCH_refkind($fields, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$fields;},
- SCALAR => sub {$self->_quote($fields)},
- SCALARREF => sub {$$fields},
- });
- return join (' ', $self->_sqlcase(' returning'), $f);
-}
-
-sub _insert_HASHREF { # explicit list of fields and then values
- my ($self, $data) = @_;
+has renderer => (is => 'lazy', clearer => 'clear_renderer');
- my @fields = sort keys %$data;
+has name_sep => (
+ is => 'rw', default => sub { '.' },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
- my ($sql, @bind) = $self->_insert_values($data);
+has quote_char => (
+ is => 'rw',
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
- # assemble SQL
- $_ = $self->_quote($_) foreach @fields;
- $sql = "( ".join(", ", @fields).") ".$sql;
+has collapse_aliases => (
+ is => 'ro',
+ default => sub { 0 }
+);
- return ($sql, @bind);
-}
+has always_quote => (
+ is => 'rw', default => sub { 1 },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
-sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
- my ($self, $data) = @_;
+has convert => (is => 'ro');
- # no names (arrayref) so can't generate bindtype
- $self->{bindtype} ne 'columns'
- or belch "can't do 'columns' bindtype when called with arrayref";
+has array_datatypes => (is => 'ro');
- # 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 };
+has converter_class => (
+ is => 'rw', lazy => 1, builder => '_build_converter_class',
+ trigger => sub { shift->clear_converter },
+);
- return $self->_insert_values($data_in_hash);
+sub _build_converter_class {
+ use_module('SQL::Abstract::Converter')
}
-sub _insert_ARRAYREFREF { # literal SQL with bind
- my ($self, $data) = @_;
+has renderer_class => (
+ is => 'rw', lazy => 1, clearer => 1, builder => 1,
+ trigger => sub { shift->clear_renderer },
+);
- my ($sql, @bind) = @${$data};
- $self->_assert_bindval_matches_bindtype(@bind);
+after clear_renderer_class => sub { shift->clear_renderer };
- return ($sql, @bind);
+sub _build_renderer_class {
+ my ($self) = @_;
+ my ($class, @roles) = (
+ $self->_build_base_renderer_class, $self->_build_renderer_roles
+ );
+ return $class unless @roles;
+ return use_module('Moo::Role')->create_class_with_roles($class, @roles);
}
-
-sub _insert_SCALARREF { # literal SQL without bind
- my ($self, $data) = @_;
-
- return ($$data);
+sub _build_base_renderer_class {
+ use_module('Data::Query::Renderer::SQL::Naive')
}
-sub _insert_values {
- my ($self, $data) = @_;
-
- my (@values, @all_bind);
- foreach my $column (sort keys %$data) {
- my $v = $data->{$column};
+sub _build_renderer_roles { () }
- $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;
+sub _converter_args {
+ my ($self) = @_;
+ Scalar::Util::weaken($self);
+ +{
+ lower_case => $self->case,
+ default_logic => $self->logic,
+ bind_meta => not($self->bindtype eq 'normal'),
+ identifier_sep => $self->name_sep,
+ (map +($_ => $self->$_), qw(
+ cmp sqltrue sqlfalse injection_guard convert array_datatypes
+ )),
+ special_ops => [
+ map {
+ my $sub = $_->{handler};
+ +{
+ %$_,
+ handler => sub { $self->$sub(@_) }
}
- },
-
- 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);
- },
-
- });
-
+ } @{$self->special_ops}
+ ],
+ renderer_will_quote => (
+ defined($self->quote_char) and $self->always_quote
+ ),
}
-
- my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
- return ($sql, @all_bind);
}
+sub _build_converter {
+ my ($self) = @_;
+ $self->converter_class->new($self->_converter_args);
+}
-
-#======================================================================
-# UPDATE methods
-#======================================================================
-
-
-sub update {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
-
- # first build the 'SET' part of the sql statement
- my (@set, @all_bind);
- puke "Unsupported data type specified to \$sql->update"
- unless ref $data eq 'HASH';
-
- 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 $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);
- },
- });
- }
-
- # generate sql
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
- . join ', ', @set;
-
- if ($where) {
- my($where_sql, @where_bind) = $self->where($where);
- $sql .= $where_sql;
- push @all_bind, @where_bind;
+sub _renderer_args {
+ my ($self) = @_;
+ my ($chars);
+ for ($self->quote_char) {
+ $chars = defined() ? (ref() ? $_ : [$_]) : ['',''];
}
-
- return wantarray ? ($sql, @all_bind) : $sql;
+ +{
+ quote_chars => $chars, always_quote => $self->always_quote,
+ identifier_sep => $self->name_sep,
+ collapse_aliases => $self->collapse_aliases,
+ ($self->case ? (lc_keywords => 1) : ()), # always 'lower' if it exists
+ };
}
-
-
-
-#======================================================================
-# SELECT
-#======================================================================
-
-
-sub select {
- my $self = shift;
- my $table = $self->_table(shift);
- my $fields = shift || '*';
- my $where = shift;
- my $order = shift;
-
- my($where_sql, @bind) = $self->where($where, $order);
-
- my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields
- : $fields;
- my $sql = join(' ', $self->_sqlcase('select'), $f,
- $self->_sqlcase('from'), $table)
- . $where_sql;
-
- return wantarray ? ($sql, @bind) : $sql;
+sub _build_renderer {
+ my ($self) = @_;
+ $self->renderer_class->new($self->_renderer_args);
}
-#======================================================================
-# DELETE
-#======================================================================
-
-
-sub delete {
- my $self = shift;
- my $table = $self->_table(shift);
- my $where = shift;
-
-
- my($where_sql, @bind) = $self->where($where);
- my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql;
+sub _render_dq {
+ my ($self, $dq) = @_;
+ if (!$dq) {
+ return '';
+ }
+ my ($sql, @bind) = @{$self->renderer->render($dq)};
+ wantarray ?
+ ($self->{bindtype} eq 'normal'
+ ? ($sql, map $_->{value}, @bind)
+ : ($sql, map [ $_->{value_meta}, $_->{value} ], @bind)
+ )
+ : $sql;
+}
- return wantarray ? ($sql, @bind) : $sql;
+sub _render_sqla {
+ my ($self, $type, @args) = @_;
+ $self->_render_dq($self->converter->${\"_${type}_to_dq"}(@args));
}
+sub insert { shift->_render_sqla(insert => @_) }
-#======================================================================
-# WHERE: entry point
-#======================================================================
+sub update { shift->_render_sqla(update => @_) }
+sub select { shift->_render_sqla(select => @_) }
+sub delete { shift->_render_sqla(delete => @_) }
-# Finally, a separate routine just to handle WHERE clauses
sub where {
my ($self, $where, $order) = @_;
+ my $sql = '';
+ my @bind;
+
# where ?
- my ($sql, @bind) = $self->_recurse_where($where);
+ ($sql, @bind) = $self->_recurse_where($where) if defined($where);
$sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
# order by?
return wantarray ? ($sql, @bind) : $sql;
}
-
-sub _recurse_where {
- my ($self, $where, $logic) = @_;
-
- # dispatch on appropriate method according to refkind of $where
- my $method = $self->_METHOD_FOR_refkind("_where", $where);
-
- 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;
-}
-
-
-
-#======================================================================
-# WHERE: top-level ARRAYREF
-#======================================================================
-
-
-sub _where_ARRAYREF {
- my ($self, $where, $logic) = @_;
-
- $logic = uc($logic || $self->{logic});
- $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
-
- my @clauses = @$where;
-
- my (@sql_clauses, @all_bind);
- # need to use while() so can shift() for pairs
- while (my $el = shift @clauses) {
-
- # switch according to kind of $el and get corresponding ($sql, @bind)
- my ($sql, @bind) = $self->_SWITCH_refkind($el, {
-
- # skip empty elements, otherwise get invalid trailing AND stuff
- ARRAYREF => sub {$self->_recurse_where($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
- # 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)})},
-
- UNDEF => sub {puke "not supported : UNDEF in arrayref" },
- });
-
- if ($sql) {
- push @sql_clauses, $sql;
- push @all_bind, @bind;
- }
- }
-
- return $self->_join_sql_clauses($logic, \@sql_clauses, \@all_bind);
-}
-
-#======================================================================
-# WHERE: top-level ARRAYREFREF
-#======================================================================
-
-sub _where_ARRAYREFREF {
- my ($self, $where) = @_;
- my ($sql, @bind) = @$$where;
- $self->_assert_bindval_matches_bindtype(@bind);
- return ($sql, @bind);
-}
-
-#======================================================================
-# WHERE: top-level HASHREF
-#======================================================================
-
-sub _where_HASHREF {
- my ($self, $where) = @_;
- my (@sql_clauses, @all_bind);
-
- for my $k (sort keys %$where) {
- my $v = $where->{$k};
-
- # ($k => $v) is either a special unary op or a regular hashpair
- my ($sql, @bind) = do {
- if ($k =~ /^-./) {
- # put the operator in canonical form
- my $op = $k;
- $op = substr $op, 1; # remove 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;
-
- $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);
- $self->$method($k, $v);
- }
- };
-
- push @sql_clauses, $sql;
- push @all_bind, @bind;
- }
-
- return $self->_join_sql_clauses('and', \@sql_clauses, \@all_bind);
-}
-
-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'"
- unless $self->{_nested_func_lhs};
-
- return (
- $self->_convert('?'),
- $self->_bindtype($self->{_nested_func_lhs}, $rhs)
- );
- },
- FALLBACK => sub {
- $self->_recurse_where ($rhs)
- },
- });
-
- $sql = sprintf ('%s %s',
- $self->_sqlcase($op),
- $sql,
- );
-
- return ($sql, @bind);
-}
-
-sub _where_op_ANDOR {
- my ($self, $op, $v) = @_;
-
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- return $self->_where_ARRAYREF($v, $op);
- },
-
- HASHREF => sub {
- return ( $op =~ /^or/i )
- ? $self->_where_ARRAYREF( [ map { $_ => $v->{$_} } ( sort keys %$v ) ], $op )
- : $self->_where_HASHREF($v);
- },
-
- SCALARREF => sub {
- puke "-$op => \\\$scalar not supported, use -nest => ...";
- },
-
- ARRAYREFREF => sub {
- puke "-$op => \\[..] not supported, use -nest => ...";
- },
-
- SCALAR => sub { # permissively interpreted as SQL
- puke "-$op => 'scalar' not supported, use -nest => \\'scalar'";
- },
-
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
- });
-}
-
-sub _where_op_NEST {
- my ($self, $op, $v) = @_;
-
- $self->_SWITCH_refkind($v, {
-
- SCALAR => sub { # permissively interpreted as SQL
- belch "literal SQL should be -nest => \\'scalar' "
- . "instead of -nest => 'scalar' ";
- return ($v);
- },
-
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
-
- FALLBACK => sub {
- $self->_recurse_where ($v);
- },
-
- });
-}
-
-
-sub _where_op_BOOL {
- my ($self, $op, $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";
- },
-
- FALLBACK => sub {
- $self->_recurse_where ($v);
- },
- });
-
- $s = "(NOT $s)" if $op =~ /^not/i;
- ($s, @b);
-}
-
-
-sub _where_hashpair_ARRAYREF {
- my ($self, $k, $v) = @_;
-
- if( @$v ) {
- my @v = @$v; # need copy because of shift below
- $self->_debug("ARRAY($k) means distribute over elements");
-
- # put apart first element if it is an operator (-and, -or)
- my $op = (
- (defined $v[0] && $v[0] =~ /^ - (?: AND|OR ) $/ix)
- ? shift @v
- : ''
- );
- my @distributed = map { {$k => $_} } @v;
-
- if ($op) {
- $self->_debug("OP($op) reinjected into the distributed array");
- unshift @distributed, $op;
- }
-
- my $logic = $op ? substr($op, 1) : '';
-
- 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});
- }
-}
-
-sub _where_hashpair_HASHREF {
- my ($self, $k, $v, $logic) = @_;
- $logic ||= 'and';
-
- local $self->{_nested_func_lhs} = $self->{_nested_func_lhs};
-
- my ($all_sql, @all_bind);
-
- for my $orig_op (sort keys %$v) {
- my $val = $v->{$orig_op};
-
- # put the operator in canonical form
- my $op = $orig_op;
-
- # 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);
-
- # CASE: col-value logic modifiers
- if ( $orig_op =~ /^ \- (and|or) $/xi ) {
- ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $1);
- }
- # CASE: special operators like -in or -between
- elsif ( my $special_op = List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}} ) {
- my $handler = $special_op->{handler};
- if (! $handler) {
- puke "No handler supplied for special operator $orig_op";
- }
- elsif (not ref $handler) {
- ($sql, @bind) = $self->$handler ($k, $op, $val);
- }
- elsif (ref $handler eq 'CODE') {
- ($sql, @bind) = $handler->($self, $k, $op, $val);
- }
- else {
- puke "Illegal handler for special operator $orig_op - expecting a method name or a coderef";
- }
- }
- else {
- $self->_SWITCH_refkind($val, {
-
- ARRAYREF => sub { # CASE: col => {op => \@vals}
- ($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
- },
-
- ARRAYREFREF => sub { # CASE: col => {op => \[$sql, @bind]} (literal SQL with bind)
- my ($sub_sql, @sub_bind) = @$$val;
- $self->_assert_bindval_matches_bindtype(@sub_bind);
- $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($op),
- $sub_sql;
- @bind = @sub_bind;
- },
-
- 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";
- $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 (' ',
- $self->_convert($self->_quote($k)),
- $self->{_nested_func_lhs} eq $k ? $sql : "($sql)", # top level vs nested
- );
- },
- });
- }
-
- ($all_sql) = (defined $all_sql and $all_sql) ? $self->_join_sql_clauses($logic, [$all_sql, $sql], []) : $sql;
- push @all_bind, @bind;
- }
- return ($all_sql, @all_bind);
-}
-
-
-
-sub _where_field_op_ARRAYREF {
- my ($self, $k, $op, $vals) = @_;
-
- my @vals = @$vals; #always work on a copy
-
- if(@vals) {
- $self->_debug(sprintf '%s means multiple elements: [ %s ]',
- $vals,
- join (', ', map { defined $_ ? "'$_'" : 'NULL' } @vals ),
- );
-
- # see if the first element is an -and/-or op
- my $logic;
- if (defined $vals[0] && $vals[0] =~ /^ - ( AND|OR ) $/ix) {
- $logic = uc $1;
- shift @vals;
- }
-
- # 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')";
- }
-}
-
-
-sub _where_hashpair_SCALARREF {
- my ($self, $k, $v) = @_;
- $self->_debug("SCALAR($k) means literal SQL: $$v");
- my $sql = $self->_quote($k) . " " . $$v;
- return ($sql);
-}
-
-# literal SQL with bind
-sub _where_hashpair_ARRAYREFREF {
- my ($self, $k, $v) = @_;
- $self->_debug("REF($k) means literal SQL: @${$v}");
- my ($sql, @bind) = @$$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- $sql = $self->_quote($k) . " " . $sql;
- return ($sql, @bind );
-}
-
-# literal SQL without bind
-sub _where_hashpair_SCALAR {
- my ($self, $k, $v) = @_;
- $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
- my $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($self->{cmp}),
- $self->_convert('?');
- my @bind = $self->_bindtype($k, $v);
- return ( $sql, @bind);
-}
-
-
-sub _where_hashpair_UNDEF {
- my ($self, $k, $v) = @_;
- $self->_debug("UNDEF($k) means IS NULL");
- my $sql = $self->_quote($k) . $self->_sqlcase(' is null');
- return ($sql);
-}
-
-#======================================================================
-# WHERE: TOP-LEVEL OTHERS (SCALARREF, SCALAR, UNDEF)
-#======================================================================
-
-
-sub _where_SCALARREF {
- my ($self, $where) = @_;
-
- # literal sql
- $self->_debug("SCALAR(*top) means literal SQL: $$where");
- return ($$where);
-}
-
-
-sub _where_SCALAR {
- my ($self, $where) = @_;
-
- # literal sql
- $self->_debug("NOREF(*top) means literal SQL: $where");
- return ($where);
-}
-
-
-sub _where_UNDEF {
- my ($self) = @_;
- return ();
-}
-
-
-#======================================================================
-# WHERE: BUILTIN SPECIAL OPERATORS (-in, -between)
-#======================================================================
-
-
-sub _where_field_BETWEEN {
- my ($self, $k, $op, $vals) = @_;
-
- my ($label, $and, $placeholder);
- $label = $self->_convert($self->_quote($k));
- $and = ' ' . $self->_sqlcase('and') . ' ';
- $placeholder = $self->_convert('?');
- $op = $self->_sqlcase($op);
-
- my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
- ARRAYREFREF => sub {
- my ($s, @b) = @$$vals;
- $self->_assert_bindval_matches_bindtype(@b);
- ($s, @b);
- },
- SCALARREF => sub {
- return $$vals;
- },
- ARRAYREF => sub {
- puke "special op 'between' accepts an arrayref with exactly two values"
- if @$vals != 2;
-
- my (@all_sql, @all_bind);
- foreach 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 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),
- );
- },
- FALLBACK => sub {
- puke "special op 'between' accepts an arrayref with two values, or a single literal scalarref/arrayref-ref";
- },
- });
-
- my $sql = "( $label $op $clause )";
- return ($sql, @bind)
-}
-
-
-sub _where_field_IN {
- my ($self, $k, $op, $vals) = @_;
-
- # backwards compatibility : if scalar, force into an arrayref
- $vals = [$vals] if defined $vals && ! ref $vals;
-
- my ($label) = $self->_convert($self->_quote($k));
- my ($placeholder) = $self->_convert('?');
- $op = $self->_sqlcase($op);
-
- my ($sql, @bind) = $self->_SWITCH_refkind($vals, {
- ARRAYREF => sub { # list of choices
- if (@$vals) { # nonempty list
- 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 (
- 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};
- return ($sql);
- }
- },
-
- SCALARREF => sub { # literal SQL
- my $sql = $self->_open_outer_paren ($$vals);
- return ("$label $op ( $sql )");
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @$$vals;
- $self->_assert_bindval_matches_bindtype(@bind);
- $sql = $self->_open_outer_paren ($sql);
- return ("$label $op ( $sql )", @bind);
- },
-
- FALLBACK => sub {
- puke "special op 'in' requires an arrayref (or scalarref/arrayref-ref)";
- },
- });
-
- return ($sql, @bind);
-}
-
-# Some databases (SQLite) treat col IN (1, 2) different from
-# col IN ( (1, 2) ). Use this to strip all outer parens while
-# adding them back in the corresponding method
-sub _open_outer_paren {
- my ($self, $sql) = @_;
- $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
- return $sql;
-}
-
-
-#======================================================================
-# ORDER BY
-#======================================================================
+sub _recurse_where { shift->_render_sqla(where => @_) }
sub _order_by {
my ($self, $arg) = @_;
-
- my (@sql, @bind);
- for my $c ($self->_order_by_chunks ($arg) ) {
- $self->_SWITCH_refkind ($c, {
- SCALAR => sub { push @sql, $c },
- ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
- });
+ if (my $dq = $self->converter->_order_by_to_dq($arg)) {
+ # SQLA generates ' ORDER BY foo'. The hilarity.
+ wantarray
+ ? do { my @r = $self->_render_dq($dq); $r[0] = ' '.$r[0]; @r }
+ : ' '.$self->_render_dq($dq);
+ } else {
+ '';
}
-
- my $sql = @sql
- ? sprintf ('%s %s',
- $self->_sqlcase(' order by'),
- join (', ', @sql)
- )
- : ''
- ;
-
- return wantarray ? ($sql, @bind) : $sql;
-}
-
-sub _order_by_chunks {
- my ($self, $arg) = @_;
-
- return $self->_SWITCH_refkind($arg, {
-
- ARRAYREF => sub {
- map { $self->_order_by_chunks ($_ ) } @$arg;
- },
-
- ARRAYREFREF => sub {
- my ($s, @b) = @$$arg;
- $self->_assert_bindval_matches_bindtype(@b);
- [ $s, @b ];
- },
-
- SCALAR => sub {$self->_quote($arg)},
-
- UNDEF => sub {return () },
-
- SCALARREF => sub {$$arg}, # literal SQL, no quoting
-
- HASHREF => sub {
- # 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)";
- }
-
- my $direction = $1;
-
- my @ret;
- for my $c ($self->_order_by_chunks ($val)) {
- my ($sql, @bind);
-
- $self->_SWITCH_refkind ($c, {
- SCALAR => sub {
- $sql = $c;
- },
- ARRAYREF => sub {
- ($sql, @bind) = @$c;
- },
- });
-
- $sql = $sql . ' ' . $self->_sqlcase($direction);
-
- push @ret, [ $sql, @bind];
- }
-
- return @ret;
- },
- });
}
-
-#======================================================================
-# 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},
- ARRAYREFREF => sub {join ', ', @$from;},
- });
-}
-
-
-#======================================================================
-# UTILITY FUNCTIONS
-#======================================================================
-
# 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';
- 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);
);
}
+sub _assert_pass_injection_guard {
+ if ($_[1] =~ $_[0]->{injection_guard}) {
+ my $class = ref $_[0];
+ die "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()"
+ }
+}
# Conversion, if applicable
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 (@) {
#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 .. $#_]
}
}
-sub _join_sql_clauses {
- my ($self, $logic, $clauses_aref, $bind_aref) = @_;
-
- if (@$clauses_aref > 1) {
- my $join = " " . $self->_sqlcase($logic) . " ";
- my $sql = '( ' . join($join, @$clauses_aref) . ' )';
- return ($sql, @$bind_aref);
- }
- elsif (@$clauses_aref) {
- return ($clauses_aref->[0], @$bind_aref); # no parentheses
- }
- else {
- return (); # if no SQL, ignore @$bind_aref
- }
-}
-
-
# Fix SQL case, if so requested
sub _sqlcase {
# LDNOTE: if $self->{case} is true, then it contains 'lower', so we
return $_[0]->{case} ? $_[1] : uc($_[1]);
}
-
-#======================================================================
-# DISPATCHING FROM REFKIND
-#======================================================================
-
-sub _refkind {
- my ($self, $data) = @_;
-
- return 'UNDEF' unless defined $data;
-
- # blessed objects are treated like scalars
- my $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
-
- 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;
-}
-
-sub _METHOD_FOR_refkind {
- my ($self, $meth_prefix, $data) = @_;
-
- my $method;
- for (@{$self->_try_refkind($data)}) {
- $method = $self->can($meth_prefix."_".$_)
- and last;
- }
-
- return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
-}
-
-
-sub _SWITCH_refkind {
- my ($self, $data, $dispatch_table) = @_;
-
- my $coderef;
- for (@{$self->_try_refkind($data)}) {
- $coderef = $dispatch_table->{$_}
- and last;
- }
-
- puke "no dispatch entry for ".$self->_refkind($data)
- unless $coderef;
-
- $coderef->();
-}
-
-
-
-
-#======================================================================
-# VALUES, GENERATE, AUTOLOAD
-#======================================================================
-
-# LDNOTE: original code from nwiger, didn't touch code in that section
-# I feel the AUTOLOAD stuff should not be the default, it should
-# only be activated on explicit demand by user.
-
sub values {
my $self = shift;
my $data = shift || return;
my @all_bind;
foreach my $k ( sort keys %$data ) {
my $v = $data->{$k};
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # array datatype
- push @all_bind, $self->_bindtype($k, $v);
- }
- else { # literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @all_bind, @bind;
- }
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @all_bind, @bind;
- },
- SCALARREF => sub { # literal SQL without bind
- },
- SCALAR_or_UNDEF => sub {
- push @all_bind, $self->_bindtype($k, $v);
- },
- });
+ local our $Cur_Col_Meta = $k;
+ my ($sql, @bind) = $self->_render_sqla(
+ mutation_rhs => $v
+ );
+ push @all_bind, @bind;
}
return @all_bind;
}
}
-
-sub DESTROY { 1 }
-
-sub AUTOLOAD {
- # This allows us to check for a local, then _form, attr
- my $self = shift;
- my($name) = $AUTOLOAD =~ /.*::(.+)/;
- return $self->generate($name, @_);
-}
-
1;
-
__END__
=head1 NAME
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);
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
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
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
You get the idea. Strings get their case twiddled, but everything
else remains verbatim.
-
-
-
=head1 WHERE CLAUSES
=head2 Introduction
$stmt = "WHERE user = ? AND status IS NULL";
@bind = ('nwiger');
+To test if a column IS NOT NULL:
+
+ my %where = (
+ user => 'nwiger',
+ status => { '!=', undef },
+ );
+
=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:
)";
@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
@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
+=head3 Algebraic inconsistency, for historical reasons
C<Important note>: when connecting several conditions, the C<-and->|C<-or>
operator goes C<outside> of the nested structure; whereas when connecting
# yields : WHERE ( ( col LIKE ? OR col LIKE ? ) )
-=head2 Literal SQL
+=head2 Literal SQL and value type operators
+
+The basic premise of SQL::Abstract is that in WHERE specifications the "left
+side" is a column name and the "right side" is a value (normally rendered as
+a placeholder). This holds true for both hashrefs and arrayref pairs as you
+see in the L</WHERE CLAUSES> examples above. Sometimes it is necessary to
+alter this behavior. There are several ways of doing so.
-Finally, sometimes only literal SQL will do. If you want to include
-literal SQL verbatim, you can specify it as a scalar reference, namely:
+=head3 -ident
+
+This is a virtual operator that signals the string to its right side is an
+identifier (a column name) and not a value. For example to compare two
+columns you would write:
- my $inn = 'is Not Null';
my %where = (
priority => { '<', 2 },
- requestor => \$inn
+ requestor => { -ident => 'submitter' },
);
-This would create:
+which creates:
- $stmt = "WHERE priority < ? AND requestor is Not Null";
+ $stmt = "WHERE priority < ? AND requestor = submitter";
@bind = ('2');
-Note that in this example, you only get one bind parameter back, since
-the verbatim SQL is passed as part of the statement.
+If you are maintaining legacy code you may see a different construct as
+described in L</Deprecated usage of Literal SQL>, please use C<-ident> in new
+code.
+
+=head3 -value
-Of course, just to prove a point, the above can also be accomplished
-with this:
+This is a virtual operator that signals that the construct to its right side
+is a value to be passed to DBI. This is for example necessary when you want
+to write a where clause against an array (for RDBMS that support such
+datatypes). For example:
my %where = (
- priority => { '<', 2 },
- requestor => { '!=', undef },
+ array => { -value => [1, 2, 3] }
);
+will result in:
-TMTOWTDI
+ $stmt = 'WHERE array = ?';
+ @bind = ([1, 2, 3]);
-Conditions on boolean columns can be expressed in the same way, passing
-a reference to an empty string, however using liternal SQL in this way
-is deprecated - the preferred method is to use the boolean operators -
-see L</"Unary operators: bool"> :
+Note that if you were to simply say:
my %where = (
- priority => { '<', 2 },
- is_ready => \"";
+ array => [1, 2, 3]
);
-which yields
+the result would probably not be what you wanted:
- $stmt = "WHERE priority < ? AND is_ready";
- @bind = ('2');
+ $stmt = 'WHERE array = ? OR array = ? OR array = ?';
+ @bind = (1, 2, 3);
+
+=head3 Literal SQL
-Literal SQL is also the only way to compare 2 columns to one another:
+Finally, sometimes only literal SQL will do. To include a random snippet
+of SQL verbatim, you specify it as a scalar reference. Consider this only
+as a last resort. Usually there is a better way. For example:
my %where = (
priority => { '<', 2 },
- requestor => \'= submittor'
+ requestor => { -in => \'(SELECT name FROM hitmen)' },
);
-which creates:
+Would create:
- $stmt = "WHERE priority < ? AND requestor = submitter";
- @bind = ('2');
+ $stmt = "WHERE priority < ? AND requestor IN (SELECT name FROM hitmen)"
+ @bind = (2);
+
+Note that in this example, you only get one bind parameter back, since
+the verbatim SQL is passed as part of the statement.
+
+=head4 CAVEAT
-=head2 Literal SQL with placeholders and bind values (subqueries)
+ Never use untrusted input as a literal SQL argument - this is a massive
+ security risk (there is no way to check literal snippets for SQL
+ injections and other nastyness). If you need to deal with untrusted input
+ use literal SQL with placeholders as described next.
+
+=head3 Literal SQL with placeholders and bind values (subqueries)
If the literal SQL to be inserted has placeholders and bind values,
use a reference to an arrayref (yes this is a double reference --
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
$stmt = "lname LIKE ? AND NOT ( age < ? OR age > ? )"
@bind = ('%son%', 10, 20)
+=head3 Deprecated usage of Literal SQL
+
+Below are some examples of archaic use of literal SQL. It is shown only as
+reference for those who deal with legacy code. Each example has a much
+better, cleaner and safer alternative that users should opt for in new code.
+
+=over
+
+=item *
+
+ my %where = ( requestor => \'IS NOT NULL' )
+
+ $stmt = "WHERE requestor IS NOT NULL"
+
+This used to be the way of generating NULL comparisons, before the handling
+of C<undef> got formalized. For new code please use the superior syntax as
+described in L</Tests for NULL values>.
+
+=item *
+
+ my %where = ( requestor => \'= submitter' )
+
+ $stmt = "WHERE requestor = submitter"
+This used to be the only way to compare columns. Use the superior L</-ident>
+method for all new code. For example an identifier declared in such a way
+will be properly quoted if L</quote_char> is properly set, while the legacy
+form will remain as supplied.
+
+=item *
+
+ my %where = ( is_ready => \"", completed => { '>', '2012-12-21' } )
+
+ $stmt = "WHERE completed > ? AND is_ready"
+ @bind = ('2012-12-21')
+
+Using an empty string literal used to be the only way to express a boolean.
+For all new code please use the much more readable
+L<-bool|/Unary operators: bool> operator.
+
+=back
=head2 Conclusion
dynamically-generating SQL and could just hardwire it into your
script.
-
-
-
=head1 ORDER BY CLAUSES
Some functions take an order by clause. This can either be a scalar (just a
#!/usr/bin/perl
+ use warnings;
+ use strict;
+
use CGI::FormBuilder;
use SQL::Abstract;
=over
-=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git>
+=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/DBIx-Class.git>
+=item * git: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
=back
=back
-
-
=head1 ACKNOWLEDGEMENTS
There are a number of individuals that have really helped out with
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