X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=3adfc01b6dc5d72896c60106f24776e3cf080e79;hb=78536e8b84aa4fdab20f50fb2ca65d17319099af;hp=84499ec895f7f6553aec86c934dded6c11c8eb5f;hpb=0ca23f3b8e7614421c0ea9d2bf04bc060e7c7ec5;p=dbsrgits%2FSQL-Abstract.git diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index 84499ec..3adfc01 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -27,7 +27,7 @@ BEGIN { # GLOBALS #====================================================================== -our $VERSION = '1.79'; +our $VERSION = '1.81'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases @@ -78,11 +78,6 @@ sub puke (@) { sub is_literal_value ($) { ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ] : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ] - : ( - ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 - and - defined $_[0]->{-ident} and ! length ref $_[0]->{-ident} - ) ? [ $_[0]->{-ident} ] : undef; } @@ -232,7 +227,10 @@ sub insert { return wantarray ? ($sql, @bind) : $sql; } -sub _insert_returning { +# Used by DBIx::Class::SQLMaker->insert +sub _insert_returning { shift->_returning(@_) } + +sub _returning { my ($self, $options) = @_; my $f = $options->{returning}; @@ -353,10 +351,11 @@ sub _insert_values { sub update { - my $self = shift; - my $table = $self->_table(shift); - my $data = shift || return; - my $where = shift; + my $self = shift; + my $table = $self->_table(shift); + my $data = shift || return; + my $where = shift; + my $options = shift; # first build the 'SET' part of the sql statement my (@set, @all_bind); @@ -419,6 +418,12 @@ sub update { push @all_bind, @where_bind; } + if ($options->{returning}) { + my ($returning_sql, @returning_bind) = $self->_returning ($options); + $sql .= $returning_sql; + push @all_bind, @returning_bind; + } + return wantarray ? ($sql, @all_bind) : $sql; } @@ -605,7 +610,7 @@ sub _where_HASHREF { $s = "($s)" unless ( List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}} or - defined($self->{_nested_func_lhs}) && ($self->{_nested_func_lhs} eq $k) + ( defined $self->{_nested_func_lhs} and $self->{_nested_func_lhs} eq $k ) ); ($s, @b); } @@ -634,6 +639,11 @@ sub _where_HASHREF { sub _where_unary_op { my ($self, $op, $rhs) = @_; + # top level special ops are illegal in general + # this includes the -ident/-value ops (dual purpose unary and special) + puke "Illegal use of top-level '-$op'" + if ! defined $self->{_nested_func_lhs} and List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}}; + if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) { my $handler = $op_entry->{handler}; @@ -658,8 +668,8 @@ sub _where_unary_op { my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, { SCALAR => sub { - puke "Illegal use of top-level '$op'" - unless $self->{_nested_func_lhs}; + puke "Illegal use of top-level '-$op'" + unless defined $self->{_nested_func_lhs}; return ( $self->_convert('?'), @@ -791,7 +801,7 @@ sub _where_op_VALUE { # special-case NULL if (! defined $rhs) { - return $lhs + return defined $lhs ? $self->_convert($self->_quote($lhs)) . ' IS NULL' : undef ; @@ -799,7 +809,7 @@ sub _where_op_VALUE { my @bind = $self->_bindtype ( - ($lhs || $self->{_nested_func_lhs}), + ( defined $lhs ? $lhs : $self->{_nested_func_lhs} ), $rhs, ) ; @@ -850,7 +860,10 @@ sub _where_hashpair_HASHREF { my ($self, $k, $v, $logic) = @_; $logic ||= 'and'; - local $self->{_nested_func_lhs} = $self->{_nested_func_lhs}; + local $self->{_nested_func_lhs} = defined $self->{_nested_func_lhs} + ? $self->{_nested_func_lhs} + : $k + ; my ($all_sql, @all_bind); @@ -929,10 +942,6 @@ sub _where_hashpair_HASHREF { }, 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 (' ', @@ -1128,7 +1137,6 @@ sub _where_field_BETWEEN { 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 { @@ -1186,7 +1194,6 @@ sub _where_field_IN { 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 { @@ -1245,8 +1252,29 @@ sub _where_field_IN { # adding them back in the corresponding method sub _open_outer_paren { my ($self, $sql) = @_; - $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs; - return $sql; + + while ( my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs ) { + + # there are closing parens inside, need the heavy duty machinery + # to reevaluate the extraction starting from $sql (full reevaluation) + if ( $inner =~ /\)/ ) { + require Text::Balanced; + + my (undef, $remainder) = do { + # idiotic design - writes to $@ but *DOES NOT* throw exceptions + local $@; + Text::Balanced::extract_bracketed( $sql, '()', qr/\s*/ ); + }; + + # the entire expression needs to be a balanced bracketed thing + # (after an extract no remainder sans trailing space) + last if defined $remainder and $remainder =~ /\S/; + } + + $sql = $inner; + } + + $sql; } @@ -1966,7 +1994,7 @@ words in your database's SQL dialect. This is the character that will be used to escape Ls appearing in an identifier before it has been quoted. -The paramter default in case of a single L character is the quote +The parameter default in case of a single L character is the quote character itself. When opening-closing-style quoting is used (L is an arrayref) @@ -2052,7 +2080,7 @@ be supported by all database engines. =back -=head2 update($table, \%fieldvals, \%where) +=head2 update($table, \%fieldvals, \%where, \%options) This takes a table, hashref of field/value pairs, and an optional hashref L. It returns an SQL UPDATE function and a list @@ -2061,6 +2089,19 @@ See the sections on L and L for information on how to insert with those data types. +The optional C<\%options> hash reference may contain additional +options to generate the update SQL. Currently supported options +are: + +=over 4 + +=item returning + +See the C option to +L. + +=back + =head2 select($source, $fields, $where, $order) This returns a SQL SELECT statement and associated list of bind values, as @@ -2233,8 +2274,6 @@ module: =item * C<\[ $sql_string, @bind_values ]> -=item * C<< { -ident => $plain_defined_string } >> - =back On failure returns C, on sucess returns an B reference @@ -2607,10 +2646,16 @@ 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 - {col => [-and => {-like => 'foo%'}, {-like => '%bar'}]} + { col => [ -and => + { -like => 'foo%' }, + { -like => '%bar' }, + ] } # yields : WHERE ( ( col LIKE ? AND col LIKE ? ) ) - [-and => {col => {-like => 'foo%'}, {col => {-like => '%bar'}}]] + [ -and => + { col => { -like => 'foo%' } }, + { col => { -like => '%bar' } }, + ] # yields : WHERE ( ( col LIKE ? OR col LIKE ? ) )