X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=8a0bae98bb4d9fbd75e423429e928e9da5e1bb2d;hb=dq;hp=45d0425c46d69bd3ca0075b2a799626343607732;hpb=64b9e432608ec503eae190c0590188a59d86b38b;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 45d0425..8a0bae9 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -1,402 +1,220 @@ 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 SQL::Abstract::_TempExtlib; + +use Carp (); use List::Util (); use Scalar::Util (); +use Module::Runtime qw(use_module); +use Sub::Quote 'quote_sub'; +use Moo; +use namespace::clean; -#====================================================================== -# GLOBALS -#====================================================================== - -our $VERSION = '1.72'; +# DO NOT INCREMENT TO 2.0 WITHOUT COORDINATING WITH mst OR ribasushi + our $VERSION = '1.99_01'; +# DO NOT INCREMENT TO 2.0 WITHOUT COORDINATING WITH mst OR ribasushi # 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 => 1); -#====================================================================== -# 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} ||= []; - # 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()" - } -} - +has case => ( + is => 'ro', coerce => quote_sub( q{ $_[0] eq 'lower' ? 'lower' : undef } ), +); -#====================================================================== -# INSERT methods -#====================================================================== +has logic => ( + is => 'ro', coerce => quote_sub( q{ uc($_[0]) } ), default => 'OR', +); -sub insert { - my $self = shift; - my $table = $self->_table(shift); - my $data = shift || return; - my $options = shift; +has bindtype => ( + is => 'ro', default => 'normal' +); - my $method = $self->_METHOD_FOR_refkind("_insert", $data); - my ($sql, @bind) = $self->$method($data); - $sql = join " ", $self->_sqlcase('insert into'), $table, $sql; +has cmp => (is => 'ro', default => '='); - if ($options->{returning}) { - my ($s, @b) = $self->_insert_returning ($options); - $sql .= $s; - push @bind, @b; - } +has sqltrue => (is => 'ro', default => '1=1' ); +has sqlfalse => (is => 'ro', default => '0=1' ); - return wantarray ? ($sql, @bind) : $sql; -} +has special_ops => (is => 'ro', default => quote_sub( q{ [] } )); +has unary_ops => (is => 'ro', default => quote_sub( q{ [] } )); -sub _insert_returning { - my ($self, $options) = @_; +# FIXME +# need to guard against ()'s in column names too, but this will break tons of +# hacks... ideas anyone? - my $f = $options->{returning}; - - my $fieldlist = $self->_SWITCH_refkind($f, { - ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;}, - SCALAR => sub {$self->_quote($f)}, - SCALARREF => sub {$$f}, - }); - return $self->_sqlcase(' returning ') . $fieldlist; -} +has injection_guard => ( + is => 'ro', + default => quote_sub( q{ + qr/ + \; + | + ^ \s* go \s + /xmi; + }) +); -sub _insert_HASHREF { # explicit list of fields and then values - my ($self, $data) = @_; +has renderer => (is => 'lazy', clearer => 1); - my @fields = sort keys %$data; +has name_sep => ( + is => 'rw', default => '.', + trigger => quote_sub( q{ + $_[0]->clear_renderer; + $_[0]->clear_converter; + }), +); - my ($sql, @bind) = $self->_insert_values($data); +has quote_char => ( + is => 'rw', + trigger => quote_sub( q{ + $_[0]->clear_renderer; + $_[0]->clear_converter; + }), +); - # assemble SQL - $_ = $self->_quote($_) foreach @fields; - $sql = "( ".join(", ", @fields).") ".$sql; +has collapse_aliases => ( + is => 'ro', + default => 0, +); - return ($sql, @bind); -} +has always_quote => ( + is => 'rw', default => 1, + trigger => quote_sub( q{ + $_[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 => 1, + trigger => quote_sub( q{ $_[0]->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 => quote_sub( q{ $_[0]->clear_renderer } ), +); - my ($sql, @bind) = @${$data}; - $self->_assert_bindval_matches_bindtype(@bind); +after clear_renderer_class => sub { $_[0]->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? @@ -407,756 +225,20 @@ sub where { 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"); - - $self->_assert_pass_injection_guard($op); - - 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 makes little sense, use " . - ($op =~ /^or/i - ? '[ \$scalar, \%rest_of_conditions ] instead' - : '-and => [ \$scalar, \%rest_of_conditions ] instead' - ); - }, - - ARRAYREFREF => sub { - 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 => \$value makes little sense, use -bool => \$value instead"; - }, - - 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 - - $self->_assert_pass_injection_guard($op); - - # 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, $self->_bindtype($k, $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), - @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); - }, - UNDEF => sub { - return $self->_sqlcase('null'); - }, - }); - 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) = @_; @@ -1188,20 +270,18 @@ sub _quote { ); } +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] . ')'; } @@ -1211,11 +291,6 @@ sub _convert ($) { # 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 .. $#_] @@ -1237,23 +312,6 @@ sub _assert_bindval_matches_bindtype { } } -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 @@ -1261,78 +319,6 @@ sub _sqlcase { 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; @@ -1342,28 +328,11 @@ sub values { 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; @@ -1437,20 +406,9 @@ sub generate { } } - -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 @@ -1463,7 +421,7 @@ SQL::Abstract - Generate SQL from Perl data structures 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); @@ -1652,7 +610,7 @@ C to C you would get SQL such as: 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 at the bottom. =item sqltrue, sqlfalse @@ -1891,8 +849,8 @@ the source. 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 @@ -1965,9 +923,6 @@ Might give you: You get the idea. Strings get their case twiddled, but everything else remains verbatim. - - - =head1 WHERE CLAUSES =head2 Introduction @@ -2030,6 +985,13 @@ becomes: $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, @@ -2076,13 +1038,13 @@ To get an OR instead, you can combine it with the arrayref idea: 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: @@ -2180,7 +1142,8 @@ would generate: )"; @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: @@ -2245,15 +1208,19 @@ then you should use the and/or operators:- 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 @@ -2300,7 +1267,7 @@ That would yield: OR ( workhrs < ? OR geo = ? ) ) ) -=head2 Algebraic inconsistency, for historical reasons +=head3 Algebraic inconsistency, for historical reasons C: when connecting several conditions, the C<-and->|C<-or> operator goes C of the nested structure; whereas when connecting @@ -2330,64 +1297,88 @@ seem algebraically equivalent, but they are not # 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 examples above. Sometimes it is necessary to +alter this behavior. There are several ways of doing so. + +=head3 -ident -Finally, sometimes only literal SQL will do. If you want to include -literal SQL verbatim, you can specify it as a scalar reference, namely: +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, please use C<-ident> in new +code. -Of course, just to prove a point, the above can also be accomplished -with this: +=head3 -value + +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 : +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 -- @@ -2485,7 +1476,47 @@ 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 got formalized. For new code please use the superior syntax as +described in L. + +=item * + + my %where = ( requestor => \'= submitter' ) + + $stmt = "WHERE requestor = submitter" +This used to be the only way to compare columns. Use the superior L +method for all new code. For example an identifier declared in such a way +will be properly quoted if L 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 @@ -2502,9 +1533,6 @@ knew everything ahead of time, you wouldn't have to worry about 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 @@ -2715,6 +1743,9 @@ can be as simple as the following: #!/usr/bin/perl + use warnings; + use strict; + use CGI::FormBuilder; use SQL::Abstract; @@ -2740,9 +1771,9 @@ apps in under 50 lines. =over -=item * gitweb: L +=item * gitweb: L -=item * git: L +=item * git: L =back @@ -2806,8 +1837,6 @@ dropped the C<_modlogic> function =back - - =head1 ACKNOWLEDGEMENTS There are a number of individuals that have really helped out with