3932 lines
110 KiB
Perl
3932 lines
110 KiB
Perl
package SQL::Abstract; # see doc at end of file
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Carp ();
|
|
use List::Util ();
|
|
use Scalar::Util ();
|
|
|
|
use Exporter 'import';
|
|
our @EXPORT_OK = qw(is_plain_value is_literal_value is_undef_value);
|
|
|
|
BEGIN {
|
|
if ($] < 5.009_005) {
|
|
require MRO::Compat;
|
|
}
|
|
else {
|
|
require mro;
|
|
}
|
|
|
|
*SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}
|
|
? sub () { 0 }
|
|
: sub () { 1 }
|
|
;
|
|
}
|
|
|
|
#======================================================================
|
|
# GLOBALS
|
|
#======================================================================
|
|
|
|
our $VERSION = '2.000001';
|
|
|
|
# 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 => sub { die "NOPE" }},
|
|
{regex => qr/^ is (?: \s+ not )? $/ix, handler => sub { die "NOPE" }},
|
|
{regex => qr/^ (?: not \s )? in $/ix, handler => sub { die "NOPE" }},
|
|
{regex => qr/^ ident $/ix, handler => sub { die "NOPE" }},
|
|
{regex => qr/^ value $/ix, handler => sub { die "NOPE" }},
|
|
);
|
|
|
|
#======================================================================
|
|
# 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: ", @_;
|
|
}
|
|
|
|
sub is_literal_value ($) {
|
|
ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ]
|
|
: ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ]
|
|
: undef;
|
|
}
|
|
|
|
sub is_undef_value ($) {
|
|
!defined($_[0])
|
|
or (
|
|
ref($_[0]) eq 'HASH'
|
|
and exists $_[0]->{-value}
|
|
and not defined $_[0]->{-value}
|
|
);
|
|
}
|
|
|
|
# FIXME XSify - this can be done so much more efficiently
|
|
sub is_plain_value ($) {
|
|
no strict 'refs';
|
|
! length ref $_[0] ? \($_[0])
|
|
: (
|
|
ref $_[0] eq 'HASH' and keys %{$_[0]} == 1
|
|
and
|
|
exists $_[0]->{-value}
|
|
) ? \($_[0]->{-value})
|
|
: (
|
|
# reuse @_ for even moar speedz
|
|
defined ( $_[1] = Scalar::Util::blessed $_[0] )
|
|
and
|
|
# deliberately not using Devel::OverloadInfo - the checks we are
|
|
# intersted in are much more limited than the fullblown thing, and
|
|
# this is a very hot piece of code
|
|
(
|
|
# simply using ->can('(""') can leave behind stub methods that
|
|
# break actually using the overload later (see L<perldiag/Stub
|
|
# found while resolving method "%s" overloading "%s" in package
|
|
# "%s"> and the source of overload::mycan())
|
|
#
|
|
# either has stringification which DBI SHOULD prefer out of the box
|
|
grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) }
|
|
or
|
|
# has nummification or boolification, AND fallback is *not* disabled
|
|
(
|
|
SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION
|
|
and
|
|
(
|
|
grep { *{"${_}::(0+"}{CODE} } @{$_[2]}
|
|
or
|
|
grep { *{"${_}::(bool"}{CODE} } @{$_[2]}
|
|
)
|
|
and
|
|
(
|
|
# no fallback specified at all
|
|
! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} )
|
|
or
|
|
# fallback explicitly undef
|
|
! defined ${"$_[3]::()"}
|
|
or
|
|
# explicitly true
|
|
!! ${"$_[3]::()"}
|
|
)
|
|
)
|
|
)
|
|
) ? \($_[0])
|
|
: undef;
|
|
}
|
|
|
|
|
|
|
|
#======================================================================
|
|
# NEW
|
|
#======================================================================
|
|
|
|
our %Defaults = (
|
|
expand => {
|
|
bool => '_expand_bool',
|
|
row => '_expand_row',
|
|
op => '_expand_op',
|
|
func => '_expand_func',
|
|
values => '_expand_values',
|
|
list => '_expand_list',
|
|
},
|
|
expand_op => {
|
|
(map +($_ => __PACKAGE__->make_binop_expander('_expand_between')),
|
|
qw(between not_between)),
|
|
(map +($_ => __PACKAGE__->make_binop_expander('_expand_in')),
|
|
qw(in not_in)),
|
|
(map +($_ => '_expand_op_andor'), ('and', 'or')),
|
|
(map +($_ => '_expand_op_is'), ('is', 'is_not')),
|
|
(map +($_ => __PACKAGE__->make_unop_expander("_expand_${_}")),
|
|
qw(ident value nest)),
|
|
bind => __PACKAGE__->make_unop_expander(sub { +{ -bind => $_[2] } }),
|
|
},
|
|
render => {
|
|
(map +($_, "_render_$_"),
|
|
qw(op func bind ident literal row values keyword)),
|
|
},
|
|
render_op => {
|
|
(map +($_ => '_render_op_between'), 'between', 'not_between'),
|
|
(map +($_ => '_render_op_in'), 'in', 'not_in'),
|
|
(map +($_ => '_render_unop_postfix'),
|
|
'is_null', 'is_not_null', 'asc', 'desc',
|
|
),
|
|
(not => '_render_unop_paren'),
|
|
(map +($_ => '_render_op_andor'), qw(and or)),
|
|
',' => '_render_op_multop',
|
|
},
|
|
clauses_of => {
|
|
delete => [ qw(target where returning) ],
|
|
update => [ qw(target set where returning) ],
|
|
insert => [ qw(target fields from returning) ],
|
|
select => [ qw(select from where order_by) ],
|
|
},
|
|
expand_clause => {
|
|
'delete.from' => '_expand_delete_clause_target',
|
|
'update.update' => '_expand_update_clause_target',
|
|
'insert.into' => '_expand_insert_clause_target',
|
|
'insert.values' => '_expand_insert_clause_from',
|
|
},
|
|
render_clause => {
|
|
'delete.target' => '_render_delete_clause_target',
|
|
'update.target' => '_render_update_clause_target',
|
|
'insert.target' => '_render_insert_clause_target',
|
|
'insert.fields' => '_render_insert_clause_fields',
|
|
'insert.from' => '_render_insert_clause_from',
|
|
},
|
|
);
|
|
|
|
foreach my $stmt (keys %{$Defaults{clauses_of}}) {
|
|
$Defaults{expand}{$stmt} = '_expand_statement';
|
|
$Defaults{render}{$stmt} = '_render_statement';
|
|
foreach my $clause (@{$Defaults{clauses_of}{$stmt}}) {
|
|
$Defaults{expand_clause}{"${stmt}.${clause}"}
|
|
= "_expand_${stmt}_clause_${clause}";
|
|
}
|
|
}
|
|
|
|
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_)?r?like $/xi;
|
|
$opt{not_like_op} = qr/^ (is_)?not_r?like $/xi;
|
|
|
|
# SQL booleans
|
|
$opt{sqltrue} ||= '1=1';
|
|
$opt{sqlfalse} ||= '0=1';
|
|
|
|
# special operators
|
|
$opt{special_ops} ||= [];
|
|
|
|
# unary operators
|
|
$opt{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;
|
|
|
|
$opt{expand_unary} = {};
|
|
|
|
foreach my $name (sort keys %Defaults) {
|
|
$opt{$name} = { %{$Defaults{$name}}, %{$opt{$name}||{}} };
|
|
}
|
|
|
|
if ($class ne __PACKAGE__) {
|
|
|
|
# check for overriden methods
|
|
|
|
foreach my $type (qw(insert update delete)) {
|
|
my $method = "_${type}_returning";
|
|
if (__PACKAGE__->can($method) ne $class->can($method)) {
|
|
my $clause = "${type}.returning";
|
|
$opt{expand_clause}{$clause} = sub { $_[2] },
|
|
$opt{render_clause}{$clause}
|
|
= sub { [ $_[0]->$method($_[3]) ] };
|
|
}
|
|
}
|
|
if (__PACKAGE__->can('_table') ne $class->can('_table')) {
|
|
$opt{expand_clause}{'select.from'} = sub {
|
|
return +{ -literal => [ $_[0]->_table($_[2]) ] };
|
|
};
|
|
}
|
|
if (__PACKAGE__->can('_order_by') ne $class->can('_order_by')) {
|
|
$opt{expand_clause}{'select.order_by'} = sub { $_[2] };
|
|
$opt{render_clause}{'select.order_by'} = sub {
|
|
[ $_[0]->_order_by($_[2]) ];
|
|
};
|
|
}
|
|
if (__PACKAGE__->can('_select_fields') ne $class->can('_select_fields')) {
|
|
$opt{expand_clause}{'select.select'} = sub { $_[2] };
|
|
$opt{render_clause}{'select.select'} = sub {
|
|
my @super = $_[0]->_select_fields($_[2]);
|
|
my $effort = [
|
|
ref($super[0]) eq 'HASH'
|
|
? $_[0]->render_expr($super[0])
|
|
: @super
|
|
];
|
|
return $_[0]->join_query_parts(
|
|
' ', { -keyword => 'select' }, $effort
|
|
);
|
|
};
|
|
}
|
|
foreach my $type (qw(in between)) {
|
|
my $meth = "_where_field_".uc($type);
|
|
if (__PACKAGE__->can($meth) ne $class->can($meth)) {
|
|
my $exp = sub {
|
|
my ($self, $op, $v, $k) = @_;
|
|
$op = join ' ', split '_', $op;
|
|
return +{ -literal => [
|
|
$self->$meth($k, $op, $v)
|
|
] };
|
|
};
|
|
$opt{expand_op}{$_} = $exp for $type, "not_${type}";
|
|
}
|
|
}
|
|
if ($class->isa('DBIx::Class::SQLMaker')) {
|
|
$opt{warn_once_on_nest} = 1;
|
|
$opt{disable_old_special_ops} = 1;
|
|
$opt{render_clause}{'select.where'} = sub {
|
|
my ($sql, @bind) = $_[0]->where($_[2]);
|
|
s/\A\s+//, s/\s+\Z// for $sql;
|
|
return [ $sql, @bind ];
|
|
};
|
|
$opt{expand_op}{ident} = $class->make_unop_expander(sub {
|
|
my ($self, undef, $body) = @_;
|
|
$body = $body->from if Scalar::Util::blessed($body);
|
|
$self->_expand_ident(ident => $body);
|
|
});
|
|
}
|
|
if ($class->isa('SQL::Abstract::More')) {
|
|
my $orig = $opt{expand_op}{or};
|
|
$opt{expand_op}{or} = sub {
|
|
my ($self, $logop, $v, $k) = @_;
|
|
if ($k and ref($v) eq 'ARRAY') {
|
|
my ($type, $val) = @$v;
|
|
my $op;
|
|
if (
|
|
ref($type) eq 'HASH' and ref($val) eq 'HASH'
|
|
and keys %$type == 1 and keys %$val == 1
|
|
and (keys %$type)[0] eq (keys %$val)[0]
|
|
) {
|
|
($op) = keys %$type;
|
|
($type) = values %$type;
|
|
($val) = values %$val;
|
|
}
|
|
if ($self->is_bind_value_with_type(my $v = [ $type, $val ])) {
|
|
return $self->expand_expr(
|
|
{ $k, map +($op ? { $op => $_ } : $_), { -bind => $v } }
|
|
);
|
|
}
|
|
}
|
|
return $self->$orig($logop, $v, $k);
|
|
};
|
|
$opt{render}{bind} = sub {
|
|
return [ '?', map +(ref($_->[0]) ? $_ : $_->[1]), $_[2] ]
|
|
};
|
|
}
|
|
}
|
|
|
|
if ($opt{lazy_join_sql_parts}) {
|
|
require SQL::Abstract::Parts;
|
|
$opt{join_sql_parts} ||= sub { SQL::Abstract::Parts->new(@_) };
|
|
}
|
|
|
|
$opt{join_sql_parts} ||= sub { join $_[0], @_[1..$#_] };
|
|
|
|
return bless \%opt, $class;
|
|
}
|
|
|
|
sub _ext_rw {
|
|
my ($self, $name, $key, $value) = @_;
|
|
return $self->{$name}{$key} unless @_ > 3;
|
|
$self->{$name}{$key} = $value;
|
|
return $self;
|
|
}
|
|
|
|
sub make_unop_expander {
|
|
my (undef, $exp) = @_;
|
|
sub {
|
|
my ($self, $name, $body, $k) = @_;
|
|
return $self->_expand_hashpair_cmp($k, { "-${name}" => $body })
|
|
if defined($k);
|
|
return $self->$exp($name, $body);
|
|
}
|
|
}
|
|
|
|
sub make_binop_expander {
|
|
my (undef, $exp) = @_;
|
|
sub {
|
|
my ($self, $name, $body, $k) = @_;
|
|
$k = shift @{$body = [ @$body ]} unless defined $k;
|
|
$k = ref($k) ? $k : { -ident => $k };
|
|
return $self->$exp($name, $body, $k);
|
|
}
|
|
}
|
|
|
|
sub plugin {
|
|
my ($self, $plugin, @args) = @_;
|
|
unless (ref $plugin) {
|
|
$plugin =~ s/\A\+/${\__PACKAGE__}::Plugin::/;
|
|
require(join('/', split '::', $plugin).'.pm');
|
|
}
|
|
$plugin->apply_to($self, @args);
|
|
return $self;
|
|
}
|
|
|
|
BEGIN {
|
|
foreach my $type (qw(
|
|
expand op_expand render op_render clause_expand clause_render
|
|
)) {
|
|
my $name = join '_', reverse split '_', $type;
|
|
my $singular = "${type}er";
|
|
|
|
eval qq{sub ${singular} {
|
|
my \$self = shift;
|
|
return \$self->_ext_rw('${name}', \@_) if \@_ == 1;
|
|
return \$self->${singular}s(\@_)
|
|
}; 1 } or die "Method builder failed for ${singular}: $@";
|
|
eval qq{sub wrap_${singular} {
|
|
shift->wrap_${singular}s(\@_)
|
|
}; 1 } or die "Method builder failed for wrap_${singular}: $@";
|
|
|
|
eval qq{sub ${singular}s {
|
|
my (\$self, \@args) = \@_;
|
|
while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) {
|
|
\$self->_ext_rw('${name}', \$this_key, \$this_value);
|
|
}
|
|
return \$self;
|
|
}; 1 } or die "Method builder failed for ${singular}s: $@";
|
|
eval qq{sub wrap_${singular}s {
|
|
my (\$self, \@args) = \@_;
|
|
while (my (\$this_key, \$this_builder) = splice(\@args, 0, 2)) {
|
|
my \$orig = \$self->_ext_rw('${name}', \$this_key);
|
|
\$self->_ext_rw(
|
|
'${name}', \$this_key,
|
|
\$this_builder->(\$orig, '${name}', \$this_key),
|
|
);
|
|
}
|
|
return \$self;
|
|
}; 1 } or die "Method builder failed for wrap_${singular}s: $@";
|
|
eval qq{sub ${singular}_list { sort keys %{\$_[0]->{\$name}} }; 1; }
|
|
or die "Method builder failed for ${singular}_list: $@";
|
|
}
|
|
foreach my $singular (qw(unop_expander binop_expander)) {
|
|
eval qq{sub ${singular} { shift->${singular}s(\@_) }; 1 }
|
|
or die "Method builder failed for ${singular}: $@";
|
|
eval qq{sub ${singular}s {
|
|
my (\$self, \@args) = \@_;
|
|
while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) {
|
|
\$self->_ext_rw(
|
|
expand_op => \$this_key,
|
|
\$self->make_${singular}(\$this_value),
|
|
);
|
|
}
|
|
return \$self;
|
|
}; 1 } or die "Method builder failed for ${singular}s: $@";
|
|
}
|
|
}
|
|
|
|
#sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] }
|
|
|
|
sub statement_list { sort keys %{$_[0]->{clauses_of}} }
|
|
|
|
sub clauses_of {
|
|
my ($self, $of, @clauses) = @_;
|
|
unless (@clauses) {
|
|
return @{$self->{clauses_of}{$of}||[]};
|
|
}
|
|
if (ref($clauses[0]) eq 'CODE') {
|
|
@clauses = $self->${\($clauses[0])}(@{$self->{clauses_of}{$of}||[]});
|
|
}
|
|
$self->{clauses_of}{$of} = \@clauses;
|
|
return $self;
|
|
}
|
|
|
|
sub clone {
|
|
my ($self) = @_;
|
|
bless(
|
|
{
|
|
(map +($_ => (
|
|
ref($self->{$_}) eq 'HASH'
|
|
? { %{$self->{$_}} }
|
|
: $self->{$_}
|
|
)), keys %$self),
|
|
},
|
|
ref($self)
|
|
);
|
|
}
|
|
|
|
sub sqltrue { +{ -literal => [ $_[0]->{sqltrue} ] } }
|
|
sub sqlfalse { +{ -literal => [ $_[0]->{sqlfalse} ] } }
|
|
|
|
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, $table, $data, $options) = @_;
|
|
|
|
my $stmt = do {
|
|
if (ref($table) eq 'HASH') {
|
|
$table;
|
|
} else {
|
|
my %clauses = (target => $table, values => $data, %{$options||{}});
|
|
\%clauses;
|
|
}
|
|
};
|
|
my @rendered = $self->render_statement({ -insert => $stmt });
|
|
return wantarray ? @rendered : $rendered[0];
|
|
}
|
|
|
|
sub _expand_insert_clause_target {
|
|
+(target => $_[0]->expand_expr($_[2], -ident));
|
|
}
|
|
|
|
sub _expand_insert_clause_fields {
|
|
return +{ -row => [
|
|
$_[0]->expand_expr({ -list => $_[2] }, -ident)
|
|
] } if ref($_[2]) eq 'ARRAY';
|
|
return $_[2]; # should maybe still expand somewhat?
|
|
}
|
|
|
|
sub _expand_insert_clause_from {
|
|
my ($self, undef, $data) = @_;
|
|
if (ref($data) eq 'HASH' and (keys(%$data))[0] =~ /^-/) {
|
|
return $self->expand_expr($data);
|
|
}
|
|
my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data);
|
|
return (
|
|
from => { -values => [ $v_aqt ] },
|
|
($f_aqt ? (fields => $f_aqt) : ()),
|
|
);
|
|
}
|
|
|
|
sub _expand_insert_clause_returning {
|
|
+(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident));
|
|
}
|
|
|
|
sub _expand_insert_values {
|
|
my ($self, $data) = @_;
|
|
if (is_literal_value($data)) {
|
|
(undef, $self->expand_expr($data));
|
|
} else {
|
|
my ($fields, $values) = (
|
|
ref($data) eq 'HASH' ?
|
|
([ sort keys %$data ], [ @{$data}{sort keys %$data} ])
|
|
: ([], $data)
|
|
);
|
|
|
|
# no names (arrayref) means can't generate bindtype
|
|
!($fields) && $self->{bindtype} eq 'columns'
|
|
&& belch "can't do 'columns' bindtype when called with arrayref";
|
|
|
|
+(
|
|
(@$fields
|
|
? $self->expand_expr({ -row => $fields }, -ident)
|
|
: undef
|
|
),
|
|
+{ -row => [
|
|
map {
|
|
local our $Cur_Col_Meta = $fields->[$_];
|
|
$self->_expand_insert_value($values->[$_])
|
|
} 0..$#$values
|
|
] },
|
|
);
|
|
}
|
|
}
|
|
|
|
sub _render_insert_clause_fields {
|
|
return $_[0]->render_aqt($_[2]);
|
|
}
|
|
|
|
sub _render_insert_clause_target {
|
|
my ($self, undef, $from) = @_;
|
|
$self->join_query_parts(' ', { -keyword => 'insert into' }, $from);
|
|
}
|
|
|
|
sub _render_insert_clause_from {
|
|
return $_[0]->render_aqt($_[2], 1);
|
|
}
|
|
|
|
# So that subclasses can override INSERT ... RETURNING separately from
|
|
# UPDATE and DELETE (e.g. DBIx::Class::SQLMaker::Oracle does this)
|
|
sub _insert_returning { shift->_returning(@_) }
|
|
|
|
sub _redispatch_returning {
|
|
my ($self, $type, undef, $returning) = @_;
|
|
[ $self->${\"_${type}_returning"}({ returning => $returning }) ];
|
|
}
|
|
|
|
sub _returning {
|
|
my ($self, $options) = @_;
|
|
|
|
my $f = $options->{returning};
|
|
|
|
my ($sql, @bind) = @{ $self->render_aqt(
|
|
$self->expand_expr({ -list => $f }, -ident)
|
|
) };
|
|
my $rsql = $self->_sqlcase(' returning ').$sql;
|
|
return wantarray ? ($rsql, @bind) : $rsql;
|
|
}
|
|
|
|
sub _expand_insert_value {
|
|
my ($self, $v) = @_;
|
|
|
|
my $k = our $Cur_Col_Meta;
|
|
|
|
if (ref($v) eq 'ARRAY') {
|
|
if ($self->{array_datatypes}) {
|
|
return +{ -bind => [ $k, $v ] };
|
|
}
|
|
my ($sql, @bind) = @$v;
|
|
$self->_assert_bindval_matches_bindtype(@bind);
|
|
return +{ -literal => $v };
|
|
}
|
|
if (ref($v) eq 'HASH') {
|
|
if (grep !/^-/, keys %$v) {
|
|
belch "HASH ref as bind value in insert is not supported";
|
|
return +{ -bind => [ $k, $v ] };
|
|
}
|
|
}
|
|
if (!defined($v)) {
|
|
return +{ -bind => [ $k, undef ] };
|
|
}
|
|
return $self->expand_expr($v);
|
|
}
|
|
|
|
|
|
|
|
#======================================================================
|
|
# UPDATE methods
|
|
#======================================================================
|
|
|
|
sub update {
|
|
my ($self, $table, $set, $where, $options) = @_;
|
|
|
|
my $stmt = do {
|
|
if (ref($table) eq 'HASH') {
|
|
$table
|
|
} else {
|
|
my %clauses;
|
|
@clauses{qw(target set where)} = ($table, $set, $where);
|
|
puke "Unsupported data type specified to \$sql->update"
|
|
unless ref($clauses{set}) eq 'HASH';
|
|
@clauses{keys %$options} = values %$options;
|
|
\%clauses;
|
|
}
|
|
};
|
|
my @rendered = $self->render_statement({ -update => $stmt });
|
|
return wantarray ? @rendered : $rendered[0];
|
|
}
|
|
|
|
sub _render_update_clause_target {
|
|
my ($self, undef, $target) = @_;
|
|
$self->join_query_parts(' ', { -keyword => 'update' }, $target);
|
|
}
|
|
|
|
sub _update_set_values {
|
|
my ($self, $data) = @_;
|
|
|
|
return @{ $self->render_aqt(
|
|
$self->_expand_update_set_values(undef, $data),
|
|
) };
|
|
}
|
|
|
|
sub _expand_update_set_values {
|
|
my ($self, undef, $data) = @_;
|
|
$self->expand_expr({ -list => [
|
|
map {
|
|
my ($k, $set) = @$_;
|
|
$set = { -bind => $_ } unless defined $set;
|
|
+{ -op => [ '=', { -ident => $k }, $set ] };
|
|
}
|
|
map {
|
|
my $k = $_;
|
|
my $v = $data->{$k};
|
|
(ref($v) eq 'ARRAY'
|
|
? ($self->{array_datatypes}
|
|
? [ $k, +{ -bind => [ $k, $v ] } ]
|
|
: [ $k, +{ -literal => $v } ])
|
|
: do {
|
|
local our $Cur_Col_Meta = $k;
|
|
[ $k, $self->_expand_expr($v) ]
|
|
}
|
|
);
|
|
} sort keys %$data
|
|
] });
|
|
}
|
|
|
|
sub _expand_update_clause_target {
|
|
my ($self, undef, $target) = @_;
|
|
+(target => $self->expand_expr({ -list => $target }, -ident));
|
|
}
|
|
|
|
sub _expand_update_clause_set {
|
|
return $_[2] if ref($_[2]) eq 'HASH' and ($_[2]->{-op}||[''])->[0] eq ',';
|
|
+(set => $_[0]->_expand_update_set_values($_[1], $_[2]));
|
|
}
|
|
|
|
sub _expand_update_clause_where {
|
|
+(where => $_[0]->expand_expr($_[2]));
|
|
}
|
|
|
|
sub _expand_update_clause_returning {
|
|
+(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident));
|
|
}
|
|
|
|
# So that subclasses can override UPDATE ... RETURNING separately from
|
|
# INSERT and DELETE
|
|
sub _update_returning { shift->_returning(@_) }
|
|
|
|
|
|
|
|
#======================================================================
|
|
# SELECT
|
|
#======================================================================
|
|
|
|
sub select {
|
|
my ($self, @args) = @_;
|
|
my $stmt = do {
|
|
if (ref(my $sel = $args[0]) eq 'HASH') {
|
|
$sel
|
|
} else {
|
|
my %clauses;
|
|
@clauses{qw(from select where order_by)} = @args;
|
|
|
|
# This oddity is to literalify since historically SQLA doesn't quote
|
|
# a single identifier argument, so we convert it into a literal
|
|
|
|
$clauses{select} = { -literal => [ $clauses{select}||'*' ] }
|
|
unless ref($clauses{select});
|
|
\%clauses;
|
|
}
|
|
};
|
|
|
|
my @rendered = $self->render_statement({ -select => $stmt });
|
|
return wantarray ? @rendered : $rendered[0];
|
|
}
|
|
|
|
sub _expand_select_clause_select {
|
|
my ($self, undef, $select) = @_;
|
|
+(select => $self->expand_expr({ -list => $select }, -ident));
|
|
}
|
|
|
|
sub _expand_select_clause_from {
|
|
my ($self, undef, $from) = @_;
|
|
+(from => $self->expand_expr({ -list => $from }, -ident));
|
|
}
|
|
|
|
sub _expand_select_clause_where {
|
|
my ($self, undef, $where) = @_;
|
|
|
|
my $sqla = do {
|
|
if (my $conv = $self->{convert}) {
|
|
my $_wrap = sub {
|
|
my $orig = shift;
|
|
sub {
|
|
my $self = shift;
|
|
+{ -func => [
|
|
$conv,
|
|
$self->$orig(@_)
|
|
] };
|
|
};
|
|
};
|
|
$self->clone
|
|
->wrap_expander(bind => $_wrap)
|
|
->wrap_op_expanders(map +($_ => $_wrap), qw(ident value))
|
|
->wrap_expander(func => sub {
|
|
my $orig = shift;
|
|
sub {
|
|
my ($self, $type, $thing) = @_;
|
|
if (ref($thing) eq 'ARRAY' and $thing->[0] eq $conv
|
|
and @$thing == 2 and ref($thing->[1]) eq 'HASH'
|
|
and (
|
|
$thing->[1]{-ident}
|
|
or $thing->[1]{-value}
|
|
or $thing->[1]{-bind})
|
|
) {
|
|
return { -func => $thing }; # already went through our expander
|
|
}
|
|
return $self->$orig($type, $thing);
|
|
}
|
|
});
|
|
} else {
|
|
$self;
|
|
}
|
|
};
|
|
|
|
return +(where => $sqla->expand_expr($where));
|
|
}
|
|
|
|
sub _expand_select_clause_order_by {
|
|
my ($self, undef, $order_by) = @_;
|
|
+(order_by => $self->_expand_order_by($order_by));
|
|
}
|
|
|
|
sub _select_fields {
|
|
my ($self, $fields) = @_;
|
|
return $fields unless ref($fields);
|
|
my ($sql, @bind) = @{ $self->render_aqt(
|
|
$self->expand_expr({ -list => $fields }, '-ident')
|
|
) };
|
|
return wantarray ? ($sql, @bind) : $sql;
|
|
}
|
|
|
|
#======================================================================
|
|
# DELETE
|
|
#======================================================================
|
|
|
|
sub delete {
|
|
my ($self, $table, $where, $options) = @_;
|
|
|
|
my $stmt = do {
|
|
if (ref($table) eq 'HASH') {
|
|
$table;
|
|
} else {
|
|
my %clauses = (target => $table, where => $where, %{$options||{}});
|
|
\%clauses;
|
|
}
|
|
};
|
|
my @rendered = $self->render_statement({ -delete => $stmt });
|
|
return wantarray ? @rendered : $rendered[0];
|
|
}
|
|
|
|
# So that subclasses can override DELETE ... RETURNING separately from
|
|
# INSERT and UPDATE
|
|
sub _delete_returning { shift->_returning(@_) }
|
|
|
|
sub _expand_delete_clause_target {
|
|
+(target => $_[0]->expand_expr({ -list => $_[2] }, -ident));
|
|
}
|
|
|
|
sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); }
|
|
|
|
sub _expand_delete_clause_returning {
|
|
+(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident));
|
|
}
|
|
|
|
sub _render_delete_clause_target {
|
|
my ($self, undef, $from) = @_;
|
|
$self->join_query_parts(' ', { -keyword => 'delete from' }, $from);
|
|
}
|
|
|
|
#======================================================================
|
|
# WHERE: entry point
|
|
#======================================================================
|
|
|
|
|
|
|
|
# Finally, a separate routine just to handle WHERE clauses
|
|
sub where {
|
|
my ($self, $where, $order) = @_;
|
|
|
|
local $self->{convert_where} = $self->{convert};
|
|
|
|
# where ?
|
|
my ($sql, @bind) = defined($where)
|
|
? $self->_recurse_where($where)
|
|
: (undef);
|
|
$sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : '';
|
|
|
|
# order by?
|
|
if ($order) {
|
|
my ($order_sql, @order_bind) = $self->_order_by($order);
|
|
$sql .= $order_sql;
|
|
push @bind, @order_bind;
|
|
}
|
|
|
|
return wantarray ? ($sql, @bind) : $sql;
|
|
}
|
|
|
|
{ our $Default_Scalar_To = -value }
|
|
|
|
sub expand_expr {
|
|
my ($self, $expr, $default_scalar_to) = @_;
|
|
local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
|
|
$self->_expand_expr($expr);
|
|
}
|
|
|
|
sub render_aqt {
|
|
my ($self, $aqt, $top_level) = @_;
|
|
my ($k, $v, @rest) = %$aqt;
|
|
die "No" if @rest;
|
|
die "Not a node type: $k" unless $k =~ s/^-//;
|
|
if (my $meth = $self->{render}{$k}) {
|
|
local our $Render_Top_Level = $top_level;
|
|
return $self->$meth($k, $v)||[];
|
|
}
|
|
die "notreached: $k";
|
|
}
|
|
|
|
sub render_expr {
|
|
my ($self, $expr, $default_scalar_to) = @_;
|
|
return @{ $self->render_aqt(
|
|
$self->expand_expr($expr, $default_scalar_to)
|
|
) };
|
|
}
|
|
|
|
sub render_statement {
|
|
my ($self, $expr, $default_scalar_to) = @_;
|
|
@{$self->render_aqt(
|
|
$self->expand_expr($expr, $default_scalar_to), 1
|
|
)};
|
|
}
|
|
|
|
sub _expand_statement {
|
|
my ($self, $type, $args) = @_;
|
|
my $ec = $self->{expand_clause};
|
|
if ($args->{_}) {
|
|
$args = { %$args };
|
|
$args->{$type} = delete $args->{_}
|
|
}
|
|
my %has_clause = map +($_ => 1), @{$self->{clauses_of}{$type}};
|
|
return +{ "-${type}" => +{
|
|
map {
|
|
my $val = $args->{$_};
|
|
if (defined($val) and my $exp = $ec->{"${type}.$_"}) {
|
|
if ((my (@exp) = $self->$exp($_ => $val)) == 1) {
|
|
($_ => $exp[0])
|
|
} else {
|
|
@exp
|
|
}
|
|
} elsif ($has_clause{$_}) {
|
|
($_ => $self->expand_expr($val))
|
|
} else {
|
|
($_ => $val)
|
|
}
|
|
} sort keys %$args
|
|
} };
|
|
}
|
|
|
|
sub _render_statement {
|
|
my ($self, $type, $args) = @_;
|
|
my @parts;
|
|
foreach my $clause (@{$self->{clauses_of}{$type}}) {
|
|
next unless my $clause_expr = $args->{$clause};
|
|
my $part = do {
|
|
if (my $rdr = $self->{render_clause}{"${type}.${clause}"}) {
|
|
$self->$rdr($clause, $clause_expr, $args);
|
|
} else {
|
|
my $r = $self->render_aqt($clause_expr, 1);
|
|
next unless defined $r->[0] and length $r->[0];
|
|
$self->join_query_parts(' ',
|
|
{ -keyword => $clause },
|
|
$r
|
|
);
|
|
}
|
|
};
|
|
push @parts, $part;
|
|
}
|
|
my $q = $self->join_query_parts(' ', @parts);
|
|
return $self->join_query_parts('',
|
|
(our $Render_Top_Level ? $q : ('(', $q, ')'))
|
|
);
|
|
}
|
|
|
|
sub _normalize_op {
|
|
my ($self, $raw) = @_;
|
|
my $op = lc $raw;
|
|
return $op if grep $_->{$op}, @{$self}{qw(expand_op render_op)};
|
|
s/^-(?=.)//, s/\s+/_/g for $op;
|
|
$op;
|
|
}
|
|
|
|
sub _expand_expr {
|
|
my ($self, $expr) = @_;
|
|
our $Expand_Depth ||= 0; local $Expand_Depth = $Expand_Depth + 1;
|
|
return undef unless defined($expr);
|
|
if (ref($expr) eq 'HASH') {
|
|
return undef unless my $kc = keys %$expr;
|
|
if ($kc > 1) {
|
|
return $self->_expand_logop(and => $expr);
|
|
}
|
|
my ($key, $value) = %$expr;
|
|
if ($key =~ /^-/ and $key =~ 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 => [ $key => COND1, $key => COND2 ... ]";
|
|
}
|
|
return $self->_expand_hashpair($key, $value);
|
|
}
|
|
if (ref($expr) eq 'ARRAY') {
|
|
return $self->_expand_logop(lc($self->{logic}), $expr);
|
|
}
|
|
if (my $literal = is_literal_value($expr)) {
|
|
return +{ -literal => $literal };
|
|
}
|
|
if (!ref($expr) or Scalar::Util::blessed($expr)) {
|
|
return $self->_expand_scalar($expr);
|
|
}
|
|
die "notreached";
|
|
}
|
|
|
|
sub _expand_hashpair {
|
|
my ($self, $k, $v) = @_;
|
|
unless (defined($k) and length($k)) {
|
|
if (defined($k) and my $literal = is_literal_value($v)) {
|
|
belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
|
|
return { -literal => $literal };
|
|
}
|
|
puke "Supplying an empty left hand side argument is not supported";
|
|
}
|
|
if ($k =~ /^-./) {
|
|
return $self->_expand_hashpair_op($k, $v);
|
|
} elsif ($k =~ /^\W+$/) {
|
|
my ($lhs, @rhs) = ref($v) eq 'ARRAY' ? @$v : $v;
|
|
return $self->_expand_op(
|
|
-op, [ $k, $self->expand_expr($lhs, -ident), @rhs ]
|
|
);
|
|
}
|
|
return $self->_expand_hashpair_ident($k, $v);
|
|
}
|
|
|
|
sub _expand_hashpair_ident {
|
|
my ($self, $k, $v) = @_;
|
|
|
|
local our $Cur_Col_Meta = $k;
|
|
|
|
# hash with multiple or no elements is andor
|
|
|
|
if (ref($v) eq 'HASH' and keys %$v != 1) {
|
|
return $self->_expand_logop(and => $v, $k);
|
|
}
|
|
|
|
# undef needs to be re-sent with cmp to achieve IS/IS NOT NULL
|
|
|
|
if (is_undef_value($v)) {
|
|
return $self->_expand_hashpair_cmp($k => undef);
|
|
}
|
|
|
|
# scalars and objects get expanded as whatever requested or values
|
|
|
|
if (!ref($v) or Scalar::Util::blessed($v)) {
|
|
return $self->_expand_hashpair_scalar($k, $v);
|
|
}
|
|
|
|
# single key hashref is a hashtriple
|
|
|
|
if (ref($v) eq 'HASH') {
|
|
return $self->_expand_hashtriple($k, %$v);
|
|
}
|
|
|
|
# arrayref needs re-engineering over the elements
|
|
|
|
if (ref($v) eq 'ARRAY') {
|
|
return $self->sqlfalse unless @$v;
|
|
$self->_debug("ARRAY($k) means distribute over elements");
|
|
my $logic = lc(
|
|
($v->[0]||'') =~ /^-(and|or)$/i
|
|
? (shift(@{$v = [ @$v ]}), $1)
|
|
: lc($self->{logic} || 'OR')
|
|
);
|
|
return $self->_expand_logop(
|
|
$logic => $v, $k
|
|
);
|
|
}
|
|
|
|
if (my $literal = is_literal_value($v)) {
|
|
unless (length $k) {
|
|
belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead';
|
|
return \$literal;
|
|
}
|
|
my ($sql, @bind) = @$literal;
|
|
if ($self->{bindtype} eq 'columns') {
|
|
for (@bind) {
|
|
$self->_assert_bindval_matches_bindtype($_);
|
|
}
|
|
}
|
|
return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] };
|
|
}
|
|
die "notreached";
|
|
}
|
|
|
|
sub _expand_scalar {
|
|
my ($self, $expr) = @_;
|
|
|
|
return $self->_expand_expr({ (our $Default_Scalar_To) => $expr });
|
|
}
|
|
|
|
sub _expand_hashpair_scalar {
|
|
my ($self, $k, $v) = @_;
|
|
|
|
return $self->_expand_hashpair_cmp(
|
|
$k, $self->_expand_scalar($v),
|
|
);
|
|
}
|
|
|
|
sub _expand_hashpair_op {
|
|
my ($self, $k, $v) = @_;
|
|
|
|
$self->_assert_pass_injection_guard($k =~ /\A-(.*)\Z/s);
|
|
|
|
my $op = $self->_normalize_op($k);
|
|
|
|
my $wsop = join(' ', split '_', $op);
|
|
|
|
my $is_special = List::Util::first { $wsop =~ $_->{regex} }
|
|
@{$self->{special_ops}};
|
|
|
|
{ # Old SQLA compat
|
|
|
|
# the old special op system requires illegality for top-level use
|
|
|
|
if (
|
|
(our $Expand_Depth) == 1
|
|
and (
|
|
$is_special
|
|
or (
|
|
$self->{disable_old_special_ops}
|
|
and List::Util::first { $wsop =~ $_->{regex} } @BUILTIN_SPECIAL_OPS
|
|
)
|
|
)
|
|
) {
|
|
puke "Illegal use of top-level '-$wsop'"
|
|
}
|
|
}
|
|
|
|
if (my $exp = $self->{expand}{$op}||$self->{expand_op}{$op}) {
|
|
return $self->$exp($op, $v);
|
|
}
|
|
|
|
if ($self->{render}{$op}) {
|
|
return { "-${op}" => $v };
|
|
}
|
|
|
|
# Ops prefixed with -not_ get converted
|
|
|
|
if (my ($rest) = $op =~/^not_(.*)$/) {
|
|
return +{ -op => [
|
|
'not',
|
|
$self->_expand_expr({ "-${rest}", $v })
|
|
] };
|
|
}
|
|
|
|
{ # Old SQLA compat
|
|
|
|
# the old unary op system means we should touch nothing and let it work
|
|
|
|
my $op = join(' ', split '_', $op);
|
|
|
|
if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
|
|
return { -op => [ $op, $v ] };
|
|
}
|
|
}
|
|
|
|
my $type = $is_special || $self->{render_op}{$op} ? -op : -func;
|
|
|
|
if ($self->{restore_old_unop_handling}) {
|
|
|
|
# Old SQLA compat
|
|
|
|
if (
|
|
ref($v) eq 'HASH'
|
|
and keys %$v == 1
|
|
and (keys %$v)[0] =~ /^-/
|
|
and not $self->{render_op}{$op}
|
|
and not $is_special
|
|
) {
|
|
$type = -func;
|
|
} else {
|
|
$type = -op;
|
|
}
|
|
}
|
|
|
|
if ($type eq -func and ref($v) eq 'ARRAY') {
|
|
return $self->_expand_expr({ -func => [ $op, @$v ] });
|
|
}
|
|
|
|
return $self->_expand_expr({ $type => [ $op, $v ] });
|
|
}
|
|
|
|
sub _expand_hashpair_cmp {
|
|
my ($self, $k, $v) = @_;
|
|
$self->_expand_hashtriple($k, $self->{cmp}, $v);
|
|
}
|
|
|
|
sub _expand_hashtriple {
|
|
my ($self, $k, $vk, $vv) = @_;
|
|
|
|
my $ik = $self->_expand_expr({ -ident => $k });
|
|
|
|
my $op = $self->_normalize_op($vk);
|
|
$self->_assert_pass_injection_guard($op);
|
|
|
|
if ($op =~ s/ _? \d+ $//x ) {
|
|
return $self->_expand_expr($k, { $vk, $vv });
|
|
}
|
|
if (my $x = $self->{expand_op}{$op}) {
|
|
local our $Cur_Col_Meta = $k;
|
|
return $self->$x($op, $vv, $k);
|
|
}
|
|
{ # Old SQLA compat
|
|
|
|
my $op = join(' ', split '_', $op);
|
|
|
|
if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
|
|
return { -op => [ $op, $ik, $vv ] };
|
|
}
|
|
if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
|
|
return { -op => [
|
|
$self->{cmp},
|
|
$ik,
|
|
{ -op => [ $op, $vv ] }
|
|
] };
|
|
}
|
|
}
|
|
if (ref($vv) eq 'ARRAY') {
|
|
my @raw = @$vv;
|
|
my $logic = (defined($raw[0]) and $raw[0] =~ /^-(and|or)$/i)
|
|
? (shift(@raw), lc $1) : 'or';
|
|
my @values = map +{ $vk => $_ }, @raw;
|
|
if (
|
|
$op =~ $self->{inequality_op}
|
|
or $op =~ $self->{not_like_op}
|
|
) {
|
|
if (lc($logic) eq 'or' and @values > 1) {
|
|
belch "A multi-element arrayref as an argument to the inequality op '${\uc(join ' ', split '_', $op)}' "
|
|
. 'is technically equivalent to an always-true 1=1 (you probably wanted '
|
|
. "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)"
|
|
;
|
|
}
|
|
}
|
|
unless (@values) {
|
|
# try to DWIM on equality operators
|
|
return ($self->_dwim_op_to_is($op,
|
|
"Supplying an empty arrayref to '%s' is deprecated",
|
|
"operator '%s' applied on an empty array (field '$k')"
|
|
) ? $self->sqlfalse : $self->sqltrue);
|
|
}
|
|
return $self->_expand_logop($logic => \@values, $k);
|
|
}
|
|
if (is_undef_value($vv)) {
|
|
my $is = ($self->_dwim_op_to_is($op,
|
|
"Supplying an undefined argument to '%s' is deprecated",
|
|
"unexpected operator '%s' with undef operand",
|
|
) ? 'is' : 'is not');
|
|
|
|
return $self->_expand_hashpair($k => { $is, undef });
|
|
}
|
|
local our $Cur_Col_Meta = $k;
|
|
return +{ -op => [
|
|
$op,
|
|
$ik,
|
|
$self->_expand_expr($vv)
|
|
] };
|
|
}
|
|
|
|
sub _dwim_op_to_is {
|
|
my ($self, $raw, $empty, $fail) = @_;
|
|
|
|
my $op = $self->_normalize_op($raw);
|
|
|
|
if ($op =~ /^not$/i) {
|
|
return 0;
|
|
}
|
|
if ($op =~ $self->{equality_op}) {
|
|
return 1;
|
|
}
|
|
if ($op =~ $self->{like_op}) {
|
|
belch(sprintf $empty, uc(join ' ', split '_', $op));
|
|
return 1;
|
|
}
|
|
if ($op =~ $self->{inequality_op}) {
|
|
return 0;
|
|
}
|
|
if ($op =~ $self->{not_like_op}) {
|
|
belch(sprintf $empty, uc(join ' ', split '_', $op));
|
|
return 0;
|
|
}
|
|
puke(sprintf $fail, $op);
|
|
}
|
|
|
|
sub _expand_func {
|
|
my ($self, undef, $args) = @_;
|
|
my ($func, @args) = @$args;
|
|
return +{ -func => [ $func, map $self->expand_expr($_), @args ] };
|
|
}
|
|
|
|
sub _expand_ident {
|
|
my ($self, undef, $body) = @_;
|
|
unless (defined($body) or (ref($body) and ref($body) eq 'ARRAY')) {
|
|
puke "-ident requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
|
|
}
|
|
my ($sep) = map +(defined() ? $_ : '.') , $self->{name_sep};
|
|
my @parts = map +($sep
|
|
? map split(/\Q${sep}\E/, $_), @$_
|
|
: @$_
|
|
), ref($body) ? $body : [ $body ];
|
|
return { -ident => $parts[-1] } if $self->{_dequalify_idents};
|
|
unless ($self->{quote_char}) {
|
|
$self->_assert_pass_injection_guard($_) for @parts;
|
|
}
|
|
return +{ -ident => \@parts };
|
|
}
|
|
|
|
sub _expand_value {
|
|
+{ -bind => [ our $Cur_Col_Meta, $_[2] ] };
|
|
}
|
|
|
|
sub _expand_row {
|
|
my ($self, undef, $args) = @_;
|
|
+{ -row => [ map $self->expand_expr($_), @$args ] };
|
|
}
|
|
|
|
sub _expand_op {
|
|
my ($self, undef, $args) = @_;
|
|
my ($op, @opargs) = @$args;
|
|
if (my $exp = $self->{expand_op}{$op}) {
|
|
return $self->$exp($op, \@opargs);
|
|
}
|
|
if (List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
|
|
return { -op => [ $op, @opargs ] };
|
|
}
|
|
+{ -op => [ $op, map $self->expand_expr($_), @opargs ] };
|
|
}
|
|
|
|
sub _expand_bool {
|
|
my ($self, undef, $v) = @_;
|
|
if (ref($v)) {
|
|
return $self->_expand_expr($v);
|
|
}
|
|
puke "-bool => undef not supported" unless defined($v);
|
|
return $self->_expand_expr({ -ident => $v });
|
|
}
|
|
|
|
sub _expand_list {
|
|
my ($self, undef, $expr) = @_;
|
|
return { -op => [
|
|
',', map $self->expand_expr($_),
|
|
@{$expr->{-op}}[1..$#{$expr->{-op}}]
|
|
] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ',';
|
|
return +{ -op => [ ',',
|
|
map $self->expand_expr($_),
|
|
ref($expr) eq 'ARRAY' ? @$expr : $expr
|
|
] };
|
|
}
|
|
|
|
sub _expand_logop {
|
|
my ($self, $logop, $v, $k) = @_;
|
|
$self->${\$self->{expand_op}{$logop}}($logop, $v, $k);
|
|
}
|
|
|
|
sub _expand_op_andor {
|
|
my ($self, $logop, $v, $k) = @_;
|
|
if (defined $k) {
|
|
$v = [ map +{ $k, $_ },
|
|
(ref($v) eq 'HASH')
|
|
? (map +{ $_ => $v->{$_} }, sort keys %$v)
|
|
: @$v,
|
|
];
|
|
}
|
|
if (ref($v) eq 'HASH') {
|
|
return undef unless keys %$v;
|
|
return +{ -op => [
|
|
$logop,
|
|
map $self->_expand_expr({ $_ => $v->{$_} }),
|
|
sort keys %$v
|
|
] };
|
|
}
|
|
if (ref($v) eq 'ARRAY') {
|
|
$logop eq 'and' or $logop eq 'or' or puke "unknown logic: $logop";
|
|
|
|
my @expr = grep {
|
|
(ref($_) eq 'ARRAY' and @$_)
|
|
or (ref($_) eq 'HASH' and %$_)
|
|
or 1
|
|
} @$v;
|
|
|
|
my @res;
|
|
|
|
while (my ($el) = splice @expr, 0, 1) {
|
|
puke "Supplying an empty left hand side argument is not supported in array-pairs"
|
|
unless defined($el) and length($el);
|
|
my $elref = ref($el);
|
|
if (!$elref) {
|
|
local our $Expand_Depth = 0;
|
|
push(@res, grep defined, $self->_expand_expr({ $el, shift(@expr) }));
|
|
} elsif ($elref eq 'ARRAY') {
|
|
push(@res, grep defined, $self->_expand_expr($el)) if @$el;
|
|
} elsif (my $l = is_literal_value($el)) {
|
|
push @res, { -literal => $l };
|
|
} elsif ($elref eq 'HASH') {
|
|
local our $Expand_Depth = 0;
|
|
push @res, grep defined, $self->_expand_expr($el) if %$el;
|
|
} else {
|
|
die "notreached";
|
|
}
|
|
}
|
|
# ???
|
|
# return $res[0] if @res == 1;
|
|
return { -op => [ $logop, @res ] };
|
|
}
|
|
die "notreached";
|
|
}
|
|
|
|
sub _expand_op_is {
|
|
my ($self, $op, $vv, $k) = @_;
|
|
($k, $vv) = @$vv unless defined $k;
|
|
puke "$op can only take undef as argument"
|
|
if defined($vv)
|
|
and not (
|
|
ref($vv) eq 'HASH'
|
|
and exists($vv->{-value})
|
|
and !defined($vv->{-value})
|
|
);
|
|
return +{ -op => [ $op.'_null', $self->expand_expr($k, -ident) ] };
|
|
}
|
|
|
|
sub _expand_between {
|
|
my ($self, $op, $vv, $k) = @_;
|
|
my @rhs = map $self->_expand_expr($_),
|
|
ref($vv) eq 'ARRAY' ? @$vv : $vv;
|
|
unless (
|
|
(@rhs == 1 and ref($rhs[0]) eq 'HASH' and $rhs[0]->{-literal})
|
|
or
|
|
(@rhs == 2 and defined($rhs[0]) and defined($rhs[1]))
|
|
) {
|
|
puke "Operator '${\uc($op)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref";
|
|
}
|
|
return +{ -op => [
|
|
$op,
|
|
$self->expand_expr($k),
|
|
map $self->expand_expr($_, -value), @rhs
|
|
] }
|
|
}
|
|
|
|
sub _expand_in {
|
|
my ($self, $op, $vv, $k) = @_;
|
|
if (my $literal = is_literal_value($vv)) {
|
|
my ($sql, @bind) = @$literal;
|
|
my $opened_sql = $self->_open_outer_paren($sql);
|
|
return +{ -op => [
|
|
$op, $self->expand_expr($k, -ident),
|
|
{ -literal => [ $opened_sql, @bind ] }
|
|
] };
|
|
}
|
|
my $undef_err =
|
|
'SQL::Abstract before v1.75 used to generate incorrect SQL when the '
|
|
. "-${\uc($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)'
|
|
;
|
|
puke("Argument passed to the '${\uc($op)}' operator can not be undefined")
|
|
if !defined($vv);
|
|
my @rhs = map $self->expand_expr($_, -value),
|
|
map { defined($_) ? $_: puke($undef_err) }
|
|
(ref($vv) eq 'ARRAY' ? @$vv : $vv);
|
|
return $self->${\($op =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs;
|
|
|
|
return +{ -op => [
|
|
$op,
|
|
$self->expand_expr($k, -ident),
|
|
@rhs
|
|
] };
|
|
}
|
|
|
|
sub _expand_nest {
|
|
my ($self, undef, $v) = @_;
|
|
# DBIx::Class requires a nest warning to be emitted once but the private
|
|
# method it overrode to do so no longer exists
|
|
if ($self->{warn_once_on_nest}) {
|
|
unless (our $Nest_Warned) {
|
|
belch(
|
|
"-nest in search conditions is deprecated, you most probably wanted:\n"
|
|
.q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
|
|
);
|
|
$Nest_Warned = 1;
|
|
}
|
|
}
|
|
return $self->_expand_expr($v);
|
|
}
|
|
|
|
sub _expand_values {
|
|
my ($self, undef, $values) = @_;
|
|
return { -values => [
|
|
map +(
|
|
ref($_) eq 'HASH'
|
|
? $self->expand_expr($_)
|
|
: +{ -row => [ map $self->expand_expr($_), @$_ ] }
|
|
), ref($values) eq 'ARRAY' ? @$values : $values
|
|
] };
|
|
}
|
|
|
|
sub _recurse_where {
|
|
my ($self, $where) = @_;
|
|
|
|
# Special case: top level simple string treated as literal
|
|
|
|
my $where_exp = (ref($where)
|
|
? $self->_expand_select_clause_where(undef, $where)
|
|
: { -literal => [ $where ] });
|
|
|
|
# dispatch expanded expression
|
|
|
|
my ($sql, @bind) = defined($where_exp) ? @{ $self->render_aqt($where_exp) || [] } : ();
|
|
# DBIx::Class used to call _recurse_where in scalar context
|
|
# something else might too...
|
|
if (wantarray) {
|
|
return ($sql, @bind);
|
|
}
|
|
else {
|
|
belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0";
|
|
return $sql;
|
|
}
|
|
}
|
|
|
|
sub _render_ident {
|
|
my ($self, undef, $ident) = @_;
|
|
|
|
return [ $self->_quote($ident) ];
|
|
}
|
|
|
|
sub _render_row {
|
|
my ($self, undef, $values) = @_;
|
|
return $self->join_query_parts('',
|
|
'(',
|
|
$self->_render_op(undef, [ ',', @$values ]),
|
|
')'
|
|
);
|
|
}
|
|
|
|
sub _render_func {
|
|
my ($self, undef, $rest) = @_;
|
|
my ($func, @args) = @$rest;
|
|
return $self->join_query_parts('',
|
|
$self->_sqlcase($func),
|
|
$self->join_query_parts('',
|
|
'(',
|
|
$self->join_query_parts(', ', @args),
|
|
')'
|
|
),
|
|
);
|
|
}
|
|
|
|
sub _render_bind {
|
|
my ($self, undef, $bind) = @_;
|
|
return [ '?', $self->_bindtype(@$bind) ];
|
|
}
|
|
|
|
sub _render_literal {
|
|
my ($self, undef, $literal) = @_;
|
|
$self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
|
|
return $literal;
|
|
}
|
|
|
|
sub _render_keyword {
|
|
my ($self, undef, $keyword) = @_;
|
|
return [ $self->_sqlcase(
|
|
ref($keyword) ? $$keyword : join ' ', split '_', $keyword
|
|
) ];
|
|
}
|
|
|
|
sub _render_op {
|
|
my ($self, undef, $v) = @_;
|
|
my ($op, @args) = @$v;
|
|
if (my $r = $self->{render_op}{$op}) {
|
|
return $self->$r($op, \@args);
|
|
}
|
|
|
|
{ # Old SQLA compat
|
|
|
|
my $op = join(' ', split '_', $op);
|
|
|
|
my $ss = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
|
|
if ($ss and @args > 1) {
|
|
puke "Special op '${op}' requires first value to be identifier"
|
|
unless my ($ident) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
|
|
my $k = join(($self->{name_sep}||'.'), @$ident);
|
|
local our $Expand_Depth = 1;
|
|
return [ $self->${\($ss->{handler})}($k, $op, $args[1]) ];
|
|
}
|
|
if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
|
|
return [ $self->${\($us->{handler})}($op, $args[0]) ];
|
|
}
|
|
if ($ss) {
|
|
return $self->_render_unop_paren($op, \@args);
|
|
}
|
|
}
|
|
if (@args == 1) {
|
|
return $self->_render_unop_prefix($op, \@args);
|
|
} else {
|
|
return $self->_render_op_multop($op, \@args);
|
|
}
|
|
die "notreached";
|
|
}
|
|
|
|
|
|
sub _render_op_between {
|
|
my ($self, $op, $args) = @_;
|
|
my ($left, $low, $high) = @$args;
|
|
my @rh = do {
|
|
if (@$args == 2) {
|
|
puke "Single arg to between must be a literal"
|
|
unless $low->{-literal};
|
|
$low;
|
|
} else {
|
|
+($low, { -keyword => 'and' }, $high);
|
|
}
|
|
};
|
|
return $self->join_query_parts(' ',
|
|
'(', $left, { -keyword => $op }, @rh, ')',
|
|
);
|
|
}
|
|
|
|
sub _render_op_in {
|
|
my ($self, $op, $args) = @_;
|
|
my ($lhs, @rhs) = @$args;
|
|
|
|
return $self->join_query_parts(' ',
|
|
$lhs,
|
|
{ -keyword => $op },
|
|
$self->join_query_parts(' ',
|
|
'(',
|
|
$self->join_query_parts(', ', @rhs),
|
|
')'
|
|
),
|
|
);
|
|
}
|
|
|
|
sub _render_op_andor {
|
|
my ($self, $op, $args) = @_;
|
|
return undef unless @$args;
|
|
return $self->join_query_parts('', $args->[0]) if @$args == 1;
|
|
my $inner = $self->_render_op_multop($op, $args);
|
|
return undef unless defined($inner->[0]) and length($inner->[0]);
|
|
return $self->join_query_parts(' ',
|
|
'(', $inner, ')'
|
|
);
|
|
}
|
|
|
|
sub _render_op_multop {
|
|
my ($self, $op, $args) = @_;
|
|
my @parts = @$args;
|
|
return undef unless @parts;
|
|
return $self->render_aqt($parts[0]) if @parts == 1;
|
|
my $join = ($op eq ','
|
|
? ', '
|
|
: { -keyword => " ${op} " }
|
|
);
|
|
return $self->join_query_parts($join, @parts);
|
|
}
|
|
|
|
sub _render_values {
|
|
my ($self, undef, $values) = @_;
|
|
my $inner = $self->join_query_parts(' ',
|
|
{ -keyword => 'values' },
|
|
$self->join_query_parts(', ',
|
|
ref($values) eq 'ARRAY' ? @$values : $values
|
|
),
|
|
);
|
|
return $self->join_query_parts('',
|
|
(our $Render_Top_Level ? $inner : ('(', $inner, ')'))
|
|
);
|
|
}
|
|
|
|
sub join_query_parts {
|
|
my ($self, $join, @parts) = @_;
|
|
if (ref($join) eq 'HASH') {
|
|
$join = $self->render_aqt($join)->[0];
|
|
}
|
|
my @final = map +(
|
|
ref($_) eq 'HASH'
|
|
? $self->render_aqt($_)
|
|
: ((ref($_) eq 'ARRAY') ? $_ : [ $_ ])
|
|
), @parts;
|
|
return [
|
|
$self->{join_sql_parts}->(
|
|
$join, grep defined && length, map $_->[0], @final
|
|
),
|
|
(map @{$_}[1..$#$_], @final),
|
|
];
|
|
}
|
|
|
|
sub _render_unop_paren {
|
|
my ($self, $op, $v) = @_;
|
|
return $self->join_query_parts('',
|
|
'(', $self->_render_unop_prefix($op, $v), ')'
|
|
);
|
|
}
|
|
|
|
sub _render_unop_prefix {
|
|
my ($self, $op, $v) = @_;
|
|
my $op_sql = $self->{restore_old_unop_handling}
|
|
? $self->_sqlcase($op)
|
|
: { -keyword => $op };
|
|
return $self->join_query_parts(' ',
|
|
($self->{restore_old_unop_handling}
|
|
? $self->_sqlcase($op)
|
|
: { -keyword => \$op }),
|
|
$v->[0]
|
|
);
|
|
}
|
|
|
|
sub _render_unop_postfix {
|
|
my ($self, $op, $v) = @_;
|
|
return $self->join_query_parts(' ',
|
|
$v->[0], { -keyword => $op },
|
|
);
|
|
}
|
|
|
|
# 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) = @_;
|
|
|
|
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;
|
|
}
|
|
|
|
sub _where_field_IN {
|
|
my ($self, $k, $op, $vals) = @_;
|
|
@{$self->_render_op_in(
|
|
$op,
|
|
[
|
|
$self->expand_expr($k, -ident),
|
|
map $self->expand_expr($_, -value),
|
|
ref($vals) eq 'ARRAY' ? @$vals : $vals
|
|
]
|
|
)};
|
|
}
|
|
|
|
sub _where_field_BETWEEN {
|
|
my ($self, $k, $op, $vals) = @_;
|
|
@{$self->_render_op_between(
|
|
$op,
|
|
[ $self->expand_expr($k, -ident), ref($vals) eq 'ARRAY' ? @$vals : $vals ]
|
|
)};
|
|
}
|
|
|
|
#======================================================================
|
|
# ORDER BY
|
|
#======================================================================
|
|
|
|
sub _expand_order_by {
|
|
my ($self, $arg) = @_;
|
|
|
|
return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
|
|
|
|
return $self->expand_expr({ -list => $arg })
|
|
if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ',';
|
|
|
|
my $expander = sub {
|
|
my ($self, $dir, $expr) = @_;
|
|
my @to_expand = ref($expr) eq 'ARRAY' ? @$expr : $expr;
|
|
foreach my $arg (@to_expand) {
|
|
if (
|
|
ref($arg) eq 'HASH'
|
|
and keys %$arg > 1
|
|
and grep /^-(asc|desc)$/, keys %$arg
|
|
) {
|
|
puke "ordering direction hash passed to order by must have exactly one key (-asc or -desc)";
|
|
}
|
|
}
|
|
my @exp = map +(
|
|
defined($dir) ? { -op => [ $dir =~ /^-?(.*)$/ ,=> $_ ] } : $_
|
|
),
|
|
map $self->expand_expr($_, -ident),
|
|
map ref($_) eq 'ARRAY' ? @$_ : $_, @to_expand;
|
|
return undef unless @exp;
|
|
return undef if @exp == 1 and not defined($exp[0]);
|
|
return +{ -op => [ ',', @exp ] };
|
|
};
|
|
|
|
local @{$self->{expand}}{qw(asc desc)} = (($expander) x 2);
|
|
|
|
return $self->$expander(undef, $arg);
|
|
}
|
|
|
|
sub _order_by {
|
|
my ($self, $arg) = @_;
|
|
|
|
return '' unless defined(my $expanded = $self->_expand_order_by($arg));
|
|
|
|
my ($sql, @bind) = @{ $self->render_aqt($expanded) };
|
|
|
|
return '' unless length($sql);
|
|
|
|
my $final_sql = $self->_sqlcase(' order by ').$sql;
|
|
|
|
return $final_sql unless wantarray;
|
|
|
|
return ($final_sql, @bind);
|
|
}
|
|
|
|
# _order_by no longer needs to call this so doesn't but DBIC uses it.
|
|
|
|
sub _order_by_chunks {
|
|
my ($self, $arg) = @_;
|
|
|
|
return () unless defined(my $expanded = $self->_expand_order_by($arg));
|
|
|
|
my @res = $self->_chunkify_order_by($expanded);
|
|
(ref() ? $_->[0] : $_) .= '' for @res;
|
|
return @res;
|
|
}
|
|
|
|
sub _chunkify_order_by {
|
|
my ($self, $expanded) = @_;
|
|
|
|
return grep length, @{ $self->render_aqt($expanded) }
|
|
if $expanded->{-ident} or @{$expanded->{-literal}||[]} == 1;
|
|
|
|
for ($expanded) {
|
|
if (ref() eq 'HASH' and $_->{-op} and $_->{-op}[0] eq ',') {
|
|
my ($comma, @list) = @{$_->{-op}};
|
|
return map $self->_chunkify_order_by($_), @list;
|
|
}
|
|
return $self->render_aqt($_);
|
|
}
|
|
}
|
|
|
|
#======================================================================
|
|
# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
|
|
#======================================================================
|
|
|
|
sub _table {
|
|
my $self = shift;
|
|
my $from = shift;
|
|
$self->render_aqt(
|
|
$self->expand_expr({ -list => $from }, -ident)
|
|
)->[0];
|
|
}
|
|
|
|
|
|
#======================================================================
|
|
# 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';
|
|
puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH';
|
|
|
|
unless ($_[0]->{quote_char}) {
|
|
if (ref($_[1]) eq 'ARRAY') {
|
|
return join($_[0]->{name_sep}||'.', @{$_[1]});
|
|
} else {
|
|
$_[0]->_assert_pass_injection_guard($_[1]);
|
|
return $_[1];
|
|
}
|
|
}
|
|
|
|
my $qref = ref $_[0]->{quote_char};
|
|
my ($l, $r) =
|
|
!$qref ? ($_[0]->{quote_char}, $_[0]->{quote_char})
|
|
: ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}}
|
|
: puke "Unsupported quote_char format: $_[0]->{quote_char}";
|
|
|
|
my $esc = $_[0]->{escape_char} || $r;
|
|
|
|
# parts containing * are naturally unquoted
|
|
return join(
|
|
$_[0]->{name_sep}||'',
|
|
map +(
|
|
$_ eq '*'
|
|
? $_
|
|
: do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r }
|
|
),
|
|
(ref($_[1]) eq 'ARRAY'
|
|
? @{$_[1]}
|
|
: (
|
|
$_[0]->{name_sep}
|
|
? split (/\Q$_[0]->{name_sep}\E/, $_[1] )
|
|
: $_[1]
|
|
)
|
|
)
|
|
);
|
|
}
|
|
|
|
|
|
# Conversion, if applicable
|
|
sub _convert {
|
|
#my ($self, $arg) = @_;
|
|
if (my $conv = $_[0]->{convert_where}) {
|
|
return @{ $_[0]->join_query_parts('',
|
|
$_[0]->_sqlcase($conv),
|
|
'(' , $_[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]"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# 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 =~ /.*::(.+)/;
|
|
puke "AUTOLOAD invoked for method name ${name} and allow_autoload option not set" unless $self->{allow_autoload};
|
|
return $self->generate($name, @_);
|
|
}
|
|
|
|
1;
|
|
|
|
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
SQL::Abstract - Generate SQL from Perl data structures
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use SQL::Abstract;
|
|
|
|
my $sql = SQL::Abstract->new;
|
|
|
|
my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order);
|
|
|
|
my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
|
|
|
|
my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where);
|
|
|
|
my($stmt, @bind) = $sql->delete($table, \%where);
|
|
|
|
# Then, use these in your DBI statements
|
|
my $sth = $dbh->prepare($stmt);
|
|
$sth->execute(@bind);
|
|
|
|
# Just generate the WHERE clause
|
|
my($stmt, @bind) = $sql->where(\%where, $order);
|
|
|
|
# Return values in the same order, for hashed queries
|
|
# See PERFORMANCE section for more details
|
|
my @bind = $sql->values(\%fieldvals);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This module was inspired by the excellent L<DBIx::Abstract>.
|
|
However, in using that module I found that what I really wanted
|
|
to do was generate SQL, but still retain complete control over my
|
|
statement handles and use the DBI interface. So, I set out to
|
|
create an abstract SQL generation module.
|
|
|
|
While based on the concepts used by L<DBIx::Abstract>, there are
|
|
several important differences, especially when it comes to WHERE
|
|
clauses. I have modified the concepts used to make the SQL easier
|
|
to generate from Perl data structures and, IMO, more intuitive.
|
|
The underlying idea is for this module to do what you mean, based
|
|
on the data structures you provide it. The big advantage is that
|
|
you don't have to modify your code every time your data changes,
|
|
as this module figures it out.
|
|
|
|
To begin with, an SQL INSERT is as easy as just specifying a hash
|
|
of C<key=value> pairs:
|
|
|
|
my %data = (
|
|
name => 'Jimbo Bobson',
|
|
phone => '123-456-7890',
|
|
address => '42 Sister Lane',
|
|
city => 'St. Louis',
|
|
state => 'Louisiana',
|
|
);
|
|
|
|
The SQL can then be generated with this:
|
|
|
|
my($stmt, @bind) = $sql->insert('people', \%data);
|
|
|
|
Which would give you something like this:
|
|
|
|
$stmt = "INSERT INTO people
|
|
(address, city, name, phone, state)
|
|
VALUES (?, ?, ?, ?, ?)";
|
|
@bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson',
|
|
'123-456-7890', 'Louisiana');
|
|
|
|
These are then used directly in your DBI code:
|
|
|
|
my $sth = $dbh->prepare($stmt);
|
|
$sth->execute(@bind);
|
|
|
|
=head2 Inserting and Updating Arrays
|
|
|
|
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 $sql = SQL::Abstract->new(array_datatypes => 1);
|
|
my %data = (
|
|
planets => [qw/Mercury Venus Earth Mars/]
|
|
);
|
|
|
|
my($stmt, @bind) = $sql->insert('solar_system', \%data);
|
|
|
|
This results in:
|
|
|
|
$stmt = "INSERT INTO solar_system (planets) VALUES (?)"
|
|
|
|
@bind = (['Mercury', 'Venus', 'Earth', 'Mars']);
|
|
|
|
|
|
=head2 Inserting and Updating SQL
|
|
|
|
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:
|
|
|
|
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 Complex where statements
|
|
|
|
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:
|
|
|
|
my %where = (
|
|
requestor => 'inna',
|
|
worker => ['nwiger', 'rcwe', 'sfz'],
|
|
status => { '!=', 'completed' }
|
|
);
|
|
|
|
my($stmt, @bind) = $sql->select('tickets', '*', \%where);
|
|
|
|
The above would give you something like this:
|
|
|
|
$stmt = "SELECT * FROM tickets WHERE
|
|
( requestor = ? ) AND ( status != ? )
|
|
AND ( worker = ? OR worker = ? OR worker = ? )";
|
|
@bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz');
|
|
|
|
Which you could then use in DBI code like so:
|
|
|
|
my $sth = $dbh->prepare($stmt);
|
|
$sth->execute(@bind);
|
|
|
|
Easy, eh?
|
|
|
|
=head1 METHODS
|
|
|
|
The methods are simple. There's one for every major SQL operation,
|
|
and a constructor you use first. The arguments are specified in a
|
|
similar order for each method (table, then fields, then a where
|
|
clause) to try and simplify things.
|
|
|
|
=head2 new(option => 'value')
|
|
|
|
The C<new()> function takes a list of options and values, and returns
|
|
a new B<SQL::Abstract> object which can then be used to generate SQL
|
|
through the methods below. The options accepted are:
|
|
|
|
=over
|
|
|
|
=item case
|
|
|
|
If set to 'lower', then SQL will be generated in all lowercase. By
|
|
default SQL is generated in "textbook" case meaning something like:
|
|
|
|
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
|
|
it is C<=>, meaning that a hash like this:
|
|
|
|
%where = (name => 'nwiger', email => 'nate@wiger.org');
|
|
|
|
Will generate SQL like this:
|
|
|
|
WHERE name = 'nwiger' AND email = 'nate@wiger.org'
|
|
|
|
However, you may want loose comparisons by default, so if you set
|
|
C<cmp> to C<like> you would get SQL such as:
|
|
|
|
WHERE name like 'nwiger' AND email like 'nate@wiger.org'
|
|
|
|
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 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'},
|
|
);
|
|
|
|
will generate SQL like this:
|
|
|
|
WHERE event_date >= '2/13/99' OR event_date <= '4/24/03'
|
|
|
|
This is probably not what you want given this query, though (look
|
|
at the dates). To change the "OR" to an "AND", simply specify:
|
|
|
|
my $sql = SQL::Abstract->new(logic => 'and');
|
|
|
|
Which will change the above C<WHERE> to:
|
|
|
|
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
|
|
function for both column and value. This is mostly used with an argument
|
|
of C<upper> or C<lower>, so that the SQL will have the effect of
|
|
case-insensitive "searches". For example, this:
|
|
|
|
$sql = SQL::Abstract->new(convert => 'upper');
|
|
%where = (keywords => 'MaKe iT CAse inSeNSItive');
|
|
|
|
Will turn out the following SQL:
|
|
|
|
WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive')
|
|
|
|
The conversion can be C<upper()>, C<lower()>, or any other SQL function
|
|
that can be applied symmetrically to fields (actually B<SQL::Abstract> does
|
|
not validate this option; it will just pass through what you specify verbatim).
|
|
|
|
=item bindtype
|
|
|
|
This is a kludge because many databases suck. For example, you can't
|
|
just bind values using DBI's C<execute()> for Oracle C<CLOB> or C<BLOB> fields.
|
|
Instead, you have to use C<bind_param()>:
|
|
|
|
$sth->bind_param(1, 'reg data');
|
|
$sth->bind_param(2, $lots, {ora_type => ORA_CLOB});
|
|
|
|
The problem is, B<SQL::Abstract> will normally just return a C<@bind> array,
|
|
which loses track of which field each slot refers to. Fear not.
|
|
|
|
If you specify C<bindtype> in new, you can determine how C<@bind> is returned.
|
|
Currently, you can specify either C<normal> (default) or C<columns>. If you
|
|
specify C<columns>, you will get an array that looks like this:
|
|
|
|
my $sql = SQL::Abstract->new(bindtype => 'columns');
|
|
my($stmt, @bind) = $sql->insert(...);
|
|
|
|
@bind = (
|
|
[ 'column1', 'value1' ],
|
|
[ 'column2', 'value2' ],
|
|
[ 'column3', 'value3' ],
|
|
);
|
|
|
|
You can then iterate through this manually, using DBI's C<bind_param()>.
|
|
|
|
$sth->prepare($stmt);
|
|
my $i = 1;
|
|
for (@bind) {
|
|
my($col, $data) = @$_;
|
|
if ($col eq 'details' || $col eq 'comments') {
|
|
$sth->bind_param($i, $data, {ora_type => ORA_CLOB});
|
|
} elsif ($col eq 'image') {
|
|
$sth->bind_param($i, $data, {ora_type => ORA_BLOB});
|
|
} else {
|
|
$sth->bind_param($i, $data);
|
|
}
|
|
$i++;
|
|
}
|
|
$sth->execute; # execute without @bind now
|
|
|
|
Now, why would you still use B<SQL::Abstract> if you have to do this crap?
|
|
Basically, the advantage is still that you don't have to care which fields
|
|
are or are not included. You could wrap that above C<for> loop in a simple
|
|
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
|
|
the character C<`>, to generate SQL like this:
|
|
|
|
SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%'
|
|
|
|
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 escape_char
|
|
|
|
This is the character that will be used to escape L</quote_char>s appearing
|
|
in an identifier before it has been quoted.
|
|
|
|
The parameter default in case of a single L</quote_char> character is the quote
|
|
character itself.
|
|
|
|
When opening-closing-style quoting is used (L</quote_char> is an arrayref)
|
|
this parameter defaults to the B<closing (right)> L</quote_char>. Occurrences
|
|
of the B<opening (left)> L</quote_char> within the identifier are currently left
|
|
untouched. The default for opening-closing-style quotes may change in future
|
|
versions, thus you are B<strongly encouraged> to specify the escape character
|
|
explicitly.
|
|
|
|
=item name_sep
|
|
|
|
This is the character that separates a table and column name. It is
|
|
necessary to specify this when the C<quote_char> option is selected,
|
|
so that tables and column names can be individually quoted like this:
|
|
|
|
SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1
|
|
|
|
=item injection_guard
|
|
|
|
A regular expression C<qr/.../> that is applied to any C<-function> and unquoted
|
|
column name specified in a query structure. This is a safety mechanism to avoid
|
|
injection attacks when mishandling user input e.g.:
|
|
|
|
my %condition_as_column_value_pairs = get_values_from_user();
|
|
$sqla->select( ... , \%condition_as_column_value_pairs );
|
|
|
|
If the expression matches an exception is thrown. Note that literal SQL
|
|
supplied via C<\'...'> or C<\['...']> is B<not> checked in any way.
|
|
|
|
Defaults to checking for C<;> and the C<GO> keyword (TransactSQL)
|
|
|
|
=item array_datatypes
|
|
|
|
When this option is true, arrayrefs in INSERT or UPDATE are
|
|
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).
|
|
|
|
|
|
=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, \%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.
|
|
|
|
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, \%options)
|
|
|
|
This takes a table, hashref of field/value pairs, and an optional
|
|
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.
|
|
|
|
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<returning> option to
|
|
L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
|
|
|
|
=back
|
|
|
|
=head2 select($source, $fields, $where, $order)
|
|
|
|
This returns a SQL SELECT statement and associated list of bind values, as
|
|
specified by the arguments:
|
|
|
|
=over
|
|
|
|
=item $source
|
|
|
|
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 SQL, not quoted).
|
|
|
|
=item $fields
|
|
|
|
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.
|
|
|
|
=item $where
|
|
|
|
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.
|
|
|
|
=item $order
|
|
|
|
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.
|
|
|
|
=back
|
|
|
|
|
|
=head2 delete($table, \%where, \%options)
|
|
|
|
This takes a table name and optional hashref L<WHERE clause|/WHERE CLAUSES>.
|
|
It returns an SQL DELETE statement and list of bind values.
|
|
|
|
The optional C<\%options> hash reference may contain additional
|
|
options to generate the delete SQL. Currently supported options
|
|
are:
|
|
|
|
=over 4
|
|
|
|
=item returning
|
|
|
|
See the C<returning> option to
|
|
L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
|
|
|
|
=back
|
|
|
|
=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.
|
|
|
|
|
|
=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.
|
|
|
|
=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 EXPORTABLE FUNCTIONS
|
|
|
|
=head2 is_plain_value
|
|
|
|
Determines if the supplied argument is a plain value as understood by this
|
|
module:
|
|
|
|
=over
|
|
|
|
=item * The value is C<undef>
|
|
|
|
=item * The value is a non-reference
|
|
|
|
=item * The value is an object with stringification overloading
|
|
|
|
=item * The value is of the form C<< { -value => $anything } >>
|
|
|
|
=back
|
|
|
|
On failure returns C<undef>, on success returns a B<scalar> reference
|
|
to the original supplied argument.
|
|
|
|
=over
|
|
|
|
=item * Note
|
|
|
|
The stringification overloading detection is rather advanced: it takes
|
|
into consideration not only the presence of a C<""> overload, but if that
|
|
fails also checks for enabled
|
|
L<autogenerated versions of C<"">|overload/Magic Autogeneration>, based
|
|
on either C<0+> or C<bool>.
|
|
|
|
Unfortunately testing in the field indicates that this
|
|
detection B<< may tickle a latent bug in perl versions before 5.018 >>,
|
|
but only when very large numbers of stringifying objects are involved.
|
|
At the time of writing ( Sep 2014 ) there is no clear explanation of
|
|
the direct cause, nor is there a manageably small test case that reliably
|
|
reproduces the problem.
|
|
|
|
If you encounter any of the following exceptions in B<random places within
|
|
your application stack> - this module may be to blame:
|
|
|
|
Operation "ne": no method found,
|
|
left argument in overloaded package <something>,
|
|
right argument in overloaded package <something>
|
|
|
|
or perhaps even
|
|
|
|
Stub found while resolving method "???" overloading """" in package <something>
|
|
|
|
If you fall victim to the above - please attempt to reduce the problem
|
|
to something that could be sent to the L<SQL::Abstract developers
|
|
|DBIx::Class/GETTING HELP/SUPPORT>
|
|
(either publicly or privately). As a workaround in the meantime you can
|
|
set C<$ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION}> to a true
|
|
value, which will most likely eliminate your problem (at the expense of
|
|
not being able to properly detect exotic forms of stringification).
|
|
|
|
This notice and environment variable will be removed in a future version,
|
|
as soon as the underlying problem is found and a reliable workaround is
|
|
devised.
|
|
|
|
=back
|
|
|
|
=head2 is_literal_value
|
|
|
|
Determines if the supplied argument is a literal value as understood by this
|
|
module:
|
|
|
|
=over
|
|
|
|
=item * C<\$sql_string>
|
|
|
|
=item * C<\[ $sql_string, @bind_values ]>
|
|
|
|
=back
|
|
|
|
On failure returns C<undef>, on success returns an B<array> reference
|
|
containing the unpacked version of the supplied literal SQL and bind values.
|
|
|
|
=head2 is_undef_value
|
|
|
|
Tests for undef, whether expanded or not.
|
|
|
|
=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
|
|
are AND'ed.>
|
|
|
|
The easiest way to explain is to show lots of examples. After
|
|
each C<%where> hash shown, it is assumed you used:
|
|
|
|
my($stmt, @bind) = $sql->where(\%where);
|
|
|
|
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 = (
|
|
user => 'nwiger',
|
|
status => 'completed'
|
|
);
|
|
|
|
Is converted to SQL C<key = val> statements:
|
|
|
|
$stmt = "WHERE user = ? AND status = ?";
|
|
@bind = ('nwiger', 'completed');
|
|
|
|
One common thing I end up doing is having a list of values that
|
|
a field can be in. To do this, simply specify a list inside of
|
|
an arrayref:
|
|
|
|
my %where = (
|
|
user => 'nwiger',
|
|
status => ['assigned', 'in-progress', 'pending'];
|
|
);
|
|
|
|
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:
|
|
|
|
my %where = (
|
|
user => 'nwiger',
|
|
status => { '!=', 'completed' }
|
|
);
|
|
|
|
Which would generate:
|
|
|
|
$stmt = "WHERE user = ? AND status != ?";
|
|
@bind = ('nwiger', 'completed');
|
|
|
|
To test against multiple values, just enclose the values in an arrayref:
|
|
|
|
status => { '=', ['assigned', 'in-progress', 'pending'] };
|
|
|
|
Which would give you:
|
|
|
|
"WHERE status = ? OR status = ? OR status = ?"
|
|
|
|
|
|
The hashref can also contain multiple pairs, in which case it is expanded
|
|
into an C<AND> of its elements:
|
|
|
|
my %where = (
|
|
user => 'nwiger',
|
|
status => { '!=', 'completed', -not_like => 'pending%' }
|
|
);
|
|
|
|
# Or more dynamically, like from a form
|
|
$where{user} = 'nwiger';
|
|
$where{status}{'!='} = 'completed';
|
|
$where{status}{'-not_like'} = 'pending%';
|
|
|
|
# Both generate this
|
|
$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 }, { '>', 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 reference to an arrayref as the value:
|
|
|
|
my %where = (
|
|
date_entered => { '>' => \["to_date(?, 'MM/DD/YYYY')", "11/26/2008"] },
|
|
date_expires => { '<' => \"now()" }
|
|
);
|
|
|
|
Which would generate:
|
|
|
|
$stmt = "WHERE date_entered > to_date(?, 'MM/DD/YYYY') AND date_expires < now()";
|
|
@bind = ('11/26/2008');
|
|
|
|
|
|
=head2 Logic and nesting operators
|
|
|
|
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 != ?
|
|
|
|
Because, in Perl you I<can't> do this:
|
|
|
|
priority => { '!=' => 2, '!=' => 1 }
|
|
|
|
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} ]
|
|
|
|
|
|
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
|
|
C<logic> option to C<new()> in order to change the way your queries
|
|
work by default.) B<Important:> Note that the C<-modifier> goes
|
|
B<INSIDE> the arrayref, as an extra first element. This will
|
|
B<NOT> do what you think it might:
|
|
|
|
priority => -and => [{'!=', 2}, {'!=', 1}] # WRONG!
|
|
|
|
Here is a quick list of equivalencies, since there is some overlap:
|
|
|
|
# Same
|
|
status => {'!=', 'completed', 'not like', 'pending%' }
|
|
status => [ -and => {'!=', 'completed'}, {'not like', 'pending%'}]
|
|
|
|
# Same
|
|
status => {'=', ['assigned', 'in-progress']}
|
|
status => [ -or => {'=', 'assigned'}, {'=', 'in-progress'}]
|
|
status => [ {'=', 'assigned'}, {'=', 'in-progress'} ]
|
|
|
|
|
|
|
|
=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:
|
|
|
|
my %where = (
|
|
status => 'completed',
|
|
reportid => { -in => [567, 2335, 2] }
|
|
);
|
|
|
|
Which would generate:
|
|
|
|
$stmt = "WHERE status = ? AND reportid IN (?,?,?)";
|
|
@bind = ('completed', '567', '2335', '2');
|
|
|
|
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',
|
|
completion_date => {
|
|
-not_between => ['2002-10-01', '2003-02-06']
|
|
}
|
|
);
|
|
|
|
Would give you:
|
|
|
|
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:
|
|
|
|
my @where = (
|
|
{
|
|
user => 'nwiger',
|
|
status => { -like => ['pending%', 'dispatched'] },
|
|
},
|
|
{
|
|
user => 'robot',
|
|
status => 'unassigned',
|
|
}
|
|
);
|
|
|
|
This data structure would create the following:
|
|
|
|
$stmt = "WHERE ( user = ? AND ( status LIKE ? OR status LIKE ? ) )
|
|
OR ( user = ? AND status = ? ) )";
|
|
@bind = ('nwiger', 'pending', 'dispatched', 'robot', 'unassigned');
|
|
|
|
|
|
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',
|
|
[
|
|
-and => [ workhrs => {'>', 20}, geo => 'ASIA' ],
|
|
-or => { workhrs => {'<', 50}, geo => 'EURO' },
|
|
],
|
|
],
|
|
);
|
|
|
|
That would yield:
|
|
|
|
$stmt = "WHERE ( user = ?
|
|
AND ( ( workhrs > ? AND geo = ? )
|
|
OR ( workhrs < ? OR geo = ? ) ) )";
|
|
@bind = ('nwiger', '20', 'ASIA', '50', 'EURO');
|
|
|
|
=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
|
|
|
|
{ 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 %where = (
|
|
priority => { '<', 2 },
|
|
requestor => { -ident => 'submitter' },
|
|
);
|
|
|
|
which creates:
|
|
|
|
$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.
|
|
|
|
=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 = (
|
|
date_column => \[ "= 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|/where(\%where, $order)>. This 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 => \[ "= date '2008-09-30' - ?::integer", [ {} => 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],
|
|
);
|
|
|
|
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
|
|
module implements the C<WHERE> expansion as a recursive function
|
|
internally). Your best bet is to "play around" with the module a
|
|
little to see how the data structures behave, and choose the best
|
|
format for your data based on that.
|
|
|
|
And of course, all the values above will probably be replaced with
|
|
variables gotten from forms or the command line. After all, if you
|
|
knew everything ahead of time, you wouldn't have to worry about
|
|
dynamically-generating SQL and could just hardwire it into your
|
|
script.
|
|
|
|
=head1 ORDER BY CLAUSES
|
|
|
|
Some functions take an order by clause. This can either be a scalar (just a
|
|
column name), a hashref of C<< { -desc => 'col' } >> or C<< { -asc => 'col' }
|
|
>>, a scalarref, an arrayref-ref, or an arrayref of any of the previous
|
|
forms. Examples:
|
|
|
|
Given | Will Generate
|
|
---------------------------------------------------------------
|
|
|
|
|
'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
|
|
|
|
|
\'colA DESC' | ORDER BY colA DESC
|
|
|
|
|
\[ 'FUNC(colA, ?)', $x ] | ORDER BY FUNC(colA, ?)
|
|
| /* ...with $x bound to ? */
|
|
|
|
|
[ | ORDER BY
|
|
{ -asc => 'colA' }, | colA ASC,
|
|
{ -desc => [qw/colB/] }, | colB DESC,
|
|
{ -asc => [qw/colC colD/] },| colC ASC, colD ASC,
|
|
\'colE DESC', | colE DESC,
|
|
\[ 'FUNC(colF, ?)', $x ], | FUNC(colF, ?)
|
|
] | /* ...with $x bound to ? */
|
|
===============================================================
|
|
|
|
|
|
|
|
=head1 OLD EXTENSION SYSTEM
|
|
|
|
=head2 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:
|
|
|
|
$field is the LHS of the operator
|
|
$op is the part that matched the handler regex
|
|
$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);
|
|
}
|
|
},
|
|
|
|
]);
|
|
|
|
|
|
=head2 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 NEW METHODS (EXPERIMENTAL)
|
|
|
|
See L<SQL::Abstract::Reference> for the C<expr> versus C<aqt> concept and
|
|
an explanation of what the below extensions are extending.
|
|
|
|
=head2 plugin
|
|
|
|
$sqla->plugin('+Foo');
|
|
|
|
Enables plugin SQL::Abstract::Plugin::Foo.
|
|
|
|
=head2 render_expr
|
|
|
|
my ($sql, @bind) = $sqla->render_expr($expr);
|
|
|
|
=head2 render_statement
|
|
|
|
Use this if you may be rendering a top level statement so e.g. a SELECT
|
|
query doesn't get wrapped in parens
|
|
|
|
my ($sql, @bind) = $sqla->render_statement($expr);
|
|
|
|
=head2 expand_expr
|
|
|
|
Expression expansion with optional default for scalars.
|
|
|
|
my $aqt = $self->expand_expr($expr);
|
|
my $aqt = $self->expand_expr($expr, -ident);
|
|
|
|
=head2 render_aqt
|
|
|
|
Top level means avoid parens on statement AQT.
|
|
|
|
my $res = $self->render_aqt($aqt, $top_level);
|
|
my ($sql, @bind) = @$res;
|
|
|
|
=head2 join_query_parts
|
|
|
|
Similar to join() but will render hashrefs as nodes for both join and parts,
|
|
and treats arrayref as a nested C<[ $join, @parts ]> structure.
|
|
|
|
my $part = $self->join_query_parts($join, @parts);
|
|
|
|
=head1 NEW EXTENSION SYSTEM
|
|
|
|
=head2 clone
|
|
|
|
my $sqla2 = $sqla->clone;
|
|
|
|
Performs a semi-shallow copy such that extension methods won't leak state
|
|
but excessive depth is avoided.
|
|
|
|
=head2 expander
|
|
|
|
=head2 expanders
|
|
|
|
=head2 op_expander
|
|
|
|
=head2 op_expanders
|
|
|
|
=head2 clause_expander
|
|
|
|
=head2 clause_expanders
|
|
|
|
$sqla->expander('name' => sub { ... });
|
|
$sqla->expanders('name1' => sub { ... }, 'name2' => sub { ... });
|
|
|
|
=head2 expander_list
|
|
|
|
=head2 op_expander_list
|
|
|
|
=head2 clause_expander_list
|
|
|
|
my @names = $sqla->expander_list;
|
|
|
|
=head2 wrap_expander
|
|
|
|
=head2 wrap_expanders
|
|
|
|
=head2 wrap_op_expander
|
|
|
|
=head2 wrap_op_expanders
|
|
|
|
=head2 wrap_clause_expander
|
|
|
|
=head2 wrap_clause_expanders
|
|
|
|
$sqla->wrap_expander('name' => sub { my ($orig) = @_; sub { ... } });
|
|
$sqla->wrap_expanders(
|
|
'name1' => sub { my ($orig1) = @_; sub { ... } },
|
|
'name2' => sub { my ($orig2) = @_; sub { ... } },
|
|
);
|
|
|
|
=head2 renderer
|
|
|
|
=head2 renderers
|
|
|
|
=head2 op_renderer
|
|
|
|
=head2 op_renderers
|
|
|
|
=head2 clause_renderer
|
|
|
|
=head2 clause_renderers
|
|
|
|
$sqla->renderer('name' => sub { ... });
|
|
$sqla->renderers('name1' => sub { ... }, 'name2' => sub { ... });
|
|
|
|
=head2 renderer_list
|
|
|
|
=head2 op_renderer_list
|
|
|
|
=head2 clause_renderer_list
|
|
|
|
my @names = $sqla->renderer_list;
|
|
|
|
=head2 wrap_renderer
|
|
|
|
=head2 wrap_renderers
|
|
|
|
=head2 wrap_op_renderer
|
|
|
|
=head2 wrap_op_renderers
|
|
|
|
=head2 wrap_clause_renderer
|
|
|
|
=head2 wrap_clause_renderers
|
|
|
|
$sqla->wrap_renderer('name' => sub { my ($orig) = @_; sub { ... } });
|
|
$sqla->wrap_renderers(
|
|
'name1' => sub { my ($orig1) = @_; sub { ... } },
|
|
'name2' => sub { my ($orig2) = @_; sub { ... } },
|
|
);
|
|
|
|
=head2 clauses_of
|
|
|
|
my @clauses = $sqla->clauses_of('select');
|
|
$sqla->clauses_of(select => \@new_clauses);
|
|
$sqla->clauses_of(select => sub {
|
|
my (undef, @old_clauses) = @_;
|
|
...
|
|
return @new_clauses;
|
|
});
|
|
|
|
=head2 statement_list
|
|
|
|
my @list = $sqla->statement_list;
|
|
|
|
=head2 make_unop_expander
|
|
|
|
my $exp = $sqla->make_unop_expander(sub { ... });
|
|
|
|
If the op is found as a binop, assumes it wants a default comparison, so
|
|
the inner expander sub can reliably operate as
|
|
|
|
sub { my ($self, $name, $body) = @_; ... }
|
|
|
|
=head2 make_binop_expander
|
|
|
|
my $exp = $sqla->make_binop_expander(sub { ... });
|
|
|
|
If the op is found as a unop, assumes the value will be an arrayref with the
|
|
LHS as the first entry, and converts that to an ident node if it's a simple
|
|
scalar. So the inner expander sub looks like
|
|
|
|
sub {
|
|
my ($self, $name, $body, $k) = @_;
|
|
{ -blah => [ map $self->expand_expr($_), $k, $body ] }
|
|
}
|
|
|
|
=head2 unop_expander
|
|
|
|
=head2 unop_expanders
|
|
|
|
=head2 binop_expander
|
|
|
|
=head2 binop_expanders
|
|
|
|
The above methods operate exactly like the op_ versions but wrap the coderef
|
|
using the appropriate make_ method first.
|
|
|
|
=head1 PERFORMANCE
|
|
|
|
Thanks to some benchmarking by Mark Stosberg, it turns out that
|
|
this module is many orders of magnitude faster than using C<DBIx::Abstract>.
|
|
I must admit this wasn't an intentional design issue, but it's a
|
|
byproduct of the fact that you get to control your C<DBI> handles
|
|
yourself.
|
|
|
|
To maximize performance, use a code snippet like the following:
|
|
|
|
# prepare a statement handle using the first row
|
|
# and then reuse it for the rest of the rows
|
|
my($sth, $stmt);
|
|
for my $href (@array_of_hashrefs) {
|
|
$stmt ||= $sql->insert('table', $href);
|
|
$sth ||= $dbh->prepare($stmt);
|
|
$sth->execute($sql->values($href));
|
|
}
|
|
|
|
The reason this works is because the keys in your C<$href> are sorted
|
|
internally by B<SQL::Abstract>. Thus, as long as your data retains
|
|
the same structure, you only have to generate the SQL the first time
|
|
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
|
|
really like this part (I do, at least). Building up a complex query
|
|
can be as simple as the following:
|
|
|
|
#!/usr/bin/perl
|
|
|
|
use warnings;
|
|
use strict;
|
|
|
|
use CGI::FormBuilder;
|
|
use SQL::Abstract;
|
|
|
|
my $form = CGI::FormBuilder->new(...);
|
|
my $sql = SQL::Abstract->new;
|
|
|
|
if ($form->submitted) {
|
|
my $field = $form->field;
|
|
my $id = delete $field->{id};
|
|
my($stmt, @bind) = $sql->update('table', $field, {id => $id});
|
|
}
|
|
|
|
Of course, you would still have to connect using C<DBI> to run the
|
|
query, but the point is that if you make your form look like your
|
|
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
|
|
use these three modules together to write complex database query
|
|
apps in under 50 lines.
|
|
|
|
=head1 HOW TO CONTRIBUTE
|
|
|
|
Contributions are always welcome, in all usable forms (we especially
|
|
welcome documentation improvements). The delivery methods include git-
|
|
or unified-diff formatted patches, GitHub pull requests, or plain bug
|
|
reports either via RT or the Mailing list. Contributors are generally
|
|
granted full access to the official repository after their first several
|
|
patches pass successful review.
|
|
|
|
This project is maintained in a git repository. The code and related tools are
|
|
accessible at the following locations:
|
|
|
|
=over
|
|
|
|
=item * Official repo: L<git://git.shadowcat.co.uk/dbsrgits/SQL-Abstract.git>
|
|
|
|
=item * Official gitweb: L<http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/SQL-Abstract.git>
|
|
|
|
=item * GitHub mirror: L<https://github.com/dbsrgits/sql-abstract>
|
|
|
|
=item * Authorized committers: L<ssh://dbsrgits@git.shadowcat.co.uk/SQL-Abstract.git>
|
|
|
|
=back
|
|
|
|
=head1 CHANGES
|
|
|
|
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 *
|
|
|
|
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
|
|
|
|
There are a number of individuals that have really helped out with
|
|
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)
|
|
Philip Collins (per-field SQL functions)
|
|
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", 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>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Copyright (c) 2001-2007 Nathan Wiger <nwiger@cpan.org>. All Rights Reserved.
|
|
|
|
This module is actively maintained by Matt Trout <mst@shadowcatsystems.co.uk>
|
|
|
|
For support, your best bet is to try the C<DBIx::Class> users mailing list.
|
|
While not an official support venue, C<DBIx::Class> makes heavy use of
|
|
C<SQL::Abstract>, and as such list members there are very familiar with
|
|
how to create queries.
|
|
|
|
=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
|