From: Matt S Trout Date: Mon, 16 Apr 2012 01:01:16 +0000 (+0000) Subject: factor out Converter X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a82e41dc8363edb7df67980cdff640bc1a12ce02;p=dbsrgits%2FSQL-Abstract.git factor out Converter --- diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm index d622f39..a8e4a57 100644 --- a/lib/SQL/Abstract.pm +++ b/lib/SQL/Abstract.pm @@ -1,40 +1,14 @@ 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]; @@ -46,10 +20,7 @@ sub puke (@) { Carp::croak "[$func] Fatal: ", @_; } - -#====================================================================== -# NEW -#====================================================================== +has converter => (is => 'lazy', clearer => 'clear_converter'); has case => ( is => 'ro', coerce => sub { $_[0] eq 'lower' ? 'lower' : undef } @@ -65,35 +36,15 @@ has bindtype => ( 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', @@ -110,32 +61,87 @@ has renderer => (is => 'lazy', clearer => 'clear_renderer'); 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 { @@ -154,255 +160,17 @@ 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) = @_; @@ -423,281 +191,9 @@ sub where { 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 } @@ -707,83 +203,6 @@ sub _order_by { } } -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) = @_; @@ -815,6 +234,16 @@ sub _quote { ); } +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 ($) { @@ -871,14 +300,6 @@ sub _sqlcase { 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; @@ -966,20 +387,9 @@ sub generate { } } - -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 diff --git a/lib/SQL/Abstract/Converter.pm b/lib/SQL/Abstract/Converter.pm new file mode 100644 index 0000000..2ce72cf --- /dev/null +++ b/lib/SQL/Abstract/Converter.pm @@ -0,0 +1,638 @@ +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;