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 Carp ();
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
- DQ_WHERE DQ_DELETE DQ_UPDATE DQ_INSERT
-);
-use Data::Query::ExprHelpers qw(perl_scalar_value);
+use Module::Runtime qw(use_module);
use Moo;
-#======================================================================
-# GLOBALS
-#======================================================================
-
our $VERSION = '1.72';
-# This would confuse some packagers
-$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
-
-our $AUTOLOAD;
-
-#======================================================================
-# DEBUGGING AND ERROR REPORTING
-#======================================================================
-
-sub _debug {
- return unless $_[0]->{debug}; shift; # a little faster
- my $func = (caller(1))[3];
- warn "[$func] ", @_, "\n";
-}
+$VERSION = eval $VERSION;
sub belch (@) {
my($func) = (caller(1))[3];
Carp::croak "[$func] Fatal: ", @_;
}
-
-#======================================================================
-# NEW
-#======================================================================
+has converter => (is => 'lazy', clearer => 'clear_converter');
has case => (
is => 'ro', coerce => sub { $_[0] eq 'lower' ? 'lower' : undef }
has cmp => (is => 'ro', default => sub { '=' });
-
- # try to recognize which are the 'equality' and 'unequality' ops
- # (temporary quickfix, should go through a more seasoned API)
-
-has equality_op => (
- is => 'ro', lazy => 1,
- default => sub { qr/^(\Q${\$_[0]->cmp}\E|is|(is\s+)?like)$/i }
-);
-
-has inequality_op => (
- is => 'ro',
- default => sub { qr/^(!=|<>|(is\s+)?not(\s+like)?)$/i }
-);
-
- # SQL booleans
has sqltrue => (is => 'ro', default => sub { '1=1' });
has sqlfalse => (is => 'ro', default => sub { '0=1' });
has special_ops => (is => 'ro', default => sub { [] });
has unary_ops => (is => 'ro', default => sub { [] });
- # 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?
+# FIXME
+# need to guard against ()'s in column names too, but this will break tons of
+# hacks... ideas anyone?
has injection_guard => (
is => 'ro',
has name_sep => (
is => 'rw', default => sub { '.' },
- trigger => sub { shift->clear_renderer },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
);
has quote_char => (
is => 'rw',
- trigger => sub { shift->clear_renderer },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
);
-has always_quote => (is => 'ro', default => sub { 1 });
+has always_quote => (
+ is => 'rw', default => sub { 1 },
+ trigger => sub {
+ $_[0]->clear_renderer;
+ $_[0]->clear_converter;
+ },
+);
has convert => (is => 'ro');
has array_datatypes => (is => 'ro');
-sub _build_renderer {
+has converter_class => (
+ is => 'ro', default => sub { 'SQL::Abstract::Converter' }
+);
+
+has renderer_class => (
+ is => 'ro', default => sub { 'Data::Query::Renderer::SQL::Naive' }
+);
+
+sub _converter_args {
+ my ($self) = @_;
+ Scalar::Util::weaken($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(@_) }
+ }
+ } @{$self->special_ops}
+ ],
+ renderer_will_quote => (
+ defined($self->quote_char) and $self->always_quote
+ ),
+ }
+}
+
+sub _build_converter {
+ my ($self) = @_;
+ use_module($self->converter_class)->new($self->_converter_args);
+}
+
+sub _renderer_args {
my ($self) = @_;
- require Data::Query::Renderer::SQL::Naive;
my ($chars);
for ($self->quote_char) {
$chars = defined() ? (ref() ? $_ : [$_]) : ['',''];
}
- Data::Query::Renderer::SQL::Naive->new({
+ +{
quote_chars => $chars, always_quote => $self->always_quote,
identifier_sep => $self->name_sep,
($self->case ? (lc_keywords => 1) : ()), # always 'lower' if it exists
- });
+ };
+}
+
+sub _build_renderer {
+ my ($self) = @_;
+ use_module($self->renderer_class)->new($self->_renderer_args);
}
sub _render_dq {
sub _render_sqla {
my ($self, $type, @args) = @_;
- $self->_render_dq($self->${\"_${type}_to_dq"}(@args));
-}
-
-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) ]) : ()),
- };
-}
-
-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) = @_;
- $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
-}
-
-sub _ident_to_dq {
- my ($self, $ident) = @_;
- $self->_assert_pass_injection_guard($ident)
- unless $self->renderer->quote_chars->[0] && $self->renderer->always_quote;
- $self->_maybe_convert_dq({
- type => DQ_IDENTIFIER,
- elements => [ split /\Q${\$self->renderer->identifier_sep}/, $ident ],
- });
-}
-
-sub _maybe_convert_dq {
- my ($self, $dq) = @_;
- if (my $c = $self->{where_convert}) {
- +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => 'apply' },
- args => [
- { type => DQ_IDENTIFIER, elements => [ $self->_sqlcase($c) ] },
- $dq
- ]
- };
- } else {
- $dq;
- }
+ $self->_render_dq($self->converter->${\"_${type}_to_dq"}(@args));
}
-sub _op_to_dq {
- my ($self, $op, @args) = @_;
- $self->_assert_pass_injection_guard($op);
- +{
- type => DQ_OPERATOR,
- operator => { 'SQL.Naive' => $op },
- args => \@args
- };
-}
-
-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 { shift->_render_sqla(insert => @_) }
-sub _insert_to_dq {
- my ($self, $table, $data, $options) = @_;
- my (@names, @values);
- if (ref($data) eq 'HASH') {
- @names = sort keys %$data;
- foreach my $k (@names) {
- local our $Cur_Col_Meta = $k;
- push @values, $self->_mutation_rhs_to_dq($data->{$k});
- }
- } elsif (ref($data) eq 'ARRAY') {
- local our $Cur_Col_Meta;
- @values = map $self->_mutation_rhs_to_dq($_), @$data;
- } else {
- die "Not handled yet";
- }
- my $returning;
- if (my $r_source = $options->{returning}) {
- $returning = [
- map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)),
- (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
- ];
- }
- +{
- type => DQ_INSERT,
- target => $self->_table_to_dq($table),
- (@names ? (names => [ map $self->_ident_to_dq($_), @names ]) : ()),
- values => [ \@values ],
- ($returning ? (returning => $returning) : ()),
- };
-}
-
-sub _mutation_rhs_to_dq {
- my ($self, $v) = @_;
- if (ref($v) eq 'ARRAY') {
- if ($self->{array_datatypes}) {
- return $self->_value_to_dq($v);
- }
- $v = \do { my $x = $v };
- }
- if (ref($v) eq 'HASH') {
- my ($op, $arg, @rest) = %$v;
-
- puke 'Operator calls in update/insert must be in the form { -op => $arg }'
- if (@rest or not $op =~ /^\-(.+)/);
- }
- return $self->_expr_to_dq($v);
-}
-
-#======================================================================
-# UPDATE methods
-#======================================================================
-
-
sub update { shift->_render_sqla(update => @_) }
-sub _update_to_dq {
- my ($self, $table, $data, $where) = @_;
-
- puke "Unsupported data type specified to \$sql->update"
- unless ref $data eq 'HASH';
-
- my @set;
-
- foreach my $k (sort keys %$data) {
- my $v = $data->{$k};
- local our $Cur_Col_Meta = $k;
- push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
- }
-
- return +{
- type => DQ_UPDATE,
- target => $self->_table_to_dq($table),
- set => \@set,
- where => $self->_where_to_dq($where),
- };
-}
-
-
-#======================================================================
-# SELECT
-#======================================================================
-
-sub _source_to_dq {
- my ($self, $table, undef, $where) = @_;
-
- my $source_dq = $self->_table_to_dq($table);
-
- if (my $where_dq = $self->_where_to_dq($where)) {
- $source_dq = {
- type => DQ_WHERE,
- from => $source_dq,
- where => $where_dq,
- };
- }
-
- $source_dq;
-}
-
sub select { shift->_render_sqla(select => @_) }
-sub _select_to_dq {
- my $self = shift;
- my ($table, $fields, $where, $order) = @_;
-
- my $source_dq = $self->_source_to_dq(@_);
-
- my $ordered_dq = do {
- if ($order) {
- $self->_order_by_to_dq($order, undef, $source_dq);
- } else {
- $source_dq
- }
- };
-
- return $self->_select_list_to_dq($fields, $ordered_dq);
-}
-
-sub _select_list_to_dq {
- my ($self, $fields, $from_dq) = @_;
-
- $fields ||= '*';
-
- return +{
- type => DQ_SELECT,
- select => [ $self->_select_field_list_to_dq($fields) ],
- from => $from_dq,
- };
-}
-
-sub _select_field_list_to_dq {
- my ($self, $fields) = @_;
- map $self->_select_field_to_dq($_),
- ref($fields) eq 'ARRAY' ? @$fields : $fields;
-}
-
-sub _select_field_to_dq {
- my ($self, $field) = @_;
- ref($field)
- ? $self->_literal_to_dq($$field)
- : $self->_ident_to_dq($field)
-}
-
-#======================================================================
-# DELETE
-#======================================================================
-
-
sub delete { shift->_render_sqla(delete => @_) }
-sub _delete_to_dq {
- my ($self, $table, $where) = @_;
- +{
- type => DQ_DELETE,
- target => $self->_table_to_dq($table),
- where => $self->_where_to_dq($where),
- }
-}
-
-
-#======================================================================
-# WHERE: entry point
-#======================================================================
-
-
-
-# Finally, a separate routine just to handle WHERE clauses
sub where {
my ($self, $where, $order) = @_;
sub _recurse_where { shift->_render_sqla(where => @_) }
-sub _where_to_dq {
- my ($self, $where, $logic) = @_;
-
- return undef unless defined($where);
-
- # turn the convert misfeature on - only used in WHERE clauses
- local $self->{where_convert} = $self->{convert};
-
- return $self->_expr_to_dq($where, $logic);
-}
-
-sub _expr_to_dq {
- my ($self, $where, $logic) = @_;
-
- if (ref($where) eq 'ARRAY') {
- return $self->_expr_to_dq_ARRAYREF($where, $logic);
- } elsif (ref($where) eq 'HASH') {
- return $self->_expr_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 _expr_to_dq_ARRAYREF {
- my ($self, $where, $logic) = @_;
-
- $logic = uc($logic || $self->{logic} || 'OR');
- $logic eq 'AND' or $logic eq 'OR' or puke "unknown logic: $logic";
-
- return unless @$where;
-
- my ($first, @rest) = @$where;
-
- return $self->_expr_to_dq($first) unless @rest;
-
- my $first_dq = do {
- if (!ref($first)) {
- $self->_where_hashpair_to_dq($first => shift(@rest));
- } else {
- $self->_expr_to_dq($first);
- }
- };
-
- return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
-
- $self->_op_to_dq(
- $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic)
- );
-}
-
-sub _expr_to_dq_HASHREF {
- my ($self, $where, $logic) = @_;
-
- $logic = uc($logic) if $logic;
-
- my @dq = map {
- $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic)
- } sort keys %$where;
-
- return $dq[0] unless @dq > 1;
-
- my $final = pop(@dq);
-
- foreach my $dq (reverse @dq) {
- $final = $self->_op_to_dq($logic||'AND', $dq, $final);
- }
-
- return $final;
-}
-
-sub _where_to_dq_SCALAR {
- shift->_value_to_dq(@_);
-}
-
-sub _apply_to_dq {
- my ($self, $op, $v) = @_;
- my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v);
-
- # Ok. Welcome to stupid compat code land. An SQLA expr that would in the
- # absence of this piece of crazy render to:
- #
- # A( B( C( x ) ) )
- #
- # such as
- #
- # { -a => { -b => { -c => $x } } }
- #
- # actually needs to render to:
- #
- # A( B( C x ) )
- #
- # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM.
- #
- # However, we don't want to catch 'A(x)' and turn it into 'A x'
- #
- # So the way we deal with this is to go through all our arguments, and
- # then if the argument is -also- an apply, i.e. at least 'B', we check
- # its arguments - and if there's only one of them, and that isn't an apply,
- # then we convert to the bareword form. The end result should be:
- #
- # A( x ) -> A( x )
- # A( B( x ) ) -> A( B x )
- # A( B( C( x ) ) ) -> A( B( C x ) )
- # A( B( x + y ) ) -> A( B( x + y ) )
- # A( B( x, y ) ) -> A( B( x, y ) )
- #
- # If this turns out not to be quite right, please add additional tests
- # to either 01generate.t or 02where.t *and* update this comment.
-
- foreach my $arg (@args) {
- if (
- $arg->{type} eq DQ_OPERATOR and $arg->{operator}{'SQL.Naive'} eq 'apply'
- and @{$arg->{args}} == 2 and $arg->{args}[1]{type} ne DQ_OPERATOR
- ) {
- $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
- }
- }
- $self->_assert_pass_injection_guard($op);
- return $self->_op_to_dq(
- apply => $self->_ident_to_dq($op), @args
- );
-}
-
-sub _where_hashpair_to_dq {
- my ($self, $k, $v, $logic) = @_;
-
- if ($k =~ /^-(.*)/s) {
- my $op = uc($1);
- if ($op eq 'AND' or $op eq 'OR') {
- return $self->_expr_to_dq($v, $op);
- } elsif ($op eq 'NEST') {
- return $self->_expr_to_dq($v);
- } elsif ($op eq 'NOT') {
- return $self->_op_to_dq(NOT => $self->_expr_to_dq($v));
- } elsif ($op eq 'BOOL') {
- return ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v);
- } elsif ($op eq 'NOT_BOOL') {
- return $self->_op_to_dq(
- NOT => ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v)
- );
- } elsif ($op eq 'IDENT') {
- return $self->_ident_to_dq($v);
- } elsif ($op eq 'VALUE') {
- return $self->_value_to_dq($v);
- } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+/) {
- die "Use of [and|or|nest]_N modifiers is no longer supported";
- } else {
- return $self->_apply_to_dq($op, $v);
- }
- } 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->_expr_to_dq_ARRAYREF([
- map +{ $k => $_ }, @{$v}[1..$#$v]
- ], uc($1));
- }
- return $self->_expr_to_dq_ARRAYREF([
- map +{ $k => $_ }, @$v
- ], $logic);
- } 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->_expr_to_dq_ARRAYREF([
- map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
- ], $logic||'AND');
- }
- my ($op, $value) = %$v;
- s/^-//, s/_/ /g for $op;
- if ($op =~ /^(and|or)$/i) {
- return $self->_expr_to_dq({ $k => $value }, $op);
- } elsif (
- my $special_op = List::Util::first {$op =~ $_->{regex}}
- @{$self->{special_ops}}
- ) {
- return $self->_literal_to_dq(
- [ $self->${\$special_op->{handler}}($k, $op, $value) ]
- );;
- } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
- die "Use of [and|or|nest]_N modifiers is no longer supported";
- }
- (uc($op), $value);
- } else {
- ($self->{cmp}, $v);
- }
- };
- 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 $self->_op_to_dq(
- $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
- );
- }
- return $self->_literal_to_dq($self->{sqlfalse}) unless @$rhs;
- return $self->_op_to_dq(
- $op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs
- )
- } elsif ($op =~ s/^NOT (?!LIKE)//) {
- return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
- } elsif ($op eq 'IDENT') {
- return $self->_op_to_dq(
- $self->{cmp}, $self->_ident_to_dq($k), $self->_ident_to_dq($rhs)
- );
- } elsif ($op eq 'VALUE') {
- return $self->_op_to_dq(
- $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($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 $self->_op_to_dq($null_op, $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->_expr_to_dq_ARRAYREF([
- map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs]
- ], uc($1));
- } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
- die "Use of [and|or|nest]_N modifiers is no longer supported";
- }
- return $self->_expr_to_dq_ARRAYREF([
- map +{ $k => { $op => $_ } }, @$rhs
- ]);
- }
- return $self->_op_to_dq(
- $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs)
- );
- }
-}
-
-#======================================================================
-# ORDER BY
-#======================================================================
-
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, $from) = @_;
-
- return unless $arg;
-
- my $dq = {
- type => DQ_ORDER,
- ($dir ? (direction => $dir) : ()),
- ($from ? (from => $from) : ()),
- };
-
- 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, $from);
- $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, $from);
- } 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 { shift->_render_sqla(table => @_) }
-
-sub _table_to_dq {
- my ($self, $from) = @_;
- if (ref($from) eq 'ARRAY') {
- die "Empty FROM list" unless my @f = @$from;
- my $dq = $self->_table_to_dq(shift @f);
- while (my $x = shift @f) {
- $dq = {
- type => DQ_JOIN,
- join => [ $dq, $self->_table_to_dq($x) ]
- };
- }
- $dq;
- } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
- $self->_literal_to_dq($$from);
- } else {
- $self->_ident_to_dq($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 ($) {
return $_[0]->{case} ? $_[1] : uc($_[1]);
}
-#======================================================================
-# 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;
}
}
-
-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
--- /dev/null
+package SQL::Abstract::Converter;
+
+use Carp ();
+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
+ DQ_WHERE DQ_DELETE DQ_UPDATE DQ_INSERT
+);
+use Data::Query::ExprHelpers qw(perl_scalar_value);
+use Moo;
+
+has renderer_will_quote => (
+ is => 'ro'
+);
+
+has lower_case => (
+ is => 'ro'
+);
+
+has default_logic => (
+ is => 'ro', coerce => sub { uc($_[0]) }, default => sub { 'OR' }
+);
+
+has bind_meta => (
+ is => 'ro', default => sub { 1 }
+);
+
+has cmp => (is => 'ro', default => sub { '=' });
+
+has sqltrue => (is => 'ro', default => sub { '1=1' });
+has sqlfalse => (is => 'ro', default => sub { '0=1' });
+
+has special_ops => (is => 'ro', default => sub { [] });
+
+# XXX documented but I don't current fail any tests not using it
+has unary_ops => (is => 'ro', default => sub { [] });
+
+has injection_guard => (
+ is => 'ro',
+ default => sub {
+ qr/
+ \;
+ |
+ ^ \s* go \s
+ /xmi;
+ }
+);
+
+has identifier_sep => (
+ is => 'ro', default => sub { '.' },
+);
+
+has always_quote => (is => 'ro', default => sub { 1 });
+
+has convert => (is => 'ro');
+
+has array_datatypes => (is => 'ro');
+
+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) ]) : ()),
+ };
+}
+
+sub _bind_to_dq {
+ my ($self, @bind) = @_;
+ return unless @bind;
+ $self->bind_meta
+ ? do {
+ $self->_assert_bindval_matches_bindtype(@bind);
+ map perl_scalar_value(reverse @$_), @bind
+ }
+ : map perl_scalar_value($_), @bind
+}
+
+sub _value_to_dq {
+ my ($self, $value) = @_;
+ $self->_maybe_convert_dq(perl_scalar_value($value, our $Cur_Col_Meta));
+}
+
+sub _ident_to_dq {
+ my ($self, $ident) = @_;
+ $self->_assert_pass_injection_guard($ident)
+ unless $self->renderer_will_quote;
+ $self->_maybe_convert_dq({
+ type => DQ_IDENTIFIER,
+ elements => [ split /\Q${\$self->identifier_sep}/, $ident ],
+ });
+}
+
+sub _maybe_convert_dq {
+ my ($self, $dq) = @_;
+ if (my $c = $self->{where_convert}) {
+ +{
+ type => DQ_OPERATOR,
+ operator => { 'SQL.Naive' => 'apply' },
+ args => [
+ { type => DQ_IDENTIFIER, elements => [ $self->_sqlcase($c) ] },
+ $dq
+ ]
+ };
+ } else {
+ $dq;
+ }
+}
+
+sub _op_to_dq {
+ my ($self, $op, @args) = @_;
+ $self->_assert_pass_injection_guard($op);
+ +{
+ type => DQ_OPERATOR,
+ operator => { 'SQL.Naive' => $op },
+ args => \@args
+ };
+}
+
+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()"
+ }
+}
+
+sub _insert_to_dq {
+ my ($self, $table, $data, $options) = @_;
+ my (@names, @values);
+ if (ref($data) eq 'HASH') {
+ @names = sort keys %$data;
+ foreach my $k (@names) {
+ local our $Cur_Col_Meta = $k;
+ push @values, $self->_mutation_rhs_to_dq($data->{$k});
+ }
+ } elsif (ref($data) eq 'ARRAY') {
+ local our $Cur_Col_Meta;
+ @values = map $self->_mutation_rhs_to_dq($_), @$data;
+ } else {
+ die "Not handled yet";
+ }
+ my $returning;
+ if (my $r_source = $options->{returning}) {
+ $returning = [
+ map +(ref($_) ? $self->_expr_to_dq($_) : $self->_ident_to_dq($_)),
+ (ref($r_source) eq 'ARRAY' ? @$r_source : $r_source),
+ ];
+ }
+ +{
+ type => DQ_INSERT,
+ target => $self->_table_to_dq($table),
+ (@names ? (names => [ map $self->_ident_to_dq($_), @names ]) : ()),
+ values => [ \@values ],
+ ($returning ? (returning => $returning) : ()),
+ };
+}
+
+sub _mutation_rhs_to_dq {
+ my ($self, $v) = @_;
+ if (ref($v) eq 'ARRAY') {
+ if ($self->{array_datatypes}) {
+ return $self->_value_to_dq($v);
+ }
+ $v = \do { my $x = $v };
+ }
+ if (ref($v) eq 'HASH') {
+ my ($op, $arg, @rest) = %$v;
+
+ die 'Operator calls in update/insert must be in the form { -op => $arg }'
+ if (@rest or not $op =~ /^\-(.+)/);
+ }
+ return $self->_expr_to_dq($v);
+}
+
+sub _update_to_dq {
+ my ($self, $table, $data, $where) = @_;
+
+ die "Unsupported data type specified to \$sql->update"
+ unless ref $data eq 'HASH';
+
+ my @set;
+
+ foreach my $k (sort keys %$data) {
+ my $v = $data->{$k};
+ local our $Cur_Col_Meta = $k;
+ push @set, [ $self->_ident_to_dq($k), $self->_mutation_rhs_to_dq($v) ];
+ }
+
+ return +{
+ type => DQ_UPDATE,
+ target => $self->_table_to_dq($table),
+ set => \@set,
+ where => $self->_where_to_dq($where),
+ };
+}
+
+sub _source_to_dq {
+ my ($self, $table, undef, $where) = @_;
+
+ my $source_dq = $self->_table_to_dq($table);
+
+ if (my $where_dq = $self->_where_to_dq($where)) {
+ $source_dq = {
+ type => DQ_WHERE,
+ from => $source_dq,
+ where => $where_dq,
+ };
+ }
+
+ $source_dq;
+}
+
+sub _select_to_dq {
+ my $self = shift;
+ my ($table, $fields, $where, $order) = @_;
+
+ my $source_dq = $self->_source_to_dq(@_);
+
+ my $ordered_dq = do {
+ if ($order) {
+ $self->_order_by_to_dq($order, undef, $source_dq);
+ } else {
+ $source_dq
+ }
+ };
+
+ return $self->_select_list_to_dq($fields, $ordered_dq);
+}
+
+sub _select_list_to_dq {
+ my ($self, $fields, $from_dq) = @_;
+
+ $fields ||= '*';
+
+ return +{
+ type => DQ_SELECT,
+ select => [ $self->_select_field_list_to_dq($fields) ],
+ from => $from_dq,
+ };
+}
+
+sub _select_field_list_to_dq {
+ my ($self, $fields) = @_;
+ map $self->_select_field_to_dq($_),
+ ref($fields) eq 'ARRAY' ? @$fields : $fields;
+}
+
+sub _select_field_to_dq {
+ my ($self, $field) = @_;
+ ref($field)
+ ? $self->_literal_to_dq($$field)
+ : $self->_ident_to_dq($field)
+}
+
+sub _delete_to_dq {
+ my ($self, $table, $where) = @_;
+ +{
+ type => DQ_DELETE,
+ target => $self->_table_to_dq($table),
+ where => $self->_where_to_dq($where),
+ }
+}
+
+sub _where_to_dq {
+ my ($self, $where, $logic) = @_;
+
+ return undef unless defined($where);
+
+ # turn the convert misfeature on - only used in WHERE clauses
+ local $self->{where_convert} = $self->convert;
+
+ return $self->_expr_to_dq($where, $logic);
+}
+
+sub _expr_to_dq {
+ my ($self, $where, $logic) = @_;
+
+ if (ref($where) eq 'ARRAY') {
+ return $self->_expr_to_dq_ARRAYREF($where, $logic);
+ } elsif (ref($where) eq 'HASH') {
+ return $self->_expr_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 _expr_to_dq_ARRAYREF {
+ my ($self, $where, $logic) = @_;
+
+ $logic = uc($logic || $self->default_logic || 'OR');
+ $logic eq 'AND' or $logic eq 'OR' or die "unknown logic: $logic";
+
+ return unless @$where;
+
+ my ($first, @rest) = @$where;
+
+ return $self->_expr_to_dq($first) unless @rest;
+
+ my $first_dq = do {
+ if (!ref($first)) {
+ $self->_where_hashpair_to_dq($first => shift(@rest));
+ } else {
+ $self->_expr_to_dq($first);
+ }
+ };
+
+ return $self->_expr_to_dq_ARRAYREF(\@rest, $logic) unless $first_dq;
+
+ $self->_op_to_dq(
+ $logic, $first_dq, $self->_expr_to_dq_ARRAYREF(\@rest, $logic)
+ );
+}
+
+sub _expr_to_dq_HASHREF {
+ my ($self, $where, $logic) = @_;
+
+ $logic = uc($logic) if $logic;
+
+ my @dq = map {
+ $self->_where_hashpair_to_dq($_ => $where->{$_}, $logic)
+ } sort keys %$where;
+
+ return $dq[0] unless @dq > 1;
+
+ my $final = pop(@dq);
+
+ foreach my $dq (reverse @dq) {
+ $final = $self->_op_to_dq($logic||'AND', $dq, $final);
+ }
+
+ return $final;
+}
+
+sub _where_to_dq_SCALAR {
+ shift->_value_to_dq(@_);
+}
+
+sub _apply_to_dq {
+ my ($self, $op, $v) = @_;
+ my @args = map $self->_expr_to_dq($_), (ref($v) eq 'ARRAY' ? @$v : $v);
+
+ # Ok. Welcome to stupid compat code land. An SQLA expr that would in the
+ # absence of this piece of crazy render to:
+ #
+ # A( B( C( x ) ) )
+ #
+ # such as
+ #
+ # { -a => { -b => { -c => $x } } }
+ #
+ # actually needs to render to:
+ #
+ # A( B( C x ) )
+ #
+ # because SQL sucks, and databases are hateful, and SQLA is Just That DWIM.
+ #
+ # However, we don't want to catch 'A(x)' and turn it into 'A x'
+ #
+ # So the way we deal with this is to go through all our arguments, and
+ # then if the argument is -also- an apply, i.e. at least 'B', we check
+ # its arguments - and if there's only one of them, and that isn't an apply,
+ # then we convert to the bareword form. The end result should be:
+ #
+ # A( x ) -> A( x )
+ # A( B( x ) ) -> A( B x )
+ # A( B( C( x ) ) ) -> A( B( C x ) )
+ # A( B( x + y ) ) -> A( B( x + y ) )
+ # A( B( x, y ) ) -> A( B( x, y ) )
+ #
+ # If this turns out not to be quite right, please add additional tests
+ # to either 01generate.t or 02where.t *and* update this comment.
+
+ foreach my $arg (@args) {
+ if (
+ $arg->{type} eq DQ_OPERATOR and $arg->{operator}{'SQL.Naive'} eq 'apply'
+ and @{$arg->{args}} == 2 and $arg->{args}[1]{type} ne DQ_OPERATOR
+ ) {
+ $arg->{operator}{'SQL.Naive'} = (shift @{$arg->{args}})->{elements}->[0];
+ }
+ }
+ $self->_assert_pass_injection_guard($op);
+ return $self->_op_to_dq(
+ apply => $self->_ident_to_dq($op), @args
+ );
+}
+
+sub _where_hashpair_to_dq {
+ my ($self, $k, $v, $logic) = @_;
+
+ if ($k =~ /^-(.*)/s) {
+ my $op = uc($1);
+ if ($op eq 'AND' or $op eq 'OR') {
+ return $self->_expr_to_dq($v, $op);
+ } elsif ($op eq 'NEST') {
+ return $self->_expr_to_dq($v);
+ } elsif ($op eq 'NOT') {
+ return $self->_op_to_dq(NOT => $self->_expr_to_dq($v));
+ } elsif ($op eq 'BOOL') {
+ return ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v);
+ } elsif ($op eq 'NOT_BOOL') {
+ return $self->_op_to_dq(
+ NOT => ref($v) ? $self->_expr_to_dq($v) : $self->_ident_to_dq($v)
+ );
+ } elsif ($op eq 'IDENT') {
+ return $self->_ident_to_dq($v);
+ } elsif ($op eq 'VALUE') {
+ return $self->_value_to_dq($v);
+ } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+/) {
+ die "Use of [and|or|nest]_N modifiers is no longer supported";
+ } else {
+ return $self->_apply_to_dq($op, $v);
+ }
+ } 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->_expr_to_dq_ARRAYREF([
+ map +{ $k => $_ }, @{$v}[1..$#$v]
+ ], uc($1));
+ }
+ return $self->_expr_to_dq_ARRAYREF([
+ map +{ $k => $_ }, @$v
+ ], $logic);
+ } 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->_expr_to_dq_ARRAYREF([
+ map +{ $k => { $_ => $v->{$_} } }, sort keys %$v
+ ], $logic||'AND');
+ }
+ my ($op, $value) = %$v;
+ s/^-//, s/_/ /g for $op;
+ if ($op =~ /^(and|or)$/i) {
+ return $self->_expr_to_dq({ $k => $value }, $op);
+ } elsif (
+ my $special_op = List::Util::first {$op =~ $_->{regex}}
+ @{$self->{special_ops}}
+ ) {
+ return $self->_literal_to_dq(
+ [ $special_op->{handler}->($k, $op, $value) ]
+ );;
+ } elsif ($op =~ /^(?:AND|OR|NEST)_?\d+$/i) {
+ die "Use of [and|or|nest]_N modifiers is no longer supported";
+ }
+ (uc($op), $value);
+ } else {
+ ($self->{cmp}, $v);
+ }
+ };
+ 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 $self->_op_to_dq(
+ $op, $self->_ident_to_dq($k), $self->_literal_to_dq($$rhs)
+ );
+ }
+ return $self->_literal_to_dq($self->{sqlfalse}) unless @$rhs;
+ return $self->_op_to_dq(
+ $op, $self->_ident_to_dq($k), map $self->_expr_to_dq($_), @$rhs
+ )
+ } elsif ($op =~ s/^NOT (?!LIKE)//) {
+ return $self->_where_hashpair_to_dq(-not => { $k => { $op => $rhs } });
+ } elsif ($op eq 'IDENT') {
+ return $self->_op_to_dq(
+ $self->{cmp}, $self->_ident_to_dq($k), $self->_ident_to_dq($rhs)
+ );
+ } elsif ($op eq 'VALUE') {
+ return $self->_op_to_dq(
+ $self->{cmp}, $self->_ident_to_dq($k), $self->_value_to_dq($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 $self->_op_to_dq($null_op, $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->_expr_to_dq_ARRAYREF([
+ map +{ $k => { $op => $_ } }, @{$rhs}[1..$#$rhs]
+ ], uc($1));
+ } elsif ($op =~ /^-(?:AND|OR|NEST)_?\d+/) {
+ die "Use of [and|or|nest]_N modifiers is no longer supported";
+ }
+ return $self->_expr_to_dq_ARRAYREF([
+ map +{ $k => { $op => $_ } }, @$rhs
+ ]);
+ }
+ return $self->_op_to_dq(
+ $op, $self->_ident_to_dq($k), $self->_expr_to_dq($rhs)
+ );
+ }
+}
+
+sub _order_by_to_dq {
+ my ($self, $arg, $dir, $from) = @_;
+
+ return unless $arg;
+
+ my $dq = {
+ type => DQ_ORDER,
+ ($dir ? (direction => $dir) : ()),
+ ($from ? (from => $from) : ()),
+ };
+
+ 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, $from);
+ $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) {
+ die "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, $from);
+ } else {
+ die "Can't handle $arg in _order_by_to_dq";
+ }
+ return $dq;
+}
+
+sub _table_to_dq {
+ my ($self, $from) = @_;
+ if (ref($from) eq 'ARRAY') {
+ die "Empty FROM list" unless my @f = @$from;
+ my $dq = $self->_table_to_dq(shift @f);
+ while (my $x = shift @f) {
+ $dq = {
+ type => DQ_JOIN,
+ join => [ $dq, $self->_table_to_dq($x) ]
+ };
+ }
+ $dq;
+ } elsif (ref($from) eq 'SCALAR' or (ref($from) eq 'REF')) {
+ $self->_literal_to_dq($$from);
+ } else {
+ $self->_ident_to_dq($from);
+ }
+}
+
+# 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]->bind_meta
+ ? 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->bind_meta) {
+ for (@_) {
+ if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) {
+ die "bindtype 'columns' selected, you need to pass: [column_name => bind_value]"
+ }
+ }
+ }
+}
+
+# Fix SQL case, if so requested
+sub _sqlcase {
+ return $_[0]->lower_case ? $_[1] : uc($_[1]);
+}
+
+1;
projects / dbsrgits/SQL-Abstract.git / commitdiff