+package SQL::Abstract; # see doc at end of file
-package SQL::Abstract;
+use strict;
+use warnings;
+use Carp ();
+use List::Util ();
+use Scalar::Util ();
+
+#======================================================================
+# GLOBALS
+#======================================================================
+
+our $VERSION = '1.75';
+
+# 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'},
+ {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'},
+ {regex => qr/^ value $/ix, handler => '_where_op_VALUE'},
+ {regex => qr/^ is (?: \s+ not )? $/ix, handler => '_where_field_IS'},
+);
+
+# unaryish operators - key maps to handler
+my @BUILTIN_UNARY_OPS = (
+ # the digits are backcompat stuff
+ { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+ { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
+ { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
+ { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
+ { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
+ { regex => qr/^ value $/xi, handler => '_where_op_VALUE' },
+);
+
+#======================================================================
+# 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::carp "[$func] Warning: ", @_;
+}
+
+sub puke (@) {
+ my($func) = (caller(1))[3];
+ Carp::croak "[$func] Fatal: ", @_;
+}
+
+
+#======================================================================
+# 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
+ $opt{bindtype} ||= 'normal';
+
+ # default comparison is "=", but can be overridden
+ $opt{cmp} ||= '=';
+
+ # try to recognize which are the 'equality' and 'inequality' ops
+ # (temporary quickfix (in 2007), should go through a more seasoned API)
+ $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix;
+ $opt{inequality_op} = qr/^( != | <> )$/ix;
+
+ $opt{like_op} = qr/^ (is\s+)? r?like $/xi;
+ $opt{not_like_op} = qr/^ (is\s+)? not \s+ r?like $/xi;
+
+ # SQL booleans
+ $opt{sqltrue} ||= '1=1';
+ $opt{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 sanity-check for user supplied bits treated as functions/operators
+ # If a purported function matches this regular expression, an exception is thrown.
+ # Literal SQL is *NOT* subject to this check, only functions (and column names
+ # when quoting is not in effect)
+
+ # FIXME
+ # need to guard against ()'s in column names too, but this will break tons of
+ # hacks... ideas anyone?
+ $opt{injection_guard} ||= qr/
+ \;
+ |
+ ^ \s* go \s
+ /xmi;
+
+ return bless \%opt, $class;
+}
+
+
+sub _assert_pass_injection_guard {
+ if ($_[1] =~ $_[0]->{injection_guard}) {
+ my $class = ref $_[0];
+ puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
+ . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
+ . "{injection_guard} attribute to ${class}->new()"
+ }
+}
+
+
+#======================================================================
+# INSERT methods
+#======================================================================
+
+sub insert {
+ my $self = shift;
+ my $table = $self->_table(shift);
+ my $data = shift || return;
+ my $options = shift;
+
+ my $method = $self->_METHOD_FOR_refkind("_insert", $data);
+ my ($sql, @bind) = $self->$method($data);
+ $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
+
+ if ($options->{returning}) {
+ my ($s, @b) = $self->_insert_returning ($options);
+ $sql .= $s;
+ push @bind, @b;
+ }
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+sub _insert_returning {
+ my ($self, $options) = @_;
+
+ 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;
+}
+
+sub _insert_HASHREF { # explicit list of fields and then values
+ my ($self, $data) = @_;
+
+ my @fields = sort keys %$data;
+
+ my ($sql, @bind) = $self->_insert_values($data);
+
+ # assemble SQL
+ $_ = $self->_quote($_) foreach @fields;
+ $sql = "( ".join(", ", @fields).") ".$sql;
+
+ return ($sql, @bind);
+}
+
+sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
+ my ($self, $data) = @_;
+
+ # no names (arrayref) so can't generate bindtype
+ $self->{bindtype} ne 'columns'
+ or belch "can't do 'columns' bindtype when called with arrayref";
+
+ # fold the list of values into a hash of column name - value pairs
+ # (where the column names are artificially generated, and their
+ # lexicographical ordering keep the ordering of the original list)
+ my $i = "a"; # incremented values will be in lexicographical order
+ my $data_in_hash = { map { ($i++ => $_) } @$data };
+
+ return $self->_insert_values($data_in_hash);
+}
+
+sub _insert_ARRAYREFREF { # literal SQL with bind
+ my ($self, $data) = @_;
+
+ my ($sql, @bind) = @${$data};
+ $self->_assert_bindval_matches_bindtype(@bind);
+
+ return ($sql, @bind);
+}
+
+
+sub _insert_SCALARREF { # literal SQL without bind
+ my ($self, $data) = @_;
+
+ return ($$data);
+}
+
+sub _insert_values {
+ my ($self, $data) = @_;
+
+ my (@values, @all_bind);
+ foreach my $column (sort keys %$data) {
+ my $v = $data->{$column};
+
+ $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;
+ }
+ },
+
+ 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);
+ },
+
+ });
+
+ }
+
+ my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
+ return ($sql, @all_bind);
+}
+
+
+
+#======================================================================
+# 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;
+ }
+
+ return wantarray ? ($sql, @all_bind) : $sql;
+}
+
+
+
+
+#======================================================================
+# 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;
+}
+
+#======================================================================
+# 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;
+
+ return wantarray ? ($sql, @bind) : $sql;
+}
+
+
+#======================================================================
+# WHERE: entry point
+#======================================================================
+
+
+
+# Finally, a separate routine just to handle WHERE clauses
+sub where {
+ my ($self, $where, $order) = @_;
+
+ # where ?
+ my ($sql, @bind) = $self->_recurse_where($where);
+ $sql = $sql ? $self->_sqlcase(' where ') . "( $sql )" : '';
+
+ # order by?
+ if ($order) {
+ $sql .= $self->_order_by($order);
+ }
+
+ 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},
+
+ 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_op_IDENT {
+ my $self = shift;
+ my ($op, $rhs) = splice @_, -2;
+ if (ref $rhs) {
+ puke "-$op takes a single scalar argument (a quotable identifier)";
+ }
+
+ # in case we are called as a top level special op (no '=')
+ my $lhs = shift;
+
+ $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
+
+ return $lhs
+ ? "$lhs = $rhs"
+ : $rhs
+ ;
+}
+
+sub _where_op_VALUE {
+ my $self = shift;
+ my ($op, $rhs) = splice @_, -2;
+
+ # in case we are called as a top level special op (no '=')
+ my $lhs = shift;
+
+ my @bind =
+ $self->_bindtype (
+ ($lhs || $self->{_nested_func_lhs}),
+ $rhs,
+ )
+ ;
+
+ return $lhs
+ ? (
+ $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
+ @bind
+ )
+ : (
+ $self->_convert('?'),
+ @bind,
+ )
+ ;
+}
+
+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 {
+ $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);
+
+ # fixup is_not
+ $op =~ s/^is_not/IS NOT/i;
+
+ # 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 =~ /^not$/i ? 'is not' # legacy
+ : $op =~ $self->{equality_op} ? 'is'
+ : $op =~ $self->{like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is'
+ : $op =~ $self->{inequality_op} ? 'is not'
+ : $op =~ $self->{not_like_op} ? belch("Supplying an undefined argument to '@{[ uc $op]}' is deprecated") && 'is not'
+ : puke "unexpected operator '$orig_op' with undef operand";
+
+ $sql = $self->_quote($k) . $self->_sqlcase(" $is null");
+ },
+
+ FALLBACK => sub { # CASE: col => {op/func => $stuff}
+
+ # retain for proper column type bind
+ $self->{_nested_func_lhs} ||= $k;
+
+ ($sql, @bind) = $self->_where_unary_op ($op, $val);
+
+ $sql = join (' ',
+ $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_IS {
+ my ($self, $k, $op, $v) = @_;
+
+ my ($s) = $self->_SWITCH_refkind($v, {
+ UNDEF => sub {
+ join ' ',
+ $self->_convert($self->_quote($k)),
+ map { $self->_sqlcase($_)} ($op, 'null')
+ },
+ FALLBACK => sub {
+ puke "$op can only take undef as argument";
+ },
+ });
+
+ $s;
+}
+
+sub _where_field_op_ARRAYREF {
+ my ($self, $k, $op, $vals) = @_;
+
+ 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;
+ }
+
+ # a long standing API wart - an attempt to change this behavior during
+ # the 1.50 series failed *spectacularly*. Warn instead and leave the
+ # behavior as is
+ if (
+ @vals > 1
+ and
+ (!$logic or $logic eq 'OR')
+ and
+ ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} )
+ ) {
+ my $o = uc($op);
+ belch "A multi-element arrayref as an argument to the inequality op '$o' "
+ . 'is technically equivalent to an always-true 1=1 (you probably wanted '
+ . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
+ ;
+ }
+
+ # distribute $op over each remaining member of @vals, append logic if exists
+ return $self->_recurse_where([map { {$k => {$op, $_}} } @vals], $logic);
+
+ }
+ else {
+ # try to DWIM on equality operators
+ return
+ $op =~ $self->{equality_op} ? $self->{sqlfalse}
+ : $op =~ $self->{like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqlfalse}
+ : $op =~ $self->{inequality_op} ? $self->{sqltrue}
+ : $op =~ $self->{not_like_op} ? belch("Supplying an empty arrayref to '@{[ uc $op]}' is deprecated") && $self->{sqltrue}
+ : puke "operator '$op' applied on an empty array (field '$k')";
+ }
+}
+
+
+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 $invalid_args = "Operator '$op' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
+
+ my ($clause, @bind) = $self->_SWITCH_refkind($vals, {
+ ARRAYREFREF => sub {
+ my ($s, @b) = @$$vals;
+ $self->_assert_bindval_matches_bindtype(@b);
+ ($s, @b);
+ },
+ SCALARREF => sub {
+ return $$vals;
+ },
+ ARRAYREF => sub {
+ puke $invalid_args 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);
+ },
+ FALLBACK => sub {
+ puke $invalid_args,
+ },
+ });
+ push @all_sql, $sql;
+ push @all_bind, @bind;
+ }
+
+ return (
+ (join $and, @all_sql),
+ @all_bind
+ );
+ },
+ FALLBACK => sub {
+ puke $invalid_args,
+ },
+ });
+
+ 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 {
+ puke(
+ 'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
+ . "-$op operator was given an undef-containing list: !!!AUDIT YOUR CODE "
+ . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract '
+ . 'will emit the logically correct SQL instead of raising this exception)'
+ );
+ },
+ });
+ push @all_sql, $sql;
+ 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);
+ },
+
+ UNDEF => sub {
+ puke "Argument passed to the '$op' operator can not be undefined";
+ },
+
+ FALLBACK => sub {
+ puke "special op $op 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 _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 },
+ });
+ }
+
+ 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},
+ });
+}
+
+
+#======================================================================
+# 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';
+
+ unless ($_[0]->{quote_char}) {
+ $_[0]->_assert_pass_injection_guard($_[1]);
+ return $_[1];
+ }
+
+ my $qref = ref $_[0]->{quote_char};
+ my ($l, $r);
+ if (!$qref) {
+ ($l, $r) = ( $_[0]->{quote_char}, $_[0]->{quote_char} );
+ }
+ elsif ($qref eq 'ARRAY') {
+ ($l, $r) = @{$_[0]->{quote_char}};
+ }
+ else {
+ puke "Unsupported quote_char format: $_[0]->{quote_char}";
+ }
+
+ # parts containing * are naturally unquoted
+ return join( $_[0]->{name_sep}||'', map
+ { $_ eq '*' ? $_ : $l . $_ . $r }
+ ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
+ );
+}
+
+
+# Conversion, if applicable
+sub _convert ($) {
+ #my ($self, $arg) = @_;
+ if ($_[0]->{convert}) {
+ return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
+ }
+ return $_[1];
+}
+
+# And bindtype
+sub _bindtype (@) {
+ #my ($self, $col, @vals) = @_;
+ # called often - tighten code
+ return $_[0]->{bindtype} eq 'columns'
+ ? map {[$_[1], $_]} @_[2 .. $#_]
+ : @_[2 .. $#_]
+ ;
+}
+
+# Dies if any element of @bind is not in [colname => value] format
+# if bindtype is 'columns'.
+sub _assert_bindval_matches_bindtype {
+# my ($self, @bind) = @_;
+ my $self = shift;
+ if ($self->{bindtype} eq 'columns') {
+ for (@_) {
+ if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
+ puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
+ }
+ }
+ }
+}
+
+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
+ # don't touch the argument ... crooked logic, but let's not change it!
+ 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;
+ puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
+ unless ref $data eq 'HASH';
+
+ 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);
+ },
+ });
+ }
+
+ return @all_bind;
+}
+
+sub generate {
+ my $self = shift;
+
+ my(@sql, @sqlq, @sqlv);
+
+ for (@_) {
+ my $ref = ref $_;
+ if ($ref eq 'HASH') {
+ for my $k (sort keys %$_) {
+ my $v = $_->{$k};
+ my $r = ref $v;
+ my $label = $self->_quote($k);
+ if ($r eq 'ARRAY') {
+ # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @sqlq, "$label = $sql";
+ push @sqlv, @bind;
+ } elsif ($r eq 'SCALAR') {
+ # literal SQL without bind
+ push @sqlq, "$label = $$v";
+ } else {
+ push @sqlq, "$label = ?";
+ push @sqlv, $self->_bindtype($k, $v);
+ }
+ }
+ push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
+ } elsif ($ref eq 'ARRAY') {
+ # unlike insert(), assume these are ONLY the column names, i.e. for SQL
+ for my $v (@$_) {
+ my $r = ref $v;
+ if ($r eq 'ARRAY') { # literal SQL with bind
+ my ($sql, @bind) = @$v;
+ $self->_assert_bindval_matches_bindtype(@bind);
+ push @sqlq, $sql;
+ push @sqlv, @bind;
+ } elsif ($r eq 'SCALAR') { # literal SQL without bind
+ # embedded literal SQL
+ push @sqlq, $$v;
+ } else {
+ push @sqlq, '?';
+ push @sqlv, $v;
+ }
+ }
+ push @sql, '(' . join(', ', @sqlq) . ')';
+ } elsif ($ref eq 'SCALAR') {
+ # literal SQL
+ push @sql, $$_;
+ } else {
+ # strings get case twiddled
+ push @sql, $self->_sqlcase($_);
+ }
+ }
+
+ my $sql = join ' ', @sql;
+
+ # this is pretty tricky
+ # if ask for an array, return ($stmt, @bind)
+ # otherwise, s/?/shift @sqlv/ to put it inline
+ if (wantarray) {
+ return ($sql, @sqlv);
+ } else {
+ 1 while $sql =~ s/\?/my $d = shift(@sqlv);
+ ref $d ? $d->[1] : $d/e;
+ return $sql;
+ }
+}
+
+
+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);
my $sth = $dbh->prepare($stmt);
$sth->execute(@bind);
-In addition, you can apply SQL functions to elements of your C<%data>
-by specifying an arrayref for the given hash value. For example, if
-you need to execute the Oracle C<to_date> function on a value, you
-can say something like this:
-
- my %data = (
- name => 'Bill',
- date_entered => ["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
- );
-
-The first value in the array is the actual SQL. Any other values are
-optional and would be included in the bind values array. This gives
-you:
-
- my($stmt, @bind) = $sql->insert('people', \%data);
-
- $stmt = "INSERT INTO people (name, date_entered)
- VALUES (?, to_date(?,'MM/DD/YYYY'))";
- @bind = ('Bill', '03/02/2003');
-
-An UPDATE is just as easy, all you change is the name of the function:
-
- my($stmt, @bind) = $sql->update('people', \%data);
-
-Notice that your C<%data> isn't touched; the module will generate
-the appropriately quirky SQL for you automatically. Usually you'll
-want to specify a WHERE clause for your UPDATE, though, which is
-where handling C<%where> hashes comes in handy...
+=head2 Inserting and Updating Arrays
-This module can generate pretty complicated WHERE statements
-easily. For example, simple C<key=value> pairs are taken to mean
-equality, and if you want to see if a field is within a set
-of values, you can use an arrayref. Let's say we wanted to
-SELECT some data based on this criteria:
+If your database has array types (like for example Postgres),
+activate the special option C<< array_datatypes => 1 >>
+when creating the C<SQL::Abstract> object.
+Then you may use an arrayref to insert and update database array types:
- my %where = (
- requestor => 'inna',
- worker => ['nwiger', 'rcwe', 'sfz'],
- status => { '!=', 'completed' }
+ my $sql = SQL::Abstract->new(array_datatypes => 1);
+ my %data = (
+ planets => [qw/Mercury Venus Earth Mars/]
);
- my($stmt, @bind) = $sql->select('tickets', '*', \%where);
+ my($stmt, @bind) = $sql->insert('solar_system', \%data);
-The above would give you something like this:
+This results in:
- $stmt = "SELECT * FROM tickets WHERE
- ( requestor = ? ) AND ( status != ? )
- AND ( worker = ? OR worker = ? OR worker = ? )";
- @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
+ $stmt = "INSERT INTO solar_system (planets) VALUES (?)"
-Which you could then use in DBI code like so:
+ @bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
- my $sth = $dbh->prepare($stmt);
- $sth->execute(@bind);
-Easy, eh?
+=head2 Inserting and Updating SQL
-=head1 FUNCTIONS
+In order to apply SQL functions to elements of your C<%data> you may
+specify a reference to an arrayref for the given hash value. For example,
+if you need to execute the Oracle C<to_date> function on a value, you can
+say something like this:
-The functions are simple. There's one for each major SQL operation,
-and a constructor you use first. The arguments are specified in a
-similar order to each function (table, then fields, then a where
-clause) to try and simplify things.
-
-=cut
-
-use Carp;
-use strict;
-
-our $VERSION = '1.22';
-our $REVISION = '$Id$';
-our $AUTOLOAD;
-
-# Fix SQL case, if so requested
-sub _sqlcase {
- my $self = shift;
- return $self->{case} ? $_[0] : uc($_[0]);
-}
-
-# Anon copies of arrays/hashes
-# Based on deep_copy example by merlyn
-# http://www.stonehenge.com/merlyn/UnixReview/col30.html
-sub _anoncopy {
- my $orig = shift;
- return (ref $orig eq 'HASH') ? +{map { $_ => _anoncopy($orig->{$_}) } keys %$orig}
- : (ref $orig eq 'ARRAY') ? [map _anoncopy($_), @$orig]
- : $orig;
-}
-
-# Debug
-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: ", @_;
-}
-
-sub puke (@) {
- my($func) = (caller(1))[3];
- croak "[$func] Fatal: ", @_;
-}
-
-# Utility functions
-sub _table {
- my $self = shift;
- my $from = shift;
- if (ref $from eq 'ARRAY') {
- return $self->_recurse_from(@$from);
- } elsif (ref $from eq 'HASH') {
- return $self->_make_as($from);
- } else {
- return $self->_quote($from);
- }
-}
+ my %data = (
+ name => 'Bill',
+ date_entered => \["to_date(?,'MM/DD/YYYY')", "03/02/2003"],
+ );
-sub _recurse_from {
- my ($self, $from, @join) = @_;
- my @sqlf;
- push(@sqlf, $self->_make_as($from));
- foreach my $j (@join) {
- push @sqlf, ', ' . $self->_quote($j) and next unless ref $j;
- push @sqlf, ', ' . $$j and next if ref $j eq 'SCALAR';
- my ($to, $on) = @$j;
-
- # check whether a join type exists
- my $join_clause = '';
- my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
- if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
- $join_clause = $self->_sqlcase(' '.($to_jt->{-join_type}).' JOIN ');
- } else {
- $join_clause = $self->_sqlcase(' JOIN ');
- }
- push(@sqlf, $join_clause);
+The first value in the array is the actual SQL. Any other values are
+optional and would be included in the bind values array. This gives
+you:
- if (ref $to eq 'ARRAY') {
- push(@sqlf, '(', $self->_recurse_from(@$to), ')');
- } else {
- push(@sqlf, $self->_make_as($to));
- }
- push(@sqlf, $self->_sqlcase(' ON '), $self->_join_condition($on));
- }
- return join('', @sqlf);
-}
+ my($stmt, @bind) = $sql->insert('people', \%data);
-sub _make_as {
- my ($self, $from) = @_;
- return $self->_quote($from) unless ref $from;
- return $$from if ref $from eq 'SCALAR';
- return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $self->_quote($_)) }
- reverse each %{$self->_skip_options($from)});
-}
+ $stmt = "INSERT INTO people (name, date_entered)
+ VALUES (?, to_date(?,'MM/DD/YYYY'))";
+ @bind = ('Bill', '03/02/2003');
-sub _skip_options {
- my ($self, $hash) = @_;
- my $clean_hash = {};
- $clean_hash->{$_} = $hash->{$_}
- for grep {!/^-/} keys %$hash;
- return $clean_hash;
-}
+An UPDATE is just as easy, all you change is the name of the function:
-sub _join_condition {
- my ($self, $cond) = @_;
- if (ref $cond eq 'HASH') {
- my %j;
- for (keys %$cond) {
- my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
- };
- return $self->_recurse_where(\%j);
- } elsif (ref $cond eq 'ARRAY') {
- return join(' OR ', map { $self->_join_condition($_) } @$cond);
- } else {
- die "Can't handle this yet!";
- }
-}
+ my($stmt, @bind) = $sql->update('people', \%data);
+Notice that your C<%data> isn't touched; the module will generate
+the appropriately quirky SQL for you automatically. Usually you'll
+want to specify a WHERE clause for your UPDATE, though, which is
+where handling C<%where> hashes comes in handy...
-sub _quote {
- my $self = shift;
- my $label = shift;
+=head2 Complex where statements
- return '' unless defined $label;
+This module can generate pretty complicated WHERE statements
+easily. For example, simple C<key=value> pairs are taken to mean
+equality, and if you want to see if a field is within a set
+of values, you can use an arrayref. Let's say we wanted to
+SELECT some data based on this criteria:
- return $label
- if $label eq '*';
+ my %where = (
+ requestor => 'inna',
+ worker => ['nwiger', 'rcwe', 'sfz'],
+ status => { '!=', 'completed' }
+ );
- return $$label if ref($label) eq 'SCALAR';
+ my($stmt, @bind) = $sql->select('tickets', '*', \%where);
- return $label unless $self->{quote_char};
+The above would give you something like this:
- if (ref $self->{quote_char} eq "ARRAY") {
+ $stmt = "SELECT * FROM tickets WHERE
+ ( requestor = ? ) AND ( status != ? )
+ AND ( worker = ? OR worker = ? OR worker = ? )";
+ @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
- return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
- if !defined $self->{name_sep};
+Which you could then use in DBI code like so:
- my $sep = $self->{name_sep};
- return join($self->{name_sep},
- map { $_ eq '*'
- ? $_
- : $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
- split( /\Q$sep\E/, $label ) );
- }
+ my $sth = $dbh->prepare($stmt);
+ $sth->execute(@bind);
+Easy, eh?
- return $self->{quote_char} . $label . $self->{quote_char}
- if !defined $self->{name_sep};
+=head1 FUNCTIONS
- return join $self->{name_sep},
- map { $_ eq '*' ? $_ : $self->{quote_char} . $_ . $self->{quote_char} }
- split /\Q$self->{name_sep}\E/, $label;
-}
+The functions are simple. There's one for each major SQL operation,
+and a constructor you use first. The arguments are specified in a
+similar order to each function (table, then fields, then a where
+clause) to try and simplify things.
-# Conversion, if applicable
-sub _convert ($) {
- my $self = shift;
- return @_ unless $self->{convert};
- my $conv = $self->_sqlcase($self->{convert});
- my @ret = map { $conv.'('.$_.')' } @_;
- return wantarray ? @ret : $ret[0];
-}
-# And bindtype
-sub _bindtype (@) {
- my $self = shift;
- my($col,@val) = @_;
- return $self->{bindtype} eq 'columns' ? [ @_ ] : @val;
-}
-# Modified -logic or -nest
-sub _modlogic ($) {
- my $self = shift;
- my $sym = @_ ? lc(shift) : $self->{logic};
- $sym =~ tr/_/ /;
- $sym = $self->{logic} if $sym eq 'nest';
- return $self->_sqlcase($sym); # override join
-}
=head2 new(option => 'value')
SELECT a_field FROM a_table WHERE some_field LIKE '%someval%'
+Any setting other than 'lower' is ignored.
+
=item cmp
This determines what the default comparison operator is. By default
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
+
+Expressions for inserting boolean values within SQL statements.
+By default these are C<1=1> and C<1=0>. They are used
+by the special operators C<-in> and C<-not_in> for generating
+correct SQL even when the argument is an empty array (see below).
+
=item logic
This determines the default logical operator for multiple WHERE
-statements in arrays. By default it is "or", meaning that a WHERE
+statements in arrays or hashes. If absent, the default logic is "or"
+for arrays, and "and" for hashes. This means that a WHERE
array of the form:
@where = (
- event_date => {'>=', '2/13/99'},
- event_date => {'<=', '4/24/03'},
+ event_date => {'>=', '2/13/99'},
+ event_date => {'<=', '4/24/03'},
);
-Will generate SQL like this:
+will generate SQL like this:
WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
WHERE event_date >= '2/13/99' AND event_date <= '4/24/03'
+The logic can also be changed locally by inserting
+a modifier in front of an arrayref :
+
+ @where = (-and => [event_date => {'>=', '2/13/99'},
+ event_date => {'<=', '4/24/03'} ]);
+
+See the L</"WHERE CLAUSES"> section for explanations.
+
=item convert
This will automatically convert comparisons using the specified SQL
);
You can then iterate through this manually, using DBI's C<bind_param()>.
-
+
$sth->prepare($stmt);
my $i = 1;
for (@bind) {
sub called C<bind_fields()> or something and reuse it repeatedly. You still
get a layer of abstraction over manual SQL specification.
+Note that if you set L</bindtype> to C<columns>, the C<\[$sql, @bind]>
+construct (see L</Literal SQL with placeholders and bind values (subqueries)>)
+will expect the bind values in this format.
+
=item quote_char
This is the character that a table or column name will be quoted
-with. By default this is an empty string, but you could set it to
+with. By default this is an empty string, but you could set it to
the character C<`>, to generate SQL like this:
SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
-This is useful if you have tables or columns that are reserved words
-in your database's SQL dialect.
+Alternatively, you can supply an array ref of two items, the first being the left
+hand quote character, and the second the right hand quote character. For
+example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes
+that generates SQL like this:
+
+ SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%'
+
+Quoting is useful if you have tables or columns names that are reserved
+words in your database's SQL dialect.
=item name_sep
SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
-=back
+=item injection_guard
-=cut
+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.:
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
- my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
+ my %condition_as_column_value_pairs = get_values_from_user();
+ $sqla->select( ... , \%condition_as_column_value_pairs );
- # choose our case by keeping an option around
- delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
+If the expression matches an exception is thrown. Note that literal SQL
+supplied via C<\'...'> or C<\['...']> is B<not> checked in any way.
- # override logical operator
- $opt{logic} = uc $opt{logic} if $opt{logic};
+Defaults to checking for C<;> and the C<GO> keyword (TransactSQL)
- # how to return bind vars
- $opt{bindtype} ||= delete($opt{bind_type}) || 'normal';
+=item array_datatypes
- # default comparison is "=", but can be overridden
- $opt{cmp} ||= '=';
+When this option is true, arrayrefs in INSERT or UPDATE are
+interpreted as array datatypes and are passed directly
+to the DBI layer.
+When this option is false, arrayrefs are interpreted
+as literal SQL, just like refs to arrayrefs
+(but this behavior is for backwards compatibility; when writing
+new queries, use the "reference to arrayref" syntax
+for literal SQL).
- # default quotation character around tables/columns
- $opt{quote_char} ||= '';
- return bless \%opt, $class;
-}
+=item special_ops
+
+Takes a reference to a list of "special operators"
+to extend the syntax understood by L<SQL::Abstract>.
+See section L</"SPECIAL OPERATORS"> for details.
+
+=item unary_ops
+
+Takes a reference to a list of "unary operators"
+to extend the syntax understood by L<SQL::Abstract>.
+See section L</"UNARY OPERATORS"> for details.
+
+
+
+=back
-=head2 insert($table, \@values || \%fieldvals)
+=head2 insert($table, \@values || \%fieldvals, \%options)
This is the simplest function. You simply give it a table name
and either an arrayref of values or hashref of field/value pairs.
It returns an SQL INSERT statement and a list of bind values.
+See the sections on L</"Inserting and Updating Arrays"> and
+L</"Inserting and Updating SQL"> for information on how to insert
+with those data types.
-=cut
+The optional C<\%options> hash reference may contain additional
+options to generate the insert SQL. Currently supported options
+are:
-sub insert {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
-
- my $sql = $self->_sqlcase('insert into') . " $table ";
- my(@sqlf, @sqlv, @sqlq) = ();
-
- my $ref = ref $data;
- if ($ref eq 'HASH') {
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- # named fields, so must save names in order
- push @sqlf, $self->_quote($k);
- if ($r eq 'ARRAY') {
- # SQL included for values
- my @val = @$v;
- push @sqlq, shift @val;
- push @sqlv, $self->_bindtype($k, @val);
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, $$v;
- } else {
- push @sqlq, '?';
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
- $sql .= '(' . join(', ', @sqlf) .') '. $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')';
- } elsif ($ref eq 'ARRAY') {
- # just generate values(?,?) part
- # no names (arrayref) so can't generate bindtype
- carp "Warning: ",__PACKAGE__,"->insert called with arrayref when bindtype set"
- if $self->{bindtype} ne 'normal';
- for my $v (@$data) {
- my $r = ref $v;
- if ($r eq 'ARRAY') {
- my @val = @$v;
- push @sqlq, shift @val;
- push @sqlv, @val;
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, $$v;
- } else {
- push @sqlq, '?';
- push @sqlv, $v;
- }
- }
- $sql .= $self->_sqlcase('values') . ' ('. join(', ', @sqlq) .')';
- } elsif ($ref eq 'SCALAR') {
- # literal SQL
- $sql .= $$data;
- } else {
- puke "Unsupported data type specified to \$sql->insert";
- }
+=over 4
- return wantarray ? ($sql, @sqlv) : $sql;
-}
+=item returning
+
+Takes either a scalar of raw SQL fields, or an array reference of
+field names, and adds on an SQL C<RETURNING> statement at the end.
+This allows you to return data generated by the insert statement
+(such as row IDs) without performing another C<SELECT> statement.
+Note, however, this is not part of the SQL standard and may not
+be supported by all database engines.
+
+=back
=head2 update($table, \%fieldvals, \%where)
This takes a table, hashref of field/value pairs, and an optional
-hashref WHERE clause. It returns an SQL UPDATE function and a list
+hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
of bind values.
+See the sections on L</"Inserting and Updating Arrays"> and
+L</"Inserting and Updating SQL"> for information on how to insert
+with those data types.
-=cut
-
-sub update {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
+=head2 select($source, $fields, $where, $order)
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ');
- my(@sqlf, @sqlv) = ();
-
- puke "Unsupported data type specified to \$sql->update"
- unless ref $data eq 'HASH';
+This returns a SQL SELECT statement and associated list of bind values, as
+specified by the arguments :
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
- if ($r eq 'ARRAY') {
- # SQL included for values
- my @bind = @$v;
- my $sql = shift @bind;
- push @sqlf, "$label = $sql";
- push @sqlv, $self->_bindtype($k, @bind);
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlf, "$label = $$v";
- } else {
- push @sqlf, "$label = ?";
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
+=over
- $sql .= join ', ', @sqlf;
+=item $source
- if ($where) {
- my($wsql, @wval) = $self->where($where);
- $sql .= $wsql;
- push @sqlv, @wval;
- }
+Specification of the 'FROM' part of the statement.
+The argument can be either a plain scalar (interpreted as a table
+name, will be quoted), or an arrayref (interpreted as a list
+of table names, joined by commas, quoted), or a scalarref
+(literal table name, not quoted), or a ref to an arrayref
+(list of literal table names, joined by commas, not quoted).
- return wantarray ? ($sql, @sqlv) : $sql;
-}
+=item $fields
-=head2 select($table, \@fields, \%where, \@order)
+Specification of the list of fields to retrieve from
+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 that of
+the first argument C<$source>, for backwards compatibility reasons.
-This takes a table, arrayref of fields (or '*'), optional hashref
-WHERE clause, and optional arrayref order by, and returns the
-corresponding SQL SELECT statement and list of bind values.
+=item $where
-=cut
+Optional argument to specify the WHERE part of the query.
+The argument is most often a hashref, but can also be
+an arrayref or plain scalar --
+see section L<WHERE clause|/"WHERE CLAUSES"> for details.
-sub select {
- my $self = shift;
- my $table = $self->_table(shift);
- my $fields = shift || '*';
- my $where = shift;
- my $order = shift;
+=item $order
- my $f = (ref $fields eq 'ARRAY') ? join ', ', map { $self->_quote($_) } @$fields : $fields;
- my $sql = join ' ', $self->_sqlcase('select'), $f, $self->_sqlcase('from'), $table;
+Optional argument to specify the ORDER BY part of the query.
+The argument can be a scalar, a hashref or an arrayref
+-- see section L<ORDER BY clause|/"ORDER BY CLAUSES">
+for details.
- my(@sqlf, @sqlv) = ();
- my($wsql, @wval) = $self->where($where, $order);
- $sql .= $wsql;
- push @sqlv, @wval;
+=back
- return wantarray ? ($sql, @sqlv) : $sql;
-}
=head2 delete($table, \%where)
-This takes a table name and optional hashref WHERE clause.
+This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
It returns an SQL DELETE statement and list of bind values.
-=cut
-
-sub delete {
- my $self = shift;
- my $table = $self->_table(shift);
- my $where = shift;
-
- my $sql = $self->_sqlcase('delete from') . " $table";
- my(@sqlf, @sqlv) = ();
-
- if ($where) {
- my($wsql, @wval) = $self->where($where);
- $sql .= $wsql;
- push @sqlv, @wval;
- }
-
- return wantarray ? ($sql, @sqlv) : $sql;
-}
-
=head2 where(\%where, \@order)
-This is used to generate just the WHERE clause. For example,
-if you have an arbitrary data structure and know what the
-rest of your SQL is going to look like, but want an easy way
-to produce a WHERE clause, use this. It returns an SQL WHERE
-clause and list of bind values.
-
-=cut
-
-# Finally, a separate routine just to handle WHERE clauses
-sub where {
- my $self = shift;
- my $where = shift;
- my $order = shift;
-
- # Need a separate routine to properly wrap w/ "where"
- my $sql = '';
- my @ret = $self->_recurse_where($where);
- if (@ret) {
- my $wh = shift @ret;
- $sql .= $self->_sqlcase(' where ') . $wh if $wh;
- }
-
- # order by?
- if ($order) {
- $sql .= $self->_order_by($order);
- }
-
- return wantarray ? ($sql, @ret) : $sql;
-}
-
-
-sub _recurse_where {
- local $^W = 0; # really, you've gotta be fucking kidding me
- my $self = shift;
- my $where = _anoncopy(shift); # prevent destroying original
- my $ref = ref $where || '';
- my $join = shift || $self->{logic} ||
- ($ref eq 'ARRAY' ? $self->_sqlcase('or') : $self->_sqlcase('and'));
-
- # For assembling SQL fields and values
- my(@sqlf, @sqlv) = ();
-
- # If an arrayref, then we join each element
- if ($ref eq 'ARRAY') {
- # need to use while() so can shift() for arrays
- my $subjoin;
- while (my $el = shift @$where) {
-
- # skip empty elements, otherwise get invalid trailing AND stuff
- if (my $ref2 = ref $el) {
- if ($ref2 eq 'ARRAY') {
- next unless @$el;
- } elsif ($ref2 eq 'HASH') {
- next unless %$el;
- $subjoin ||= $self->_sqlcase('and');
- } elsif ($ref2 eq 'SCALAR') {
- # literal SQL
- push @sqlf, $$el;
- next;
- }
- $self->_debug("$ref2(*top) means join with $subjoin");
- } else {
- # top-level arrayref with scalars, recurse in pairs
- $self->_debug("NOREF(*top) means join with $subjoin");
- $el = {$el => shift(@$where)};
- }
- my @ret = $self->_recurse_where($el, $subjoin);
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- }
- }
- elsif ($ref eq 'HASH') {
- # Note: during recursion, the last element will always be a hashref,
- # since it needs to point a column => value. So this be the end.
- for my $k (sort keys %$where) {
- my $v = $where->{$k};
- my $label = $self->_quote($k);
-
- if ($k =~ /^-(\D+)/) {
- # special nesting, like -and, -or, -nest, so shift over
- my $subjoin = $self->_modlogic($1);
- $self->_debug("OP(-$1) means special logic ($subjoin), recursing...");
- my @ret = $self->_recurse_where($v, $subjoin);
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- } elsif (! defined($v)) {
- # undef = null
- $self->_debug("UNDEF($k) means IS NULL");
- push @sqlf, $label . $self->_sqlcase(' is null');
- } elsif (ref $v eq 'ARRAY') {
- my @v = @$v;
-
- # multiple elements: multiple options
- $self->_debug("ARRAY($k) means multiple elements: [ @v ]");
-
- # special nesting, like -and, -or, -nest, so shift over
- my $subjoin = $self->_sqlcase('or');
- if ($v[0] =~ /^-(\D+)/) {
- $subjoin = $self->_modlogic($1); # override subjoin
- $self->_debug("OP(-$1) means special logic ($subjoin), shifting...");
- shift @v;
- }
-
- # map into an array of hashrefs and recurse
- my @ret = $self->_recurse_where([map { {$k => $_} } @v], $subjoin);
-
- # push results into our structure
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- } elsif (ref $v eq 'HASH') {
- # modified operator { '!=', 'completed' }
- for my $f (sort keys %$v) {
- my $x = $v->{$f};
-
- # do the right thing for single -in values
- $x = [$x] if ($f =~ /^-?\s*(not[\s_]+)?in\s*$/i && ref $x ne 'ARRAY');
-
- $self->_debug("HASH($k) means modified operator: { $f }");
-
- # check for the operator being "IN" or "BETWEEN" or whatever
- if (ref $x eq 'ARRAY') {
- if ($f =~ /^-?\s*(not[\s_]+)?(in|between)\s*$/i) {
- my $u = $self->_modlogic($1 . $2);
- $self->_debug("HASH($f => $x) uses special operator: [ $u ]");
- if ($u =~ /between/i) {
- # SQL sucks
- # Throw an exception if you try to use between with
- # anything other than 2 values
- $self->puke("You need two values to use between") unless @$x == 2;
- push @sqlf, join ' ', $self->_convert($label), $u, $self->_convert('?'),
- $self->_sqlcase('and'), $self->_convert('?');
- } elsif (@$x) {
- # DWIM for empty arrayrefs
- push @sqlf, join ' ', $self->_convert($label), $u, '(',
- join(', ', map { $self->_convert('?') } @$x),
- ')';
- } elsif(@$x == 0){
- # Empty IN defaults to 0=1 and empty NOT IN to 1=1
- push(@sqlf, ($u =~ /not/i ? "1=1" : "0=1"));
- }
- push @sqlv, $self->_bindtype($k, @$x);
- } else {
- # multiple elements: multiple options
- $self->_debug("ARRAY($x) means multiple elements: [ @$x ]");
-
- # map into an array of hashrefs and recurse
- my @ret = $self->_recurse_where([map { {$k => {$f, $_}} } @$x]);
-
- # push results into our structure
- push @sqlf, shift @ret;
- push @sqlv, @ret;
- }
- } elsif (! defined($x)) {
- # undef = NOT null
- my $not = ($f eq '!=' || $f eq 'not like') ? ' not' : '';
- push @sqlf, $label . $self->_sqlcase(" is$not null");
- } else {
- # regular ol' value
- $f =~ s/^-//; # strip leading -like =>
- $f =~ s/_/ /; # _ => " "
- push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($f), $self->_convert('?');
- push @sqlv, $self->_bindtype($k, $x);
- }
- }
- } elsif (ref $v eq 'SCALAR') {
- # literal SQL
- $self->_debug("SCALAR($k) means literal SQL: $$v");
- push @sqlf, "$label $$v";
- } else {
- # standard key => val
- $self->_debug("NOREF($k) means simple key=val: $k $self->{cmp} $v");
- push @sqlf, join ' ', $self->_convert($label), $self->_sqlcase($self->{cmp}), $self->_convert('?');
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
- }
- elsif ($ref eq 'SCALAR') {
- # literal sql
- $self->_debug("SCALAR(*top) means literal SQL: $$where");
- push @sqlf, $$where;
- }
- elsif (defined $where) {
- # literal sql
- $self->_debug("NOREF(*top) means literal SQL: $where");
- push @sqlf, $where;
- }
-
- # assemble and return sql
- my $wsql = @sqlf ? '( ' . join(" $join ", @sqlf) . ' )' : '';
- return wantarray ? ($wsql, @sqlv) : $wsql;
-}
-
-sub _order_by {
- my $self = shift;
- my $ref = ref $_[0];
-
- my @vals = $ref eq 'ARRAY' ? @{$_[0]} :
- $ref eq 'SCALAR' ? $_[0] :
- $ref eq '' ? $_[0] :
- puke "Unsupported data struct $ref for ORDER BY";
-
- my $val = join ', ', map { $self->_quote($_) } @vals;
- return $val ? $self->_sqlcase(' order by')." $val" : '';
-}
-
-=head2 values(\%data)
-
-This just returns the values from the hash C<%data>, in the same
-order that would be returned from any of the other above queries.
-Using this allows you to markedly speed up your queries if you
-are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
-
-=cut
-
-sub values {
- my $self = shift;
- my $data = shift || return;
- puke "Argument to ", __PACKAGE__, "->values must be a \\%hash"
- unless ref $data eq 'HASH';
- return map { $self->_bindtype($_, $data->{$_}) } sort keys %$data;
-}
-
-=head2 generate($any, 'number', $of, \@data, $struct, \%types)
-
-Warning: This is an experimental method and subject to change.
-
-This returns arbitrarily generated SQL. It's a really basic shortcut.
-It will return two different things, depending on return context:
-
- my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
- my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
-
-These would return the following:
-
- # First calling form
- $stmt = "CREATE TABLE test (?, ?)";
- @bind = (field1, field2);
-
- # Second calling form
- $stmt_and_val = "CREATE TABLE test (field1, field2)";
-
-Depending on what you're trying to do, it's up to you to choose the correct
-format. In this example, the second form is what you would want.
-
-By the same token:
-
- $sql->generate('alter session', { nls_date_format => 'MM/YY' });
-
-Might give you:
-
- ALTER SESSION SET nls_date_format = 'MM/YY'
-
-You get the idea. Strings get their case twiddled, but everything
-else remains verbatim.
-
-=cut
-
-sub generate {
- my $self = shift;
-
- my(@sql, @sqlq, @sqlv);
-
- for (@_) {
- my $ref = ref $_;
- if ($ref eq 'HASH') {
- for my $k (sort keys %$_) {
- my $v = $_->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
- if ($r eq 'ARRAY') {
- # SQL included for values
- my @bind = @$v;
- my $sql = shift @bind;
- push @sqlq, "$label = $sql";
- push @sqlv, $self->_bindtype($k, @bind);
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, "$label = $$v";
- } else {
- push @sqlq, "$label = ?";
- push @sqlv, $self->_bindtype($k, $v);
- }
- }
- push @sql, $self->_sqlcase('set'), join ', ', @sqlq;
- } elsif ($ref eq 'ARRAY') {
- # unlike insert(), assume these are ONLY the column names, i.e. for SQL
- for my $v (@$_) {
- my $r = ref $v;
- if ($r eq 'ARRAY') {
- my @val = @$v;
- push @sqlq, shift @val;
- push @sqlv, @val;
- } elsif ($r eq 'SCALAR') {
- # embedded literal SQL
- push @sqlq, $$v;
- } else {
- push @sqlq, '?';
- push @sqlv, $v;
- }
- }
- push @sql, '(' . join(', ', @sqlq) . ')';
- } elsif ($ref eq 'SCALAR') {
- # literal SQL
- push @sql, $$_;
- } else {
- # strings get case twiddled
- push @sql, $self->_sqlcase($_);
- }
- }
-
- my $sql = join ' ', @sql;
+This is used to generate just the WHERE clause. For example,
+if you have an arbitrary data structure and know what the
+rest of your SQL is going to look like, but want an easy way
+to produce a WHERE clause, use this. It returns an SQL WHERE
+clause and list of bind values.
- # this is pretty tricky
- # if ask for an array, return ($stmt, @bind)
- # otherwise, s/?/shift @sqlv/ to put it inline
- if (wantarray) {
- return ($sql, @sqlv);
- } else {
- 1 while $sql =~ s/\?/my $d = shift(@sqlv);
- ref $d ? $d->[1] : $d/e;
- return $sql;
- }
-}
-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, @_);
-}
+=head2 values(\%data)
-1;
+This just returns the values from the hash C<%data>, in the same
+order that would be returned from any of the other above queries.
+Using this allows you to markedly speed up your queries if you
+are affecting lots of rows. See below under the L</"PERFORMANCE"> section.
-__END__
+=head2 generate($any, 'number', $of, \@data, $struct, \%types)
+
+Warning: This is an experimental method and subject to change.
+
+This returns arbitrarily generated SQL. It's a really basic shortcut.
+It will return two different things, depending on return context:
+
+ my($stmt, @bind) = $sql->generate('create table', \$table, \@fields);
+ my $stmt_and_val = $sql->generate('create table', \$table, \@fields);
+
+These would return the following:
+
+ # First calling form
+ $stmt = "CREATE TABLE test (?, ?)";
+ @bind = (field1, field2);
+
+ # Second calling form
+ $stmt_and_val = "CREATE TABLE test (field1, field2)";
+
+Depending on what you're trying to do, it's up to you to choose the correct
+format. In this example, the second form is what you would want.
+
+By the same token:
+
+ $sql->generate('alter session', { nls_date_format => 'MM/YY' });
+
+Might give you:
+
+ ALTER SESSION SET nls_date_format = 'MM/YY'
+
+You get the idea. Strings get their case twiddled, but everything
+else remains verbatim.
=head1 WHERE CLAUSES
+=head2 Introduction
+
This module uses a variation on the idea from L<DBIx::Abstract>. It
is B<NOT>, repeat I<not> 100% compatible. B<The main logic of this
module is that things in arrays are OR'ed, and things in hashes
However, note that the C<%where> hash can be used directly in any
of the other functions as well, as described above.
+=head2 Key-value pairs
+
So, let's get started. To begin, a simple hash:
my %where = (
);
This simple code will create the following:
-
+
$stmt = "WHERE user = ? AND ( status = ? OR status = ? OR status = ? )";
@bind = ('nwiger', 'assigned', 'in-progress', 'pending');
+A field associated to an empty arrayref will be considered a
+logical false and will generate 0=1.
+
+=head2 Tests for NULL values
+
+If the value part is C<undef> then this is converted to SQL <IS NULL>
+
+ my %where = (
+ user => 'nwiger',
+ status => undef,
+ );
+
+becomes:
+
+ $stmt = "WHERE user = ? AND status IS NULL";
+ @bind = ('nwiger');
+
+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,
you can use a hashref for a given column:
To test against multiple values, just enclose the values in an arrayref:
- status => { '!=', ['assigned', 'in-progress', 'pending'] };
+ status => { '=', ['assigned', 'in-progress', 'pending'] };
Which would give you:
- "WHERE status != ? OR status != ? OR status != ?"
+ "WHERE status = ? OR status = ? OR status = ?"
+
-But, this is probably not what you want in this case (look at it). So
-the hashref can also contain multiple pairs, in which case it is expanded
+The hashref can also contain multiple pairs, in which case it is expanded
into an C<AND> of its elements:
my %where = (
$stmt = "WHERE user = ? AND status != ? AND status NOT LIKE ?";
@bind = ('nwiger', 'completed', 'pending%');
+
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 ( 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:
+
+ my %where = (
+ date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
+ date_expires => { '<' => \"now()" }
);
Which would generate:
- $stmt = "WHERE user = ? AND priority = ? OR priority != ?";
- @bind = ('nwiger', '2', '1');
+ $stmt = "WHERE date_entered > "to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
+ @bind = ('11/26/2008');
+
+
+=head2 Logic and nesting operators
-However, there is a subtle trap if you want to say something like
+In the example above,
+there is a subtle trap if you want to say something like
this (notice the C<AND>):
WHERE priority != ? AND priority != ?
As the second C<!=> key will obliterate the first. The solution
is to use the special C<-modifier> form inside an arrayref:
- priority => [ -and => {'!=', 2}, {'!=', 1} ]
+ priority => [ -and => {'!=', 2},
+ {'!=', 1} ]
+
Normally, these would be joined by C<OR>, but the modifier tells it
to use C<AND> instead. (Hint: You can use this in conjunction with the
status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
-In addition to C<-and> and C<-or>, 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' ],
- );
+=head2 Special operators : IN, BETWEEN, etc.
You can also use the hashref format to compare a list of fields using the
C<IN> comparison operator, by specifying the list as an arrayref:
$stmt = "WHERE status = ? AND reportid IN (?,?,?)";
@bind = ('completed', '567', '2335', '2');
-You can use this same format to use other grouping functions, such
-as C<BETWEEN>, C<SOME>, and so forth. For example:
+The reverse operator C<-not_in> generates SQL C<NOT IN> and is used in
+the same way.
+
+If the argument to C<-in> is an empty array, 'sqlfalse' is generated
+(by default : C<1=0>). Similarly, C<< -not_in => [] >> generates
+'sqltrue' (by default : C<1=1>).
+
+In addition to the array you can supply a chunk of literal sql or
+literal sql with bind:
+
+ my %where = {
+ customer => { -in => \[
+ 'SELECT cust_id FROM cust WHERE balance > ?',
+ 2000,
+ ],
+ status => { -in => \'SELECT status_codes FROM states' },
+ };
+
+would generate:
+
+ $stmt = "WHERE (
+ customer IN ( SELECT cust_id FROM cust WHERE balance > ? )
+ AND status IN ( SELECT status_codes FROM states )
+ )";
+ @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 = (
user => 'nwiger',
WHERE user = ? AND completion_date NOT BETWEEN ( ? AND ? )
+Just like with C<-in> all plausible combinations of literal SQL
+are possible:
+
+ my %where = {
+ start0 => { -between => [ 1, 2 ] },
+ start1 => { -between => \["? AND ?", 1, 2] },
+ start2 => { -between => \"lower(x) AND upper(y)" },
+ start3 => { -between => [
+ \"lower(x)",
+ \["upper(?)", 'stuff' ],
+ ] },
+ };
+
+Would give you:
+
+ $stmt = "WHERE (
+ ( start0 BETWEEN ? AND ? )
+ AND ( start1 BETWEEN ? AND ? )
+ AND ( start2 BETWEEN lower(x) AND upper(y) )
+ AND ( start3 BETWEEN lower(x) AND upper(?) )
+ )";
+ @bind = (1, 2, 1, 2, 'stuff');
+
+
+These are the two builtin "special operators"; but the
+list can be expanded : see section L</"SPECIAL OPERATORS"> below.
+
+=head2 Unary operators: bool
+
+If you wish to test against boolean columns or functions within your
+database you can use the C<-bool> and C<-not_bool> operators. For
+example to test the column C<is_user> being true and the column
+C<is_enabled> being false you would use:-
+
+ my %where = (
+ -bool => 'is_user',
+ -not_bool => 'is_enabled',
+ );
+
+Would give you:
+
+ WHERE is_user AND NOT is_enabled
+
+If a more complex combination is required, testing more conditions,
+then you should use the and/or operators:-
+
+ my %where = (
+ -and => [
+ -bool => 'one',
+ -not_bool => { two=> { -rlike => 'bar' } },
+ -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] },
+ ],
+ );
+
+Would give you:
+
+ WHERE
+ one
+ AND
+ (NOT two RLIKE ?)
+ AND
+ (NOT ( three = ? OR three > ? ))
+
+
+=head2 Nested conditions, -and/-or prefixes
+
So far, we've seen how multiple conditions are joined with a top-level
C<AND>. We can change this by putting the different conditions we want in
hashes and then putting those hashes in an array. For example:
OR ( user = ? AND status = ? ) )";
@bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
-This can be combined with the C<-nest> operator to properly group
-SQL statements:
+
+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 = ? )
+ ) )
+
+=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
+several constraints on one column, the C<-and> operator goes
+C<inside> the arrayref. Here is an example combining both features :
+
+ my @where = (
+ -and => [a => 1, b => 2],
+ -or => [c => 3, d => 4],
+ e => [-and => {-like => 'foo%'}, {-like => '%bar'} ]
+ )
+
+yielding
+
+ WHERE ( ( ( a = ? AND b = ? )
+ OR ( c = ? OR d = ? )
+ OR ( e LIKE ? AND e LIKE ? ) ) )
+
+This difference in syntax is unfortunate but must be preserved for
+historical reasons. So be careful : the two examples below would
+seem algebraically equivalent, but they are not
-Finally, sometimes only literal SQL will do. If you want to include
-literal SQL verbatim, you can specify it as a scalar reference, namely:
+ {col => [-and => {-like => 'foo%'}, {-like => '%bar'}]}
+ # yields : WHERE ( ( col LIKE ? AND col LIKE ? ) )
+
+ [-and => {col => {-like => 'foo%'}, {col => {-like => '%bar'}}]]
+ # yields : WHERE ( ( col LIKE ? OR col LIKE ? ) )
+
+
+=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.
+
+=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');
+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
+
+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 = (
+ array => { -value => [1, 2, 3] }
+ );
+
+will result in:
+
+ $stmt = 'WHERE array = ?';
+ @bind = ([1, 2, 3]);
+
+Note that if you were to simply say:
+
+ my %where = (
+ array => [1, 2, 3]
+ );
+
+the result would probably not be what you wanted:
+
+ $stmt = 'WHERE array = ? OR array = ? OR array = ?';
+ @bind = (1, 2, 3);
+
+=head3 Literal SQL
+
+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 => { -in => \'(SELECT name FROM hitmen)' },
+ );
+
+Would create:
+
+ $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.
-Of course, just to prove a point, the above can also be accomplished
-with this:
+=head4 CAVEAT
+
+ 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 --
+not so common, but perfectly legal Perl). For example, to find a date
+in Postgres you can use something like this:
my %where = (
- priority => { '<', 2 },
- requestor => { '!=', undef },
+ date_column => \[q/= date '2008-09-30' - ?::integer/, 10/]
+ )
+
+This would create:
+
+ $stmt = "WHERE ( date_column = date '2008-09-30' - ?::integer )"
+ @bind = ('10');
+
+Note that you must pass the bind values in the same format as they are returned
+by L</where>. That means that if you set L</bindtype> to C<columns>, you must
+provide the bind values in the C<< [ column_meta => value ] >> format, where
+C<column_meta> is an opaque scalar value; most commonly the column name, but
+you can use any scalar value (including references and blessed references),
+L<SQL::Abstract> will simply pass it through intact. So if C<bindtype> is set
+to C<columns> the above example will look like:
+
+ my %where = (
+ date_column => \[q/= date '2008-09-30' - ?::integer/, [ dummy => 10 ]/]
+ )
+
+Literal SQL is especially useful for nesting parenthesized clauses in the
+main SQL query. Here is a first example :
+
+ my ($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?",
+ 100, "foo%");
+ my %where = (
+ foo => 1234,
+ bar => \["IN ($sub_stmt)" => @sub_bind],
+ );
+
+This yields :
+
+ $stmt = "WHERE (foo = ? AND bar IN (SELECT c1 FROM t1
+ WHERE c2 < ? AND c3 LIKE ?))";
+ @bind = (1234, 100, "foo%");
+
+Other subquery operators, like for example C<"E<gt> ALL"> or C<"NOT IN">,
+are expressed in the same way. Of course the C<$sub_stmt> and
+its associated bind values can be generated through a former call
+to C<select()> :
+
+ my ($sub_stmt, @sub_bind)
+ = $sql->select("t1", "c1", {c2 => {"<" => 100},
+ c3 => {-like => "foo%"}});
+ my %where = (
+ foo => 1234,
+ bar => \["> ALL ($sub_stmt)" => @sub_bind],
+ );
+
+In the examples above, the subquery was used as an operator on a column;
+but the same principle also applies for a clause within the main C<%where>
+hash, like an EXISTS subquery :
+
+ my ($sub_stmt, @sub_bind)
+ = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"});
+ my %where = ( -and => [
+ foo => 1234,
+ \["EXISTS ($sub_stmt)" => @sub_bind],
+ ]);
+
+which yields
+
+ $stmt = "WHERE (foo = ? AND EXISTS (SELECT * FROM t1
+ WHERE c1 = ? AND c2 > t0.c0))";
+ @bind = (1234, 1);
+
+
+Observe that the condition on C<c2> in the subquery refers to
+column C<t0.c0> of the main query : this is I<not> a bind
+value, so we have to express it through a scalar ref.
+Writing C<< c2 => {">" => "t0.c0"} >> would have generated
+C<< c2 > ? >> with bind value C<"t0.c0"> ... not exactly
+what we wanted here.
+
+Finally, here is an example where a subquery is used
+for expressing unary negation:
+
+ my ($sub_stmt, @sub_bind)
+ = $sql->where({age => [{"<" => 10}, {">" => 20}]});
+ $sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause
+ my %where = (
+ lname => {like => '%son%'},
+ \["NOT ($sub_stmt)" => @sub_bind],
);
-TMTOWTDI.
+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
These pages could go on for a while, since the nesting of the data
structures this module can handle are pretty much unlimited (the
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
+column name,) a hash of C<< { -desc => 'col' } >> or C<< { -asc => 'col' } >>,
+or an array of either of the two previous forms. Examples:
+
+ Given | Will Generate
+ ----------------------------------------------------------
+ |
+ \'colA DESC' | ORDER BY colA DESC
+ |
+ 'colA' | ORDER BY colA
+ |
+ [qw/colA colB/] | ORDER BY colA, colB
+ |
+ {-asc => 'colA'} | ORDER BY colA ASC
+ |
+ {-desc => 'colB'} | ORDER BY colB DESC
+ |
+ ['colA', {-asc => 'colB'}] | ORDER BY colA, colB ASC
+ |
+ { -asc => [qw/colA colB/] } | ORDER BY colA ASC, colB ASC
+ |
+ [ |
+ { -asc => 'colA' }, | ORDER BY colA ASC, colB DESC,
+ { -desc => [qw/colB/], | colC ASC, colD ASC
+ { -asc => [qw/colC colD/],|
+ ] |
+ ===========================================================
+
+
+
+=head1 SPECIAL OPERATORS
+
+ my $sqlmaker = SQL::Abstract->new(special_ops => [
+ {
+ regex => qr/.../,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ ...
+ },
+ },
+ {
+ regex => qr/.../,
+ handler => 'method_name',
+ },
+ ]);
+
+A "special operator" is a SQL syntactic clause that can be
+applied to a field, instead of a usual binary operator.
+For example :
+
+ WHERE field IN (?, ?, ?)
+ WHERE field BETWEEN ? AND ?
+ WHERE MATCH(field) AGAINST (?, ?)
+
+Special operators IN and BETWEEN are fairly standard and therefore
+are builtin within C<SQL::Abstract> (as the overridable methods
+C<_where_field_IN> and C<_where_field_BETWEEN>). For other operators,
+like the MATCH .. AGAINST example above which is specific to MySQL,
+you can write your own operator handlers - supply a C<special_ops>
+argument to the C<new> method. That argument takes an arrayref of
+operator definitions; each operator definition is a hashref with two
+entries:
+
+=over
+
+=item regex
+
+the regular expression to match the operator
+
+=item handler
+
+Either a coderef or a plain scalar method name. In both cases
+the expected return is C<< ($sql, @bind) >>.
+
+When supplied with a method name, it is simply called on the
+L<SQL::Abstract/> object as:
+
+ $self->$method_name ($field, $op, $arg)
+
+ Where:
+
+ $op is the part that matched the handler regex
+ $field is the LHS of the operator
+ $arg is the RHS
+
+When supplied with a coderef, it is called as:
+
+ $coderef->($self, $field, $op, $arg)
+
+
+=back
+
+For example, here is an implementation
+of the MATCH .. AGAINST syntax for MySQL
+
+ my $sqlmaker = SQL::Abstract->new(special_ops => [
+
+ # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
+ {regex => qr/^match$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg = [$arg] if not ref $arg;
+ my $label = $self->_quote($field);
+ my ($placeholder) = $self->_convert('?');
+ my $placeholders = join ", ", (($placeholder) x @$arg);
+ my $sql = $self->_sqlcase('match') . " ($label) "
+ . $self->_sqlcase('against') . " ($placeholders) ";
+ my @bind = $self->_bindtype($field, @$arg);
+ return ($sql, @bind);
+ }
+ },
+
+ ]);
+
+
+=head1 UNARY OPERATORS
+
+ my $sqlmaker = SQL::Abstract->new(unary_ops => [
+ {
+ regex => qr/.../,
+ handler => sub {
+ my ($self, $op, $arg) = @_;
+ ...
+ },
+ },
+ {
+ regex => qr/.../,
+ handler => 'method_name',
+ },
+ ]);
+
+A "unary operator" is a SQL syntactic clause that can be
+applied to a field - the operator goes before the field
+
+You can write your own operator handlers - supply a C<unary_ops>
+argument to the C<new> method. That argument takes an arrayref of
+operator definitions; each operator definition is a hashref with two
+entries:
+
+=over
+
+=item regex
+
+the regular expression to match the operator
+
+=item handler
+
+Either a coderef or a plain scalar method name. In both cases
+the expected return is C<< $sql >>.
+
+When supplied with a method name, it is simply called on the
+L<SQL::Abstract/> object as:
+
+ $self->$method_name ($op, $arg)
+
+ Where:
+
+ $op is the part that matched the handler regex
+ $arg is the RHS or argument of the operator
+
+When supplied with a coderef, it is called as:
+
+ $coderef->($self, $op, $arg)
+
+
+=back
+
+
=head1 PERFORMANCE
Thanks to some benchmarking by Mark Stosberg, it turns out that
around. On subsequent queries, simply use the C<values> function provided
by this module to return your values in the correct order.
+However this depends on the values having the same type - if, for
+example, the values of a where clause may either have values
+(resulting in sql of the form C<column = ?> with a single bind
+value), or alternatively the values might be C<undef> (resulting in
+sql of the form C<column IS NULL> with no bind value) then the
+caching technique suggested will not work.
+
=head1 FORMBUILDER
If you use my C<CGI::FormBuilder> module at all, you'll hopefully
#!/usr/bin/perl
+ use warnings;
+ use strict;
+
use CGI::FormBuilder;
use SQL::Abstract;
table, the actual query script can be extremely simplistic.
If you're B<REALLY> lazy (I am), check out C<HTML::QuickTable> for
-a fast interface to returning and formatting data. I frequently
+a fast interface to returning and formatting data. I frequently
use these three modules together to write complex database query
apps in under 50 lines.
-=head1 NOTES
+=head1 REPO
-There is not (yet) any explicit support for SQL compound logic
-statements like "AND NOT". Instead, just do the de Morgan's
-law transformations yourself. For example, this:
+=over
- "lname LIKE '%son%' AND NOT ( age < 10 OR age > 20 )"
+=item * gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
-Becomes:
+=item * git: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
- "lname LIKE '%son%' AND ( age >= 10 AND age <= 20 )"
+=back
-With the corresponding C<%where> hash:
+=head1 CHANGES
- %where = (
- lname => {like => '%son%'},
- age => [-and => {'>=', 10}, {'<=', 20}],
- );
+Version 1.50 was a major internal refactoring of C<SQL::Abstract>.
+Great care has been taken to preserve the I<published> behavior
+documented in previous versions in the 1.* family; however,
+some features that were previously undocumented, or behaved
+differently from the documentation, had to be changed in order
+to clarify the semantics. Hence, client code that was relying
+on some dark areas of C<SQL::Abstract> v1.*
+B<might behave differently> in v1.50.
+
+The main changes are :
+
+=over
+
+=item *
+
+support for literal SQL through the C<< \ [$sql, bind] >> syntax.
+
+=item *
+
+support for the { operator => \"..." } construct (to embed literal SQL)
+
+=item *
-Again, remember that the C<-and> goes I<inside> the arrayref.
+support for the { operator => \["...", @bind] } construct (to embed literal SQL with bind values)
+
+=item *
+
+optional support for L<array datatypes|/"Inserting and Updating Arrays">
+
+=item *
+
+defensive programming : check arguments
+
+=item *
+
+fixed bug with global logic, which was previously implemented
+through global variables yielding side-effects. Prior versions would
+interpret C<< [ {cond1, cond2}, [cond3, cond4] ] >>
+as C<< "(cond1 AND cond2) OR (cond3 AND cond4)" >>.
+Now this is interpreted
+as C<< "(cond1 AND cond2) OR (cond3 OR cond4)" >>.
+
+
+=item *
+
+fixed semantics of _bindtype on array args
+
+=item *
+
+dropped the C<_anoncopy> of the %where tree. No longer necessary,
+we just avoid shifting arrays within that tree.
+
+=item *
+
+dropped the C<_modlogic> function
+
+=back
=head1 ACKNOWLEDGEMENTS
this module. Unfortunately, most of them submitted bugs via CPAN
so I have no idea who they are! But the people I do know are:
+ Ash Berlin (order_by hash term support)
Matt Trout (DBIx::Class support)
Mark Stosberg (benchmarking)
Chas Owens (initial "IN" operator support)
Eric Kolve (hashref "AND" support)
Mike Fragassi (enhancements to "BETWEEN" and "LIKE")
Dan Kubb (support for "quote_char" and "name_sep")
- Guillermo Roditi (patch to cleanup "IN" and "BETWEEN")
+ Guillermo Roditi (patch to cleanup "IN" and "BETWEEN", fix and tests for _order_by)
+ 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")
Thanks!
=head1 SEE ALSO
-L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>
+L<DBIx::Class>, L<DBIx::Abstract>, L<CGI::FormBuilder>, L<HTML::QuickTable>.
=head1 AUTHOR
C<SQL::Abstract>, and as such list members there are very familiar with
how to create queries.
-This module is free software; you may copy this under the terms of
-the GNU General Public License, or the Artistic License, copies of
-which should have accompanied your Perl kit.
+=head1 LICENSE
+
+This module is free software; you may copy this under the same
+terms as perl itself (either the GNU General Public License or
+the Artistic License)
=cut
projects / dbsrgits/SQL-Abstract.git / blobdiff