use Carp;
use strict;
use warnings;
-use List::Util qw/first/;
-use Scalar::Util qw/blessed/;
+use List::Util ();
+use Scalar::Util ();
#======================================================================
# GLOBALS
#======================================================================
-our $VERSION = '1.60';
+our $VERSION = '1.61_01';
# This would confuse some packagers
#$VERSION = eval $VERSION; # numify for warning-free dev releases
# default comparison is "=", but can be overridden
$opt{cmp} ||= '=';
+ # generic SQL comparison operators
+ my $anchored_cmp_ops = join ('|', map { '^' . $_ . '$' } (
+ '(?:is \s+)? (?:not \s+)? like',
+ 'is',
+ (map { quotemeta($_) } (qw/ < > != <> = <= >= /) ),
+ ));
+ $opt{cmp_ops} = qr/$anchored_cmp_ops/ix;
+
# try to recognize which are the 'equality' and 'unequality' ops
# (temporary quickfix, should go through a more seasoned API)
- $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
- $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
+ $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
+ $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
# SQL booleans
$opt{sqltrue} ||= '1=1';
#======================================================================
sub insert {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
+ 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);
+ my ($sql, @bind) = $self->$method($data);
$sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
+
+ if (my $ret = $options->{returning}) {
+ $sql .= $self->_insert_returning ($ret);
+ }
+
return wantarray ? ($sql, @bind) : $sql;
}
+sub _insert_returning {
+ my ($self, $fields) = @_;
+
+ my $f = $self->_SWITCH_refkind($fields, {
+ ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$fields;},
+ SCALAR => sub {$self->_quote($fields)},
+ SCALARREF => sub {$$fields},
+ });
+ return join (' ', $self->_sqlcase(' returning'), $f);
+}
+
sub _insert_HASHREF { # explicit list of fields and then values
my ($self, $data) = @_;
my ($self, $where) = @_;
my (@sql_clauses, @all_bind);
- for my $k (sort keys %$where) {
+ for my $k (sort keys %$where) {
my $v = $where->{$k};
- # ($k => $v) is either a special op or a regular hashpair
- my ($sql, @bind) = ($k =~ /^(-.+)/) ? $self->_where_op_in_hash($1, $v)
- : do {
- my $method = $self->_METHOD_FOR_refkind("_where_hashpair", $v);
- $self->$method($k, $v);
- };
+ # ($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 =~ s/^-//; # remove initial dash
+ $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
+ $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
+
+ $self->_debug("Unary OP(-$op) within hashref, recursing...");
+
+ my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}};
+ if (my $handler = $op_entry->{handler}) {
+ if (not ref $handler) {
+ if ($op =~ s/\s?\d+$//) {
+ belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
+ . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
+ }
+ $self->$handler ($op, $v);
+ }
+ elsif (ref $handler eq 'CODE') {
+ $handler->($self, $op, $v);
+ }
+ else {
+ puke "Illegal handler for operator $k - expecting a method name or a coderef";
+ }
+ }
+ else {
+ $self->debug("Generic unary OP: $k - recursing as function");
+ $self->_where_func_generic ($op, $v);
+ }
+ }
+ 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_func_generic {
+ my ($self, $op, $rhs) = @_;
-sub _where_op_in_hash {
- my ($self, $orig_op, $v) = @_;
+ my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
+ SCALAR => sub {
+ puke "Illegal use of top-level '$op'"
+ unless $self->{_nested_func_lhs};
- # put the operator in canonical form
- my $op = $orig_op;
- $op =~ s/^-//; # remove initial dash
- $op =~ s/[_\t ]+/ /g; # underscores and whitespace become single spaces
- $op =~ s/^\s+|\s+$//g;# remove leading/trailing space
+ return (
+ $self->_convert('?'),
+ $self->_bindtype($self->{_nested_func_lhs}, $rhs)
+ );
+ },
+ FALLBACK => sub {
+ $self->_recurse_where ($rhs)
+ },
+ });
- $self->_debug("OP(-$op) within hashref, recursing...");
+ $sql = sprintf ('%s%s',
+ $self->_sqlcase($op),
+ ($op =~ $self->{cmp_ops}) ? " $sql" : "( $sql )",
+ );
- my $op_entry = first {$op =~ $_->{regex}} @{$self->{unary_ops}};
- my $handler = $op_entry->{handler};
- if (! $handler) {
- puke "unknown operator: $orig_op";
- }
- elsif (not ref $handler) {
- if ($op =~ s/\s?\d+$//) {
- belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. '
- . "You probably wanted ...-and => [ -$op => COND1, -$op => COND2 ... ]";
- }
- return $self->$handler ($op, $v);
- }
- elsif (ref $handler eq 'CODE') {
- return $handler->($self, $op, $v);
- }
- else {
- puke "Illegal handler for operator $orig_op - expecting a method name or a coderef";
- }
+ return ($sql, @bind);
}
sub _where_op_ANDOR {
- my ($self, $op, $v) = @_;
+ my ($self, $op, $v) = @_;
$self->_SWITCH_refkind($v, {
ARRAYREF => sub {
$self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- return $self->_where_ARRAYREF($v, '');
- },
-
- HASHREF => sub {
- return $self->_where_HASHREF($v);
- },
-
- SCALARREF => sub { # literal SQL
- return ($$v);
- },
-
- ARRAYREFREF => sub { # literal SQL
- return @{${$v}};
- },
-
SCALAR => sub { # permissively interpreted as SQL
belch "literal SQL should be -nest => \\'scalar' "
. "instead of -nest => 'scalar' ";
UNDEF => sub {
puke "-$op => undef not supported";
},
+
+ FALLBACK => sub {
+ $self->_recurse_where ($v);
+ },
+
});
}
my ( $prefix, $suffix ) = ( $op =~ /\bnot\b/i )
? ( '(NOT ', ')' )
: ( '', '' );
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- my ( $sql, @bind ) = $self->_where_ARRAYREF($v, '');
- return ( ($prefix . $sql . $suffix), @bind );
- },
-
- ARRAYREFREF => sub {
- my ( $sql, @bind ) = @{ ${$v} };
- return ( ($prefix . $sql . $suffix), @bind );
- },
- HASHREF => sub {
- my ( $sql, @bind ) = $self->_where_HASHREF($v);
- return ( ($prefix . $sql . $suffix), @bind );
- },
+ my ($sql, @bind) = do {
+ $self->_SWITCH_refkind($v, {
+ SCALAR => sub { # interpreted as SQL column
+ $self->_convert($self->_quote($v));
+ },
- SCALARREF => sub { # literal SQL
- return ($prefix . $$v . $suffix);
- },
+ UNDEF => sub {
+ puke "-$op => undef not supported";
+ },
- SCALAR => sub { # interpreted as SQL column
- return ($prefix . $self->_convert($self->_quote($v)) . $suffix);
- },
+ FALLBACK => sub {
+ $self->_recurse_where ($v);
+ },
+ });
+ };
- UNDEF => sub {
- puke "-$op => undef not supported";
- },
- });
+ return (
+ join ('', $prefix, $sql, $suffix),
+ @bind,
+ );
}
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 ($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
- my $special_op = first {$op =~ $_->{regex}} @{$self->{special_ops}};
- if ($special_op) {
+ 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";
($sql, @bind) = $self->_where_field_op_ARRAYREF($k, $op, $val);
},
- SCALARREF => sub { # CASE: col => {op => \$scalar} (literal SQL without bind)
- $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($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);
@bind = @sub_bind;
},
- HASHREF => sub {
- ($sql, @bind) = $self->_where_hashpair_HASHREF($k, $val, $op);
- },
-
UNDEF => sub { # CASE: col => {op => undef} : sql "IS (NOT)? NULL"
my $is = ($op =~ $self->{equality_op}) ? 'is' :
($op =~ $self->{inequality_op}) ? 'is not' :
$sql = $self->_quote($k) . $self->_sqlcase(" $is null");
},
- FALLBACK => sub { # CASE: col => {op => $scalar}
- $sql = join ' ', $self->_convert($self->_quote($k)),
- $self->_sqlcase($op),
- $self->_convert('?');
- @bind = $self->_bindtype($k, $val);
+ FALLBACK => sub { # CASE: col => {op/func => $stuff}
+
+ # if we are starting to nest and the first func is not a cmp op
+ # assume equality
+ my $prefix;
+ unless ($self->{_nested_func_lhs}) {
+ $self->{_nested_func_lhs} = $k;
+ $prefix = $self->{cmp} unless $op =~ $self->{cmp_ops};
+ }
+
+ ($sql, @bind) = $self->_where_func_generic ($op, $val);
+ $sql = join ' ', $self->_convert($self->_quote($k)), $prefix||(), $sql;
},
});
}
# adding them back in the corresponding method
sub _open_outer_paren {
my ($self, $sql) = @_;
- $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/x;
+ $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
return $sql;
}
while (1) {
# blessed objects are treated like scalars
- $ref = (blessed $data) ? '' : ref $data;
+ $ref = (Scalar::Util::blessed $data) ? '' : ref $data;
$n_steps += 1 if $ref;
last if $ref ne 'REF';
$data = $$data;
sub _METHOD_FOR_refkind {
my ($self, $meth_prefix, $data) = @_;
- my $method = first {$_} map {$self->can($meth_prefix."_".$_)}
- $self->_try_refkind($data)
- or puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data);
- return $method;
+
+ 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 = first {$_} map {$dispatch_table->{$_}}
- $self->_try_refkind($data)
- or puke "no dispatch entry for ".$self->_refkind($data);
+ my $coderef;
+ for ($self->_try_refkind($data)) {
+ $coderef = $dispatch_table->{$_}
+ and last;
+ }
+
+ puke "no dispatch entry for ".$self->_refkind($data)
+ unless $coderef;
+
$coderef->();
}
=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.
L</"Inserting and Updating SQL"> for information on how to insert
with those data types.
+The optional C<\%options> hash reference may contain additional
+options to generate the insert SQL. Currently supported options
+are:
+
+=over 4
+
+=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
Laurent Dami (internal refactoring, multiple -nest, 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 LICENSE
-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.
+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 / scpubgit/Q-Branch.git / blobdiff