package SQL::Abstract; # see doc at end of file
-# LDNOTE : this code is heavy refactoring from original SQLA.
-# Several design decisions will need discussion during
-# the test / diffusion / acceptance phase; those are marked with flag
-# 'LDNOTE' (note by laurent.dami AT free.fr)
+use SQL::Abstract::_TempExtlib;
-use strict;
use Carp ();
-use warnings FATAL => 'all';
use List::Util ();
use Scalar::Util ();
-use Data::Query::Constants qw(
- DQ_IDENTIFIER DQ_OPERATOR DQ_VALUE DQ_LITERAL DQ_JOIN DQ_SELECT DQ_ORDER
-);
-use Data::Query::ExprHelpers qw(perl_scalar_value);
-
-#======================================================================
-# GLOBALS
-#======================================================================
+use Module::Runtime qw(use_module);
+use Moo;
+use namespace::clean;
-our $VERSION = '1.72';
+# DO NOT INCREMENT TO 2.0 WITHOUT COORDINATING WITH mst OR ribasushi
+ our $VERSION = '1.99_01';
+# DO NOT INCREMENT TO 2.0 WITHOUT COORDINATING WITH mst OR ribasushi
# This would confuse some packagers
$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
-our $AUTOLOAD;
-
-# special operators (-in, -between). May be extended/overridden by user.
-# See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation
-my @BUILTIN_SPECIAL_OPS = (
- {regex => qr/^ (?: not \s )? between $/ix, handler => '_where_field_BETWEEN'},
- {regex => qr/^ (?: not \s )? in $/ix, handler => '_where_field_IN'},
- {regex => qr/^ ident $/ix, handler => '_where_op_IDENT'},
- {regex => qr/^ value $/ix, handler => '_where_op_VALUE'},
-);
-
-# unaryish operators - key maps to handler
-my @BUILTIN_UNARY_OPS = (
- # the digits are backcompat stuff
- { regex => qr/^ and (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^ or (?: [_\s]? \d+ )? $/xi, handler => '_where_op_ANDOR' },
- { regex => qr/^ nest (?: [_\s]? \d+ )? $/xi, handler => '_where_op_NEST' },
- { regex => qr/^ (?: not \s )? bool $/xi, handler => '_where_op_BOOL' },
- { regex => qr/^ ident $/xi, handler => '_where_op_IDENT' },
- { regex => qr/^ value $/ix, handler => '_where_op_VALUE' },
-);
-
-#======================================================================
-# DEBUGGING AND ERROR REPORTING
-#======================================================================
-
-sub _debug {
- return unless $_[0]->{debug}; shift; # a little faster
- my $func = (caller(1))[3];
- warn "[$func] ", @_, "\n";
-}
-
sub belch (@) {
my($func) = (caller(1))[3];
Carp::carp "[$func] Warning: ", @_;
Carp::croak "[$func] Fatal: ", @_;
}
+# original SQLA treated anything false as "use the default"
+# in addition a lot of CPAN seems to supply undef's for "use the default"
+# (say hi to Class::DBI::Sweet)
+sub BUILDARGS {
+ my $class = shift;
+ my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ };
-#======================================================================
-# NEW
-#======================================================================
-
-sub new {
- my $self = shift;
- my $class = ref($self) || $self;
- my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
-
- # choose our case by keeping an option around
- delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
-
- # default logic for interpreting arrayrefs
- $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR';
-
- # how to return bind vars
- # LDNOTE: changed nwiger code : why this 'delete' ??
- # $opt{bindtype} ||= delete($opt{bind_type}) || 'normal';
- $opt{bindtype} ||= 'normal';
-
- # default comparison is "=", but can be overridden
- $opt{cmp} ||= '=';
-
- # try to recognize which are the 'equality' and 'unequality' ops
- # (temporary quickfix, should go through a more seasoned API)
- $opt{equality_op} = qr/^(\Q$opt{cmp}\E|is|(is\s+)?like)$/i;
- $opt{inequality_op} = qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i;
-
- # SQL booleans
- $opt{sqltrue} ||= '1=1';
- $opt{sqlfalse} ||= '0=1';
-
- # special operators
- $opt{special_ops} ||= [];
- # regexes are applied in order, thus push after user-defines
- push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
-
- # unary operators
- $opt{unary_ops} ||= [];
- push @{$opt{unary_ops}}, @BUILTIN_UNARY_OPS;
-
- # rudimentary saniy-check for user supplied bits treated as functions/operators
- # If a purported function matches this regular expression, an exception is thrown.
- # Literal SQL is *NOT* subject to this check, only functions (and column names
- # when quoting is not in effect)
-
- # FIXME
- # need to guard against ()'s in column names too, but this will break tons of
- # hacks... ideas anyone?
- $opt{injection_guard} ||= qr/
- \;
- |
- ^ \s* go \s
- /xmi;
-
- $opt{name_sep} ||= '.';
-
- $opt{renderer} ||= do {
- require Data::Query::Renderer::SQL::Naive;
- my ($always, $chars);
- for ($opt{quote_char}) {
- $chars = defined() ? (ref() ? $_ : [$_]) : ['',''];
- $always = defined;
- }
- Data::Query::Renderer::SQL::Naive->new({
- quote_chars => $chars, always_quote => $always,
- });
- };
+ defined $args->{$_} or delete $args->{$_}
+ for keys %$args;
- return bless \%opt, $class;
+ $args;
}
-sub _render_dq {
- my ($self, $dq) = @_;
- my ($sql, @bind) = @{$self->{renderer}->render($dq)};
- wantarray ?
- ($self->{bindtype} eq 'normal'
- ? ($sql, map $_->{value}, @bind)
- : ($sql, map [ $_->{value_meta}, $_->{value} ], @bind)
- )
- : $sql;
+# many subclasses on CPAN assume they can dump a bunch of extra new()
+# parameters, and then get back at them via $obj->{foo}. YAY
+# (Class::DBI::Sweet says hi back)
+sub BUILD {
+ my ($self, $args) = @_;
+ %{$self} = (%$args, %$self);
+ $self;
}
-sub _literal_to_dq {
- my ($self, $literal) = @_;
- my @bind;
- ($literal, @bind) = @$literal if ref($literal) eq 'ARRAY';
- +{
- type => DQ_LITERAL,
- subtype => 'SQL',
- literal => $literal,
- (@bind ? (values => [ $self->_bind_to_dq(@bind) ]) : ()),
- };
-}
+has converter => (is => 'lazy', clearer => 'clear_converter');
-sub _bind_to_dq {
- my ($self, @bind) = @_;
- return unless @bind;
- $self->{bindtype} eq 'normal'
- ? map perl_scalar_value($_), @bind
- : do {
- $self->_assert_bindval_matches_bindtype(@bind);
- map perl_scalar_value(reverse @$_), @bind
- }
-}
-
-sub _value_to_dq {
- my ($self, $value) = @_;
- perl_scalar_value($value, our $Cur_Col_Meta);
-}
+has case => (
+ is => 'ro', coerce => sub { $_[0] eq 'lower' ? 'lower' : undef }
+);
-sub _ident_to_dq {
- my ($self, $ident) = @_;
- +{
- type => DQ_IDENTIFIER,
- elements => [ split /\Q$self->{name_sep}/, $ident ],
- };
-}
+has logic => (
+ is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
+);
-sub _assert_pass_injection_guard {
- if ($_[1] =~ $_[0]->{injection_guard}) {
- my $class = ref $_[0];
- puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the "
- . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own "
- . "{injection_guard} attribute to ${class}->new()"
- }
-}
+has bindtype => (
+ is => 'ro', default => sub { 'normal' }
+);
+has cmp => (is => 'ro', default => sub { '=' });
-#======================================================================
-# INSERT methods
-#======================================================================
+has sqltrue => (is => 'ro', default => sub { '1=1' });
+has sqlfalse => (is => 'ro', default => sub { '0=1' });
-sub insert {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $options = shift;
+has special_ops => (is => 'ro', default => sub { [] });
+has unary_ops => (is => 'ro', default => sub { [] });
- my $method = $self->_METHOD_FOR_refkind("_insert", $data);
- my ($sql, @bind) = $self->$method($data);
- $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
+# FIXME
+# need to guard against ()'s in column names too, but this will break tons of
+# hacks... ideas anyone?
- if ($options->{returning}) {
- my ($s, @b) = $self->_insert_returning ($options);
- $sql .= $s;
- push @bind, @b;
+has injection_guard => (
+ is => 'ro',
+ default => sub {
+ qr/
+ \;
+ |
+ ^ \s* go \s
+ /xmi;
}
+);
- return wantarray ? ($sql, @bind) : $sql;
-}
-
-sub _insert_returning {
- my ($self, $options) = @_;
-
- my $f = $options->{returning};
-
- my $fieldlist = $self->_SWITCH_refkind($f, {
- ARRAYREF => sub {join ', ', map { $self->_quote($_) } @$f;},
- SCALAR => sub {$self->_quote($f)},
- SCALARREF => sub {$$f},
- });
- return $self->_sqlcase(' returning ') . $fieldlist;
-}
-
-sub _insert_HASHREF { # explicit list of fields and then values
- my ($self, $data) = @_;
+has renderer => (is => 'lazy', clearer => 'clear_renderer');
- my @fields = sort keys %$data;
+has name_sep => (
+ is => 'rw', default => sub { '.' },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
- my ($sql, @bind) = $self->_insert_values($data);
+has quote_char => (
+ is => 'rw',
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
- # assemble SQL
- $_ = $self->_quote($_) foreach @fields;
- $sql = "( ".join(", ", @fields).") ".$sql;
+has collapse_aliases => (
+ is => 'ro',
+ default => sub { 0 }
+);
- return ($sql, @bind);
-}
+has always_quote => (
+ is => 'rw', default => sub { 1 },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
-sub _insert_ARRAYREF { # just generate values(?,?) part (no list of fields)
- my ($self, $data) = @_;
+has convert => (is => 'ro');
- # no names (arrayref) so can't generate bindtype
- $self->{bindtype} ne 'columns'
- or belch "can't do 'columns' bindtype when called with arrayref";
+has array_datatypes => (is => 'ro');
- # fold the list of values into a hash of column name - value pairs
- # (where the column names are artificially generated, and their
- # lexicographical ordering keep the ordering of the original list)
- my $i = "a"; # incremented values will be in lexicographical order
- my $data_in_hash = { map { ($i++ => $_) } @$data };
+has converter_class => (
+ is => 'rw', lazy => 1, builder => '_build_converter_class',
+ trigger => sub { shift->clear_converter },
+);
- return $self->_insert_values($data_in_hash);
+sub _build_converter_class {
+ use_module('SQL::Abstract::Converter')
}
-sub _insert_ARRAYREFREF { # literal SQL with bind
- my ($self, $data) = @_;
+has renderer_class => (
+ is => 'rw', lazy => 1, clearer => 1, builder => 1,
+ trigger => sub { shift->clear_renderer },
+);
- my ($sql, @bind) = @${$data};
- $self->_assert_bindval_matches_bindtype(@bind);
+after clear_renderer_class => sub { shift->clear_renderer };
- return ($sql, @bind);
+sub _build_renderer_class {
+ my ($self) = @_;
+ my ($class, @roles) = (
+ $self->_build_base_renderer_class, $self->_build_renderer_roles
+ );
+ return $class unless @roles;
+ return use_module('Moo::Role')->create_class_with_roles($class, @roles);
}
-
-sub _insert_SCALARREF { # literal SQL without bind
- my ($self, $data) = @_;
-
- return ($$data);
+sub _build_base_renderer_class {
+ use_module('Data::Query::Renderer::SQL::Naive')
}
-sub _insert_values {
- my ($self, $data) = @_;
-
- my (@values, @all_bind);
- foreach my $column (sort keys %$data) {
- my $v = $data->{$column};
+sub _build_renderer_roles { () }
- $self->_SWITCH_refkind($v, {
+sub _converter_args {
+ my ($self) = @_;
+ Scalar::Util::weaken($self);
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # if array datatype are activated
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- }
- else { # else literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
+ +{
+ sqla_instance => $self,
+ lower_case => $self->case,
+ default_logic => $self->logic,
+ bind_meta => not($self->bindtype eq 'normal'),
+ identifier_sep => $self->name_sep,
+ (map +($_ => $self->$_), qw(
+ cmp sqltrue sqlfalse injection_guard convert array_datatypes
+ )),
+ special_ops => [
+ map {
+ my $sub = $_->{handler};
+ +{
+ %$_,
+ handler => sub { $self->$sub(@_) }
}
- },
-
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @values, $sql;
- push @all_bind, @bind;
- },
-
- # THINK : anything useful to do with a HASHREF ?
- HASHREF => sub { # (nothing, but old SQLA passed it through)
- #TODO in SQLA >= 2.0 it will die instead
- belch "HASH ref as bind value in insert is not supported";
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
-
- SCALARREF => sub { # literal SQL without bind
- push @values, $$v;
- },
-
- SCALAR_or_UNDEF => sub {
- push @values, '?';
- push @all_bind, $self->_bindtype($column, $v);
- },
-
- });
+ } @{$self->special_ops}
+ ],
+ renderer_will_quote => (
+ defined($self->quote_char) and $self->always_quote
+ ),
+ legacy_convert_handler => ($self->can('_convert') != \&_convert) ? 1 : 0,
}
-
- my $sql = $self->_sqlcase('values')." ( ".join(", ", @values)." )";
- return ($sql, @all_bind);
}
+sub _build_converter {
+ my ($self) = @_;
+ $self->converter_class->new($self->_converter_args);
+}
-
-#======================================================================
-# UPDATE methods
-#======================================================================
-
-
-sub update {
- my $self = shift;
- my $table = $self->_table(shift);
- my $data = shift || return;
- my $where = shift;
-
- # first build the 'SET' part of the sql statement
- my (@set, @all_bind);
- puke "Unsupported data type specified to \$sql->update"
- unless ref $data eq 'HASH';
-
- for my $k (sort keys %$data) {
- my $v = $data->{$k};
- my $r = ref $v;
- my $label = $self->_quote($k);
-
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # array datatype
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- }
- else { # literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- }
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALARREF => sub { # literal SQL without bind
- push @set, "$label = $$v";
- },
- HASHREF => sub {
- my ($op, $arg, @rest) = %$v;
-
- puke 'Operator calls in update must be in the form { -op => $arg }'
- if (@rest or not $op =~ /^\-(.+)/);
-
- local $self->{_nested_func_lhs} = $k;
- my ($sql, @bind) = $self->_where_unary_op ($1, $arg);
-
- push @set, "$label = $sql";
- push @all_bind, @bind;
- },
- SCALAR_or_UNDEF => sub {
- push @set, "$label = ?";
- push @all_bind, $self->_bindtype($k, $v);
- },
- });
- }
-
- # generate sql
- my $sql = $self->_sqlcase('update') . " $table " . $self->_sqlcase('set ')
- . join ', ', @set;
-
- if ($where) {
- my($where_sql, @where_bind) = $self->where($where);
- $sql .= $where_sql;
- push @all_bind, @where_bind;
+sub _renderer_args {
+ my ($self) = @_;
+ my ($chars);
+ for ($self->quote_char) {
+ $chars = defined() ? (ref() ? $_ : [$_]) : ['',''];
}
-
- return wantarray ? ($sql, @all_bind) : $sql;
+ +{
+ quote_chars => $chars, always_quote => $self->always_quote,
+ identifier_sep => $self->name_sep,
+ collapse_aliases => $self->collapse_aliases,
+ ($self->case ? (lc_keywords => 1) : ()), # always 'lower' if it exists
+ };
}
-
-
-
-#======================================================================
-# SELECT
-#======================================================================
-
-
-sub select {
- my $self = shift;
- my $table = shift;
- my $fields = shift || '*';
- my $where = shift;
- my $order = shift;
-
- my($where_sql, @bind) = $self->where($where, $order);
-
- my $sql = $self->_render_dq({
- type => DQ_SELECT,
- select => [
- map $self->_ident_to_dq($_),
- ref($fields) eq 'ARRAY' ? @$fields : $fields
- ],
- from => $self->_table_to_dq($table),
- });
-
- $sql .= $where_sql;
-
- return wantarray ? ($sql, @bind) : $sql;
+sub _build_renderer {
+ my ($self) = @_;
+ $self->renderer_class->new($self->_renderer_args);
}
-#======================================================================
-# DELETE
-#======================================================================
-
-
-sub delete {
- my $self = shift;
- my $table = $self->_table(shift);
- my $where = shift;
-
-
- my($where_sql, @bind) = $self->where($where);
- my $sql = $self->_sqlcase('delete from') . " $table" . $where_sql;
+sub _render_dq {
+ my ($self, $dq) = @_;
+ if (!$dq) {
+ return '';
+ }
+ my ($sql, @bind) = @{$self->renderer->render($dq)};
+ wantarray ?
+ ($self->{bindtype} eq 'normal'
+ ? ($sql, map $_->{value}, @bind)
+ : ($sql, map [ $_->{value_meta}, $_->{value} ], @bind)
+ )
+ : $sql;
+}
- return wantarray ? ($sql, @bind) : $sql;
+sub _render_sqla {
+ my ($self, $type, @args) = @_;
+ $self->_render_dq($self->converter->${\"_${type}_to_dq"}(@args));
}
+sub insert { shift->_render_sqla(insert => @_) }
-#======================================================================
-# WHERE: entry point
-#======================================================================
+sub update { shift->_render_sqla(update => @_) }
+sub select { shift->_render_sqla(select => @_) }
+sub delete { shift->_render_sqla(delete => @_) }
-# Finally, a separate routine just to handle WHERE clauses
sub where {
my ($self, $where, $order) = @_;
return wantarray ? ($sql, @bind) : $sql;
}
-
-sub _recurse_where {
- my ($self, $where, $logic) = @_;
-
- return $self->_render_dq($self->_where_to_dq($where, $logic));
-}
-
-sub _where_to_dq {
- my ($self, $where, $logic) = @_;
-
- if (ref($where) eq 'ARRAY') {
- return $self->_where_to_dq_ARRAYREF($where, $logic);
- } elsif (ref($where) eq 'HASH') {
- return $self->_where_to_dq_HASHREF($where, $logic);
- } elsif (
- ref($where) eq 'SCALAR'
- or (ref($where) eq 'REF' and ref($$where) eq 'ARRAY')
- ) {
- return $self->_literal_to_dq($$where);
- } elsif (!ref($where) or Scalar::Util::blessed($where)) {
- return $self->_value_to_dq($where);
- }
- die "Can't handle $where";
-}
-
-sub _where_to_dq_ARRAYREF {
- my ($self, $where, $logic) = @_;
-
- $logic = uc($logic || 'OR');
- $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
-
- return unless @$where;
-
- my ($first, @rest) = @$where;
-
- return $self->_where_to_dq($first) unless @rest;
-
- my $first_dq = do {
- if (!ref($first)) {
- $self->_where_hashpair_to_dq($first => shift(@rest));
- } else {
- $self->_where_to_dq($first);
- }
- };
-
- return $self->_where_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
-
- +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $logic },
- args => [ $first_dq, $self->_where_to_dq_ARRAYREF(\@rest, $logic) ]
- };
-}
-
-sub _where_to_dq_HASHREF {
- my ($self, $where, $logic) = @_;
-
- $logic = uc($logic || 'AND');
-
- my @dq = map {
- $self->_where_hashpair_to_dq($_ => $where->{$_})
- } sort keys %$where;
-
- return $dq[0] unless @dq > 1;
-
- my $final = pop(@dq);
-
- foreach my $dq (reverse @dq) {
- $final = +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $logic },
- args => [ $dq, $final ]
- }
- }
-
- return $final;
-}
-
-sub _where_to_dq_SCALAR {
- shift->_value_to_dq(@_);
-}
-
-sub _where_op_IDENT {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
- if (ref $rhs) {
- puke "-$op takes a single scalar argument (a quotable identifier)";
- }
-
- # in case we are called as a top level special op (no '=')
- my $lhs = shift;
-
- $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
-
- return $lhs
- ? "$lhs = $rhs"
- : $rhs
- ;
-}
-
-sub _where_op_VALUE {
- my $self = shift;
- my ($op, $rhs) = splice @_, -2;
-
- # in case we are called as a top level special op (no '=')
- my $lhs = shift;
-
- my @bind =
- $self->_bindtype (
- ($lhs || $self->{_nested_func_lhs}),
- $rhs,
- )
- ;
-
- return $lhs
- ? (
- $self->_convert($self->_quote($lhs)) . ' = ' . $self->_convert('?'),
- @bind
- )
- : (
- $self->_convert('?'),
- @bind,
- )
- ;
-}
-
-sub _where_hashpair_to_dq {
- my ($self, $k, $v) = @_;
-
- if ($k =~ /-(.*)/) {
- my $op = uc($1);
- if ($op eq 'AND' or $op eq 'OR') {
- return $self->_where_to_dq($v, $op);
- } elsif ($op eq 'NEST') {
- return $self->_where_to_dq($v);
- } elsif ($op eq 'NOT') {
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => 'NOT' },
- args => [ $self->_where_to_dq($v) ]
- }
- } elsif ($op eq 'BOOL') {
- return ref($v) ? $self->_where_to_dq($v) : $self->_ident_to_dq($v);
- } elsif ($op eq 'NOT_BOOL') {
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => 'NOT' },
- args => [ ref($v) ? $self->_where_to_dq($v) : $self->_ident_to_dq($v) ]
- };
- } else {
- my @args = do {
- if (ref($v) eq 'HASH' and keys(%$v) == 1 and (keys %$v)[0] =~ /-(.*)/) {
- my ($inner) = values %$v;
- +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => uc($1) },
- args => [
- (map $self->_where_to_dq($_),
- (ref($inner) eq 'ARRAY' ? @$inner : $inner))
- ]
- };
- } else {
- (map $self->_where_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v))
- }
- };
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => 'apply' },
- args => [
- $self->_ident_to_dq($op), @args
- ],
- };
- }
- } else {
- local our $Cur_Col_Meta = $k;
- if (ref($v) eq 'ARRAY') {
- if (!@$v) {
- return $self->_literal_to_dq($self->{sqlfalse});
- } elsif (defined($v->[0]) && $v->[0] =~ /-(and|or)/i) {
- return $self->_where_to_dq_ARRAYREF([
- map +{ $k => $_ }, @{$v}[1..$#$v]
- ], uc($1));
- }
- return $self->_where_to_dq_ARRAYREF([
- map +{ $k => $_ }, @$v
- ]);
- } elsif (ref($v) eq 'SCALAR' or (ref($v) eq 'REF' and ref($$v) eq 'ARRAY')) {
- return +{
- type => DQ_LITERAL,
- subtype => 'SQL',
- parts => [ $self->_ident_to_dq($k), $self->_literal_to_dq($$v) ]
- };
- }
- my ($op, $rhs) = do {
- if (ref($v) eq 'HASH') {
- if (keys %$v > 1) {
- return $self->_where_to_dq_ARRAYREF([
- map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
- ], 'AND');
- }
- (uc((keys %$v)[0]), (values %$v)[0]);
- } else {
- ($self->{cmp}, $v);
- }
- };
- s/^-//, s/_/ /g for $op;
- if ($op eq 'BETWEEN' or $op eq 'IN' or $op eq 'NOT IN' or $op eq 'NOT BETWEEN') {
- if (ref($rhs) ne 'ARRAY') {
- if ($op =~ /IN$/) {
- # have to add parens if none present because -in => \"SELECT ..."
- # got documented. mst hates everything.
- if (ref($rhs) eq 'SCALAR') {
- my $x = $$rhs;
- 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
- $rhs = \$x;
- } else {
- my ($x, @rest) = @{$$rhs};
- 1 while ($x =~ s/\A\s*\((.*)\)\s*\Z/$1/s);
- $rhs = \[ $x, @rest ];
- }
- }
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $op },
- args => [ $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs) ]
- };
- }
- return $self->_literal_to_dq($self->{sqlfalse}) unless @$rhs;
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $op },
- args => [ $self->_ident_to_dq($k), map $self->_where_to_dq($_), @$rhs ]
- }
- } elsif ($op =~ s/^NOT (?!LIKE)//) {
- return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
- } elsif (!defined($rhs)) {
- my $null_op = do {
- if ($op eq '=' or $op eq 'LIKE') {
- 'IS NULL'
- } elsif ($op eq '!=') {
- 'IS NOT NULL'
- } else {
- die "Can't do undef -> NULL transform for operator ${op}";
- }
- };
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $null_op },
- args => [ $self->_ident_to_dq($k) ]
- };
- }
- if (ref($rhs) eq 'ARRAY') {
- if (!@$rhs) {
- return $self->_literal_to_dq(
- $op eq '!=' ? $self->{sqltrue} : $self->{sqlfalse}
- );
- } elsif (defined($rhs->[0]) and $rhs->[0] =~ /-(and|or)/i) {
- return $self->_where_to_dq_ARRAYREF([
- map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs]
- ], uc($1));
- }
- return $self->_where_to_dq_ARRAYREF([
- map +{ $k => { $op => $_ } }, @$rhs
- ]);
- }
- return +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $op },
- args => [ $self->_ident_to_dq($k), $self->_where_to_dq($rhs) ]
- }
- }
-}
-
-#======================================================================
-# ORDER BY
-#======================================================================
+sub _recurse_where { shift->_render_sqla(where => @_) }
sub _order_by {
my ($self, $arg) = @_;
- if (my $dq = $self->_order_by_to_dq($arg)) {
+ if (my $dq = $self->converter->_order_by_to_dq($arg)) {
# SQLA generates ' ORDER BY foo'. The hilarity.
wantarray
? do { my @r = $self->_render_dq($dq); $r[0] = ' '.$r[0]; @r }
}
}
-sub _order_by_to_dq {
- my ($self, $arg, $dir) = @_;
-
- return unless $arg;
-
- my $dq = {
- type => DQ_ORDER,
- ($dir ? (direction => $dir) : ()),
- };
-
- if (!ref($arg)) {
- $dq->{by} = $self->_ident_to_dq($arg);
- } elsif (ref($arg) eq 'ARRAY') {
- return unless @$arg;
- local our $Order_Inner unless our $Order_Recursing;
- local $Order_Recursing = 1;
- my ($outer, $inner);
- foreach my $member (@$arg) {
- local $Order_Inner;
- my $next = $self->_order_by_to_dq($member, $dir);
- $outer ||= $next;
- $inner->{from} = $next if $inner;
- $inner = $Order_Inner || $next;
- }
- $Order_Inner = $inner;
- return $outer;
- } elsif (ref($arg) eq 'REF' and ref($$arg) eq 'ARRAY') {
- $dq->{by} = $self->_literal_to_dq($$arg);
- } elsif (ref($arg) eq 'SCALAR') {
- $dq->{by} = $self->_literal_to_dq($$arg);
- } elsif (ref($arg) eq 'HASH') {
- my ($key, $val, @rest) = %$arg;
-
- return unless $key;
-
- if (@rest or not $key =~ /^-(desc|asc)/i) {
- puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
- }
- my $dir = uc $1;
- return $self->_order_by_to_dq($val, $dir);
- } else {
- die "Can't handle $arg in _order_by_to_dq";
- }
- return $dq;
-}
-
-#======================================================================
-# DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
-#======================================================================
-
-sub _table {
- my ($self, $from) = @_;
- $self->_render_dq($self->_table_to_dq($from));
-}
-
-sub _table_to_dq {
- my ($self, $from) = @_;
- $self->_SWITCH_refkind($from, {
- ARRAYREF => sub {
- die "Empty FROM list" unless my @f = @$from;
- my $dq = $self->_ident_to_dq(shift @f);
- while (my $x = shift @f) {
- $dq = {
- type => DQ_JOIN,
- join => [ $dq, $self->_ident_to_dq($x) ]
- };
- }
- $dq;
- },
- SCALAR => sub { $self->_ident_to_dq($from) },
- SCALARREF => sub {
- +{
- type => DQ_LITERAL,
- subtype => 'SQL',
- literal => $$from
- }
- },
- });
-}
-
-
-#======================================================================
-# UTILITY FUNCTIONS
-#======================================================================
-
# highly optimized, as it's called way too often
sub _quote {
# my ($self, $label) = @_;
);
}
+sub _assert_pass_injection_guard {
+ if ($_[1] =~ $_[0]->{injection_guard}) {
+ my $class = ref $_[0];
+ die "Possible SQL injection attempt '$_[1]'. If this is indeed a part of "
+ . "the desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply "
+ . "your own {injection_guard} attribute to ${class}->new()"
+ }
+}
# Conversion, if applicable
sub _convert ($) {
#my ($self, $arg) = @_;
-
-# LDNOTE : modified the previous implementation below because
-# it was not consistent : the first "return" is always an array,
-# the second "return" is context-dependent. Anyway, _convert
-# seems always used with just a single argument, so make it a
-# scalar function.
-# return @_ unless $self->{convert};
-# my $conv = $self->_sqlcase($self->{convert});
-# my @ret = map { $conv.'('.$_.')' } @_;
-# return wantarray ? @ret : $ret[0];
if ($_[0]->{convert}) {
return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
}
# And bindtype
sub _bindtype (@) {
#my ($self, $col, @vals) = @_;
-
- #LDNOTE : changed original implementation below because it did not make
- # sense when bindtype eq 'columns' and @vals > 1.
-# return $self->{bindtype} eq 'columns' ? [ $col, @vals ] : @vals;
-
# called often - tighten code
return $_[0]->{bindtype} eq 'columns'
? map {[$_[1], $_]} @_[2 .. $#_]
}
}
-sub _join_sql_clauses {
- my ($self, $logic, $clauses_aref, $bind_aref) = @_;
-
- if (@$clauses_aref > 1) {
- my $join = " " . $self->_sqlcase($logic) . " ";
- my $sql = '( ' . join($join, @$clauses_aref) . ' )';
- return ($sql, @$bind_aref);
- }
- elsif (@$clauses_aref) {
- return ($clauses_aref->[0], @$bind_aref); # no parentheses
- }
- else {
- return (); # if no SQL, ignore @$bind_aref
- }
-}
-
-
# Fix SQL case, if so requested
sub _sqlcase {
# LDNOTE: if $self->{case} is true, then it contains 'lower', so we
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;
my @all_bind;
foreach my $k ( sort keys %$data ) {
my $v = $data->{$k};
- $self->_SWITCH_refkind($v, {
- ARRAYREF => sub {
- if ($self->{array_datatypes}) { # array datatype
- push @all_bind, $self->_bindtype($k, $v);
- }
- else { # literal SQL with bind
- my ($sql, @bind) = @$v;
- $self->_assert_bindval_matches_bindtype(@bind);
- push @all_bind, @bind;
- }
- },
- ARRAYREFREF => sub { # literal SQL with bind
- my ($sql, @bind) = @${$v};
- $self->_assert_bindval_matches_bindtype(@bind);
- push @all_bind, @bind;
- },
- SCALARREF => sub { # literal SQL without bind
- },
- SCALAR_or_UNDEF => sub {
- push @all_bind, $self->_bindtype($k, $v);
- },
- });
+ local our $Cur_Col_Meta = $k;
+ my ($sql, @bind) = $self->_render_sqla(
+ mutation_rhs => $v
+ );
+ push @all_bind, @bind;
}
return @all_bind;
}
}
-
-sub DESTROY { 1 }
-
-sub AUTOLOAD {
- # This allows us to check for a local, then _form, attr
- my $self = shift;
- my($name) = $AUTOLOAD =~ /.*::(.+)/;
- return $self->generate($name, @_);
-}
-
1;
-
__END__
=head1 NAME
my $sql = SQL::Abstract->new;
- my($stmt, @bind) = $sql->select($table, \@fields, \%where, \@order);
+ my($stmt, @bind) = $sql->select($source, \@fields, \%where, \@order);
my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values);
WHERE name like 'nwiger' AND email like 'nate@wiger.org'
-You can also override the comparsion on an individual basis - see
+You can also override the comparison on an individual basis - see
the huge section on L</"WHERE CLAUSES"> at the bottom.
=item sqltrue, sqlfalse
The argument can be either an arrayref (interpreted as a list
of field names, will be joined by commas and quoted), or a
plain scalar (literal SQL, not quoted).
-Please observe that this API is not as flexible as for
-the first argument C<$table>, for backwards compatibility reasons.
+Please observe that this API is not as flexible as that of
+the first argument C<$source>, for backwards compatibility reasons.
=item $where
)";
@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 = (
-and => [
-bool => 'one',
- -bool => 'two',
- -bool => 'three',
- -not_bool => 'four',
+ -not_bool => { two=> { -rlike => 'bar' } },
+ -not_bool => { three => [ { '=', 2 }, { '>', 5 } ] },
],
);
Would give you:
- WHERE one AND two AND three AND NOT four
+ WHERE
+ one
+ AND
+ (NOT two RLIKE ?)
+ AND
+ (NOT ( three = ? OR three > ? ))
=head2 Nested conditions, -and/-or prefixes
array => [1, 2, 3]
);
-the result would porbably be not what you wanted:
+the result would probably not be what you wanted:
$stmt = 'WHERE array = ? OR array = ? OR array = ?';
@bind = (1, 2, 3);
#!/usr/bin/perl
+ use warnings;
+ use strict;
+
use CGI::FormBuilder;
use SQL::Abstract;
projects / dbsrgits/SQL-Abstract.git / blobdiff