package SQL::Abstract; # see doc at end of file use strict; use warnings; use Carp (); use List::Util (); use Scalar::Util (); use Exporter 'import'; our @EXPORT_OK = qw(is_plain_value is_literal_value is_undef_value); BEGIN { if ($] < 5.009_005) { require MRO::Compat; } else { require mro; } *SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION = $ENV{SQLA_ISVALUE_IGNORE_AUTOGENERATED_STRINGIFICATION} ? sub () { 0 } : sub () { 1 } ; } #====================================================================== # GLOBALS #====================================================================== our $VERSION = '2.000001'; # This would confuse some packagers $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases our $AUTOLOAD; # special operators (-in, -between). May be extended/overridden by user. # See section WHERE: BUILTIN SPECIAL OPERATORS below for implementation my @BUILTIN_SPECIAL_OPS = ( {regex => qr/^ (?: not \s )? between $/ix, handler => sub { die "NOPE" }}, {regex => qr/^ is (?: \s+ not )? $/ix, handler => sub { die "NOPE" }}, {regex => qr/^ (?: not \s )? in $/ix, handler => sub { die "NOPE" }}, {regex => qr/^ ident $/ix, handler => sub { die "NOPE" }}, {regex => qr/^ value $/ix, handler => sub { die "NOPE" }}, ); #====================================================================== # DEBUGGING AND ERROR REPORTING #====================================================================== sub _debug { return unless $_[0]->{debug}; shift; # a little faster my $func = (caller(1))[3]; warn "[$func] ", @_, "\n"; } sub belch (@) { my($func) = (caller(1))[3]; Carp::carp "[$func] Warning: ", @_; } sub puke (@) { my($func) = (caller(1))[3]; Carp::croak "[$func] Fatal: ", @_; } sub is_literal_value ($) { ref $_[0] eq 'SCALAR' ? [ ${$_[0]} ] : ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) ? [ @${ $_[0] } ] : undef; } sub is_undef_value ($) { !defined($_[0]) or ( ref($_[0]) eq 'HASH' and exists $_[0]->{-value} and not defined $_[0]->{-value} ); } # FIXME XSify - this can be done so much more efficiently sub is_plain_value ($) { no strict 'refs'; ! length ref $_[0] ? \($_[0]) : ( ref $_[0] eq 'HASH' and keys %{$_[0]} == 1 and exists $_[0]->{-value} ) ? \($_[0]->{-value}) : ( # reuse @_ for even moar speedz defined ( $_[1] = Scalar::Util::blessed $_[0] ) and # deliberately not using Devel::OverloadInfo - the checks we are # intersted in are much more limited than the fullblown thing, and # this is a very hot piece of code ( # simply using ->can('(""') can leave behind stub methods that # break actually using the overload later (see L and the source of overload::mycan()) # # either has stringification which DBI SHOULD prefer out of the box grep { *{ (qq[${_}::(""]) }{CODE} } @{ $_[2] = mro::get_linear_isa( $_[1] ) } or # has nummification or boolification, AND fallback is *not* disabled ( SQL::Abstract::_ENV_::DETECT_AUTOGENERATED_STRINGIFICATION and ( grep { *{"${_}::(0+"}{CODE} } @{$_[2]} or grep { *{"${_}::(bool"}{CODE} } @{$_[2]} ) and ( # no fallback specified at all ! ( ($_[3]) = grep { *{"${_}::()"}{CODE} } @{$_[2]} ) or # fallback explicitly undef ! defined ${"$_[3]::()"} or # explicitly true !! ${"$_[3]::()"} ) ) ) ) ? \($_[0]) : undef; } #====================================================================== # NEW #====================================================================== our %Defaults = ( expand => { bool => '_expand_bool', row => '_expand_row', op => '_expand_op', func => '_expand_func', values => '_expand_values', list => '_expand_list', }, expand_op => { (map +($_ => __PACKAGE__->make_binop_expander('_expand_between')), qw(between not_between)), (map +($_ => __PACKAGE__->make_binop_expander('_expand_in')), qw(in not_in)), (map +($_ => '_expand_op_andor'), ('and', 'or')), (map +($_ => '_expand_op_is'), ('is', 'is_not')), (map +($_ => __PACKAGE__->make_unop_expander("_expand_${_}")), qw(ident value nest)), bind => __PACKAGE__->make_unop_expander(sub { +{ -bind => $_[2] } }), }, render => { (map +($_, "_render_$_"), qw(op func bind ident literal row values keyword)), }, render_op => { (map +($_ => '_render_op_between'), 'between', 'not_between'), (map +($_ => '_render_op_in'), 'in', 'not_in'), (map +($_ => '_render_unop_postfix'), 'is_null', 'is_not_null', 'asc', 'desc', ), (not => '_render_unop_paren'), (map +($_ => '_render_op_andor'), qw(and or)), ',' => '_render_op_multop', }, clauses_of => { delete => [ qw(target where returning) ], update => [ qw(target set where returning) ], insert => [ qw(target fields from returning) ], select => [ qw(select from where order_by) ], }, expand_clause => { 'delete.from' => '_expand_delete_clause_target', 'update.update' => '_expand_update_clause_target', 'insert.into' => '_expand_insert_clause_target', 'insert.values' => '_expand_insert_clause_from', }, render_clause => { 'delete.target' => '_render_delete_clause_target', 'update.target' => '_render_update_clause_target', 'insert.target' => '_render_insert_clause_target', 'insert.fields' => '_render_insert_clause_fields', 'insert.from' => '_render_insert_clause_from', }, ); foreach my $stmt (keys %{$Defaults{clauses_of}}) { $Defaults{expand}{$stmt} = '_expand_statement'; $Defaults{render}{$stmt} = '_render_statement'; foreach my $clause (@{$Defaults{clauses_of}{$stmt}}) { $Defaults{expand_clause}{"${stmt}.${clause}"} = "_expand_${stmt}_clause_${clause}"; } } sub new { my $self = shift; my $class = ref($self) || $self; my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_; # choose our case by keeping an option around delete $opt{case} if $opt{case} && $opt{case} ne 'lower'; # default logic for interpreting arrayrefs $opt{logic} = $opt{logic} ? uc $opt{logic} : 'OR'; # how to return bind vars $opt{bindtype} ||= 'normal'; # default comparison is "=", but can be overridden $opt{cmp} ||= '='; # try to recognize which are the 'equality' and 'inequality' ops # (temporary quickfix (in 2007), should go through a more seasoned API) $opt{equality_op} = qr/^( \Q$opt{cmp}\E | \= )$/ix; $opt{inequality_op} = qr/^( != | <> )$/ix; $opt{like_op} = qr/^ (is_)?r?like $/xi; $opt{not_like_op} = qr/^ (is_)?not_r?like $/xi; # SQL booleans $opt{sqltrue} ||= '1=1'; $opt{sqlfalse} ||= '0=1'; # special operators $opt{special_ops} ||= []; # unary operators $opt{unary_ops} ||= []; # rudimentary sanity-check for user supplied bits treated as functions/operators # If a purported function matches this regular expression, an exception is thrown. # Literal SQL is *NOT* subject to this check, only functions (and column names # when quoting is not in effect) # FIXME # need to guard against ()'s in column names too, but this will break tons of # hacks... ideas anyone? $opt{injection_guard} ||= qr/ \; | ^ \s* go \s /xmi; $opt{expand_unary} = {}; foreach my $name (sort keys %Defaults) { $opt{$name} = { %{$Defaults{$name}}, %{$opt{$name}||{}} }; } if ($class ne __PACKAGE__) { # check for overriden methods foreach my $type (qw(insert update delete)) { my $method = "_${type}_returning"; if (__PACKAGE__->can($method) ne $class->can($method)) { my $clause = "${type}.returning"; $opt{expand_clause}{$clause} = sub { $_[2] }, $opt{render_clause}{$clause} = sub { [ $_[0]->$method($_[3]) ] }; } } if (__PACKAGE__->can('_table') ne $class->can('_table')) { $opt{expand_clause}{'select.from'} = sub { return +{ -literal => [ $_[0]->_table($_[2]) ] }; }; } if (__PACKAGE__->can('_order_by') ne $class->can('_order_by')) { $opt{expand_clause}{'select.order_by'} = sub { $_[2] }; $opt{render_clause}{'select.order_by'} = sub { [ $_[0]->_order_by($_[2]) ]; }; } if (__PACKAGE__->can('_select_fields') ne $class->can('_select_fields')) { $opt{expand_clause}{'select.select'} = sub { $_[2] }; $opt{render_clause}{'select.select'} = sub { my @super = $_[0]->_select_fields($_[2]); my $effort = [ ref($super[0]) eq 'HASH' ? $_[0]->render_expr($super[0]) : @super ]; return $_[0]->join_query_parts( ' ', { -keyword => 'select' }, $effort ); }; } foreach my $type (qw(in between)) { my $meth = "_where_field_".uc($type); if (__PACKAGE__->can($meth) ne $class->can($meth)) { my $exp = sub { my ($self, $op, $v, $k) = @_; $op = join ' ', split '_', $op; return +{ -literal => [ $self->$meth($k, $op, $v) ] }; }; $opt{expand_op}{$_} = $exp for $type, "not_${type}"; } } if ($class->isa('DBIx::Class::SQLMaker')) { $opt{warn_once_on_nest} = 1; $opt{disable_old_special_ops} = 1; $opt{render_clause}{'select.where'} = sub { my ($sql, @bind) = $_[0]->where($_[2]); s/\A\s+//, s/\s+\Z// for $sql; return [ $sql, @bind ]; }; $opt{expand_op}{ident} = $class->make_unop_expander(sub { my ($self, undef, $body) = @_; $body = $body->from if Scalar::Util::blessed($body); $self->_expand_ident(ident => $body); }); } if ($class->isa('SQL::Abstract::More')) { my $orig = $opt{expand_op}{or}; $opt{expand_op}{or} = sub { my ($self, $logop, $v, $k) = @_; if ($k and ref($v) eq 'ARRAY') { my ($type, $val) = @$v; my $op; if ( ref($type) eq 'HASH' and ref($val) eq 'HASH' and keys %$type == 1 and keys %$val == 1 and (keys %$type)[0] eq (keys %$val)[0] ) { ($op) = keys %$type; ($type) = values %$type; ($val) = values %$val; } if ($self->is_bind_value_with_type(my $v = [ $type, $val ])) { return $self->expand_expr( { $k, map +($op ? { $op => $_ } : $_), { -bind => $v } } ); } } return $self->$orig($logop, $v, $k); }; $opt{render}{bind} = sub { return [ '?', map +(ref($_->[0]) ? $_ : $_->[1]), $_[2] ] }; } } if ($opt{lazy_join_sql_parts}) { require SQL::Abstract::Parts; $opt{join_sql_parts} ||= sub { SQL::Abstract::Parts->new(@_) }; } $opt{join_sql_parts} ||= sub { join $_[0], @_[1..$#_] }; return bless \%opt, $class; } sub _ext_rw { my ($self, $name, $key, $value) = @_; return $self->{$name}{$key} unless @_ > 3; $self->{$name}{$key} = $value; return $self; } sub make_unop_expander { my (undef, $exp) = @_; sub { my ($self, $name, $body, $k) = @_; return $self->_expand_hashpair_cmp($k, { "-${name}" => $body }) if defined($k); return $self->$exp($name, $body); } } sub make_binop_expander { my (undef, $exp) = @_; sub { my ($self, $name, $body, $k) = @_; $k = shift @{$body = [ @$body ]} unless defined $k; $k = ref($k) ? $k : { -ident => $k }; return $self->$exp($name, $body, $k); } } sub plugin { my ($self, $plugin, @args) = @_; unless (ref $plugin) { $plugin =~ s/\A\+/${\__PACKAGE__}::Plugin::/; require(join('/', split '::', $plugin).'.pm'); } $plugin->apply_to($self, @args); return $self; } BEGIN { foreach my $type (qw( expand op_expand render op_render clause_expand clause_render )) { my $name = join '_', reverse split '_', $type; my $singular = "${type}er"; eval qq{sub ${singular} { my \$self = shift; return \$self->_ext_rw('${name}', \@_) if \@_ == 1; return \$self->${singular}s(\@_) }; 1 } or die "Method builder failed for ${singular}: $@"; eval qq{sub wrap_${singular} { shift->wrap_${singular}s(\@_) }; 1 } or die "Method builder failed for wrap_${singular}: $@"; eval qq{sub ${singular}s { my (\$self, \@args) = \@_; while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { \$self->_ext_rw('${name}', \$this_key, \$this_value); } return \$self; }; 1 } or die "Method builder failed for ${singular}s: $@"; eval qq{sub wrap_${singular}s { my (\$self, \@args) = \@_; while (my (\$this_key, \$this_builder) = splice(\@args, 0, 2)) { my \$orig = \$self->_ext_rw('${name}', \$this_key); \$self->_ext_rw( '${name}', \$this_key, \$this_builder->(\$orig, '${name}', \$this_key), ); } return \$self; }; 1 } or die "Method builder failed for wrap_${singular}s: $@"; eval qq{sub ${singular}_list { sort keys %{\$_[0]->{\$name}} }; 1; } or die "Method builder failed for ${singular}_list: $@"; } foreach my $singular (qw(unop_expander binop_expander)) { eval qq{sub ${singular} { shift->${singular}s(\@_) }; 1 } or die "Method builder failed for ${singular}: $@"; eval qq{sub ${singular}s { my (\$self, \@args) = \@_; while (my (\$this_key, \$this_value) = splice(\@args, 0, 2)) { \$self->_ext_rw( expand_op => \$this_key, \$self->make_${singular}(\$this_value), ); } return \$self; }; 1 } or die "Method builder failed for ${singular}s: $@"; } } #sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] } sub statement_list { sort keys %{$_[0]->{clauses_of}} } sub clauses_of { my ($self, $of, @clauses) = @_; unless (@clauses) { return @{$self->{clauses_of}{$of}||[]}; } if (ref($clauses[0]) eq 'CODE') { @clauses = $self->${\($clauses[0])}(@{$self->{clauses_of}{$of}||[]}); } $self->{clauses_of}{$of} = \@clauses; return $self; } sub clone { my ($self) = @_; bless( { (map +($_ => ( ref($self->{$_}) eq 'HASH' ? { %{$self->{$_}} } : $self->{$_} )), keys %$self), }, ref($self) ); } sub sqltrue { +{ -literal => [ $_[0]->{sqltrue} ] } } sub sqlfalse { +{ -literal => [ $_[0]->{sqlfalse} ] } } sub _assert_pass_injection_guard { if ($_[1] =~ $_[0]->{injection_guard}) { my $class = ref $_[0]; puke "Possible SQL injection attempt '$_[1]'. If this is indeed a part of the " . "desired SQL use literal SQL ( \'...' or \[ '...' ] ) or supply your own " . "{injection_guard} attribute to ${class}->new()" } } #====================================================================== # INSERT methods #====================================================================== sub insert { my ($self, $table, $data, $options) = @_; my $stmt = do { if (ref($table) eq 'HASH') { $table; } else { my %clauses = (target => $table, values => $data, %{$options||{}}); \%clauses; } }; my @rendered = $self->render_statement({ -insert => $stmt }); return wantarray ? @rendered : $rendered[0]; } sub _expand_insert_clause_target { +(target => $_[0]->expand_expr($_[2], -ident)); } sub _expand_insert_clause_fields { return +{ -row => [ $_[0]->expand_expr({ -list => $_[2] }, -ident) ] } if ref($_[2]) eq 'ARRAY'; return $_[2]; # should maybe still expand somewhat? } sub _expand_insert_clause_from { my ($self, undef, $data) = @_; if (ref($data) eq 'HASH' and (keys(%$data))[0] =~ /^-/) { return $self->expand_expr($data); } my ($f_aqt, $v_aqt) = $self->_expand_insert_values($data); return ( from => { -values => [ $v_aqt ] }, ($f_aqt ? (fields => $f_aqt) : ()), ); } sub _expand_insert_clause_returning { +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } sub _expand_insert_values { my ($self, $data) = @_; if (is_literal_value($data)) { (undef, $self->expand_expr($data)); } else { my ($fields, $values) = ( ref($data) eq 'HASH' ? ([ sort keys %$data ], [ @{$data}{sort keys %$data} ]) : ([], $data) ); # no names (arrayref) means can't generate bindtype !($fields) && $self->{bindtype} eq 'columns' && belch "can't do 'columns' bindtype when called with arrayref"; +( (@$fields ? $self->expand_expr({ -row => $fields }, -ident) : undef ), +{ -row => [ map { local our $Cur_Col_Meta = $fields->[$_]; $self->_expand_insert_value($values->[$_]) } 0..$#$values ] }, ); } } sub _render_insert_clause_fields { return $_[0]->render_aqt($_[2]); } sub _render_insert_clause_target { my ($self, undef, $from) = @_; $self->join_query_parts(' ', { -keyword => 'insert into' }, $from); } sub _render_insert_clause_from { return $_[0]->render_aqt($_[2], 1); } # So that subclasses can override INSERT ... RETURNING separately from # UPDATE and DELETE (e.g. DBIx::Class::SQLMaker::Oracle does this) sub _insert_returning { shift->_returning(@_) } sub _redispatch_returning { my ($self, $type, undef, $returning) = @_; [ $self->${\"_${type}_returning"}({ returning => $returning }) ]; } sub _returning { my ($self, $options) = @_; my $f = $options->{returning}; my ($sql, @bind) = @{ $self->render_aqt( $self->expand_expr({ -list => $f }, -ident) ) }; my $rsql = $self->_sqlcase(' returning ').$sql; return wantarray ? ($rsql, @bind) : $rsql; } sub _expand_insert_value { my ($self, $v) = @_; my $k = our $Cur_Col_Meta; if (ref($v) eq 'ARRAY') { if ($self->{array_datatypes}) { return +{ -bind => [ $k, $v ] }; } my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); return +{ -literal => $v }; } if (ref($v) eq 'HASH') { if (grep !/^-/, keys %$v) { belch "HASH ref as bind value in insert is not supported"; return +{ -bind => [ $k, $v ] }; } } if (!defined($v)) { return +{ -bind => [ $k, undef ] }; } return $self->expand_expr($v); } #====================================================================== # UPDATE methods #====================================================================== sub update { my ($self, $table, $set, $where, $options) = @_; my $stmt = do { if (ref($table) eq 'HASH') { $table } else { my %clauses; @clauses{qw(target set where)} = ($table, $set, $where); puke "Unsupported data type specified to \$sql->update" unless ref($clauses{set}) eq 'HASH'; @clauses{keys %$options} = values %$options; \%clauses; } }; my @rendered = $self->render_statement({ -update => $stmt }); return wantarray ? @rendered : $rendered[0]; } sub _render_update_clause_target { my ($self, undef, $target) = @_; $self->join_query_parts(' ', { -keyword => 'update' }, $target); } sub _update_set_values { my ($self, $data) = @_; return @{ $self->render_aqt( $self->_expand_update_set_values(undef, $data), ) }; } sub _expand_update_set_values { my ($self, undef, $data) = @_; $self->expand_expr({ -list => [ map { my ($k, $set) = @$_; $set = { -bind => $_ } unless defined $set; +{ -op => [ '=', { -ident => $k }, $set ] }; } map { my $k = $_; my $v = $data->{$k}; (ref($v) eq 'ARRAY' ? ($self->{array_datatypes} ? [ $k, +{ -bind => [ $k, $v ] } ] : [ $k, +{ -literal => $v } ]) : do { local our $Cur_Col_Meta = $k; [ $k, $self->_expand_expr($v) ] } ); } sort keys %$data ] }); } sub _expand_update_clause_target { my ($self, undef, $target) = @_; +(target => $self->expand_expr({ -list => $target }, -ident)); } sub _expand_update_clause_set { return $_[2] if ref($_[2]) eq 'HASH' and ($_[2]->{-op}||[''])->[0] eq ','; +(set => $_[0]->_expand_update_set_values($_[1], $_[2])); } sub _expand_update_clause_where { +(where => $_[0]->expand_expr($_[2])); } sub _expand_update_clause_returning { +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } # So that subclasses can override UPDATE ... RETURNING separately from # INSERT and DELETE sub _update_returning { shift->_returning(@_) } #====================================================================== # SELECT #====================================================================== sub select { my ($self, @args) = @_; my $stmt = do { if (ref(my $sel = $args[0]) eq 'HASH') { $sel } else { my %clauses; @clauses{qw(from select where order_by)} = @args; # This oddity is to literalify since historically SQLA doesn't quote # a single identifier argument, so we convert it into a literal $clauses{select} = { -literal => [ $clauses{select}||'*' ] } unless ref($clauses{select}); \%clauses; } }; my @rendered = $self->render_statement({ -select => $stmt }); return wantarray ? @rendered : $rendered[0]; } sub _expand_select_clause_select { my ($self, undef, $select) = @_; +(select => $self->expand_expr({ -list => $select }, -ident)); } sub _expand_select_clause_from { my ($self, undef, $from) = @_; +(from => $self->expand_expr({ -list => $from }, -ident)); } sub _expand_select_clause_where { my ($self, undef, $where) = @_; my $sqla = do { if (my $conv = $self->{convert}) { my $_wrap = sub { my $orig = shift; sub { my $self = shift; +{ -func => [ $conv, $self->$orig(@_) ] }; }; }; $self->clone ->wrap_expander(bind => $_wrap) ->wrap_op_expanders(map +($_ => $_wrap), qw(ident value)) ->wrap_expander(func => sub { my $orig = shift; sub { my ($self, $type, $thing) = @_; if (ref($thing) eq 'ARRAY' and $thing->[0] eq $conv and @$thing == 2 and ref($thing->[1]) eq 'HASH' and ( $thing->[1]{-ident} or $thing->[1]{-value} or $thing->[1]{-bind}) ) { return { -func => $thing }; # already went through our expander } return $self->$orig($type, $thing); } }); } else { $self; } }; return +(where => $sqla->expand_expr($where)); } sub _expand_select_clause_order_by { my ($self, undef, $order_by) = @_; +(order_by => $self->_expand_order_by($order_by)); } sub _select_fields { my ($self, $fields) = @_; return $fields unless ref($fields); my ($sql, @bind) = @{ $self->render_aqt( $self->expand_expr({ -list => $fields }, '-ident') ) }; return wantarray ? ($sql, @bind) : $sql; } #====================================================================== # DELETE #====================================================================== sub delete { my ($self, $table, $where, $options) = @_; my $stmt = do { if (ref($table) eq 'HASH') { $table; } else { my %clauses = (target => $table, where => $where, %{$options||{}}); \%clauses; } }; my @rendered = $self->render_statement({ -delete => $stmt }); return wantarray ? @rendered : $rendered[0]; } # So that subclasses can override DELETE ... RETURNING separately from # INSERT and UPDATE sub _delete_returning { shift->_returning(@_) } sub _expand_delete_clause_target { +(target => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); } sub _expand_delete_clause_returning { +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident)); } sub _render_delete_clause_target { my ($self, undef, $from) = @_; $self->join_query_parts(' ', { -keyword => 'delete from' }, $from); } #====================================================================== # WHERE: entry point #====================================================================== # Finally, a separate routine just to handle WHERE clauses sub where { my ($self, $where, $order) = @_; local $self->{convert_where} = $self->{convert}; # where ? my ($sql, @bind) = defined($where) ? $self->_recurse_where($where) : (undef); $sql = (defined $sql and length $sql) ? $self->_sqlcase(' where ') . "( $sql )" : ''; # order by? if ($order) { my ($order_sql, @order_bind) = $self->_order_by($order); $sql .= $order_sql; push @bind, @order_bind; } return wantarray ? ($sql, @bind) : $sql; } { our $Default_Scalar_To = -value } sub expand_expr { my ($self, $expr, $default_scalar_to) = @_; local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to; $self->_expand_expr($expr); } sub render_aqt { my ($self, $aqt, $top_level) = @_; my ($k, $v, @rest) = %$aqt; die "No" if @rest; die "Not a node type: $k" unless $k =~ s/^-//; if (my $meth = $self->{render}{$k}) { local our $Render_Top_Level = $top_level; return $self->$meth($k, $v)||[]; } die "notreached: $k"; } sub render_expr { my ($self, $expr, $default_scalar_to) = @_; return @{ $self->render_aqt( $self->expand_expr($expr, $default_scalar_to) ) }; } sub render_statement { my ($self, $expr, $default_scalar_to) = @_; @{$self->render_aqt( $self->expand_expr($expr, $default_scalar_to), 1 )}; } sub _expand_statement { my ($self, $type, $args) = @_; my $ec = $self->{expand_clause}; if ($args->{_}) { $args = { %$args }; $args->{$type} = delete $args->{_} } my %has_clause = map +($_ => 1), @{$self->{clauses_of}{$type}}; return +{ "-${type}" => +{ map { my $val = $args->{$_}; if (defined($val) and my $exp = $ec->{"${type}.$_"}) { if ((my (@exp) = $self->$exp($_ => $val)) == 1) { ($_ => $exp[0]) } else { @exp } } elsif ($has_clause{$_}) { ($_ => $self->expand_expr($val)) } else { ($_ => $val) } } sort keys %$args } }; } sub _render_statement { my ($self, $type, $args) = @_; my @parts; foreach my $clause (@{$self->{clauses_of}{$type}}) { next unless my $clause_expr = $args->{$clause}; my $part = do { if (my $rdr = $self->{render_clause}{"${type}.${clause}"}) { $self->$rdr($clause, $clause_expr, $args); } else { my $r = $self->render_aqt($clause_expr, 1); next unless defined $r->[0] and length $r->[0]; $self->join_query_parts(' ', { -keyword => $clause }, $r ); } }; push @parts, $part; } my $q = $self->join_query_parts(' ', @parts); return $self->join_query_parts('', (our $Render_Top_Level ? $q : ('(', $q, ')')) ); } sub _normalize_op { my ($self, $raw) = @_; my $op = lc $raw; return $op if grep $_->{$op}, @{$self}{qw(expand_op render_op)}; s/^-(?=.)//, s/\s+/_/g for $op; $op; } sub _expand_expr { my ($self, $expr) = @_; our $Expand_Depth ||= 0; local $Expand_Depth = $Expand_Depth + 1; return undef unless defined($expr); if (ref($expr) eq 'HASH') { return undef unless my $kc = keys %$expr; if ($kc > 1) { return $self->_expand_logop(and => $expr); } my ($key, $value) = %$expr; if ($key =~ /^-/ and $key =~ s/ [_\s]? \d+ $//x ) { belch 'Use of [and|or|nest]_N modifiers is deprecated and will be removed in SQLA v2.0. ' . "You probably wanted ...-and => [ $key => COND1, $key => COND2 ... ]"; } return $self->_expand_hashpair($key, $value); } if (ref($expr) eq 'ARRAY') { return $self->_expand_logop(lc($self->{logic}), $expr); } if (my $literal = is_literal_value($expr)) { return +{ -literal => $literal }; } if (!ref($expr) or Scalar::Util::blessed($expr)) { return $self->_expand_scalar($expr); } die "notreached"; } sub _expand_hashpair { my ($self, $k, $v) = @_; unless (defined($k) and length($k)) { if (defined($k) and my $literal = is_literal_value($v)) { belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; return { -literal => $literal }; } puke "Supplying an empty left hand side argument is not supported"; } if ($k =~ /^-./) { return $self->_expand_hashpair_op($k, $v); } elsif ($k =~ /^\W+$/) { my ($lhs, @rhs) = ref($v) eq 'ARRAY' ? @$v : $v; return $self->_expand_op( -op, [ $k, $self->expand_expr($lhs, -ident), @rhs ] ); } return $self->_expand_hashpair_ident($k, $v); } sub _expand_hashpair_ident { my ($self, $k, $v) = @_; local our $Cur_Col_Meta = $k; # hash with multiple or no elements is andor if (ref($v) eq 'HASH' and keys %$v != 1) { return $self->_expand_logop(and => $v, $k); } # undef needs to be re-sent with cmp to achieve IS/IS NOT NULL if (is_undef_value($v)) { return $self->_expand_hashpair_cmp($k => undef); } # scalars and objects get expanded as whatever requested or values if (!ref($v) or Scalar::Util::blessed($v)) { return $self->_expand_hashpair_scalar($k, $v); } # single key hashref is a hashtriple if (ref($v) eq 'HASH') { return $self->_expand_hashtriple($k, %$v); } # arrayref needs re-engineering over the elements if (ref($v) eq 'ARRAY') { return $self->sqlfalse unless @$v; $self->_debug("ARRAY($k) means distribute over elements"); my $logic = lc( ($v->[0]||'') =~ /^-(and|or)$/i ? (shift(@{$v = [ @$v ]}), $1) : lc($self->{logic} || 'OR') ); return $self->_expand_logop( $logic => $v, $k ); } if (my $literal = is_literal_value($v)) { unless (length $k) { belch 'Hash-pairs consisting of an empty string with a literal are deprecated, and will be removed in 2.0: use -and => [ $literal ] instead'; return \$literal; } my ($sql, @bind) = @$literal; if ($self->{bindtype} eq 'columns') { for (@bind) { $self->_assert_bindval_matches_bindtype($_); } } return +{ -literal => [ $self->_quote($k).' '.$sql, @bind ] }; } die "notreached"; } sub _expand_scalar { my ($self, $expr) = @_; return $self->_expand_expr({ (our $Default_Scalar_To) => $expr }); } sub _expand_hashpair_scalar { my ($self, $k, $v) = @_; return $self->_expand_hashpair_cmp( $k, $self->_expand_scalar($v), ); } sub _expand_hashpair_op { my ($self, $k, $v) = @_; $self->_assert_pass_injection_guard($k =~ /\A-(.*)\Z/s); my $op = $self->_normalize_op($k); my $wsop = join(' ', split '_', $op); my $is_special = List::Util::first { $wsop =~ $_->{regex} } @{$self->{special_ops}}; { # Old SQLA compat # the old special op system requires illegality for top-level use if ( (our $Expand_Depth) == 1 and ( $is_special or ( $self->{disable_old_special_ops} and List::Util::first { $wsop =~ $_->{regex} } @BUILTIN_SPECIAL_OPS ) ) ) { puke "Illegal use of top-level '-$wsop'" } } if (my $exp = $self->{expand}{$op}||$self->{expand_op}{$op}) { return $self->$exp($op, $v); } if ($self->{render}{$op}) { return { "-${op}" => $v }; } # Ops prefixed with -not_ get converted if (my ($rest) = $op =~/^not_(.*)$/) { return +{ -op => [ 'not', $self->_expand_expr({ "-${rest}", $v }) ] }; } { # Old SQLA compat # the old unary op system means we should touch nothing and let it work my $op = join(' ', split '_', $op); if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { return { -op => [ $op, $v ] }; } } my $type = $is_special || $self->{render_op}{$op} ? -op : -func; if ($self->{restore_old_unop_handling}) { # Old SQLA compat if ( ref($v) eq 'HASH' and keys %$v == 1 and (keys %$v)[0] =~ /^-/ and not $self->{render_op}{$op} and not $is_special ) { $type = -func; } else { $type = -op; } } if ($type eq -func and ref($v) eq 'ARRAY') { return $self->_expand_expr({ -func => [ $op, @$v ] }); } return $self->_expand_expr({ $type => [ $op, $v ] }); } sub _expand_hashpair_cmp { my ($self, $k, $v) = @_; $self->_expand_hashtriple($k, $self->{cmp}, $v); } sub _expand_hashtriple { my ($self, $k, $vk, $vv) = @_; my $ik = $self->_expand_expr({ -ident => $k }); my $op = $self->_normalize_op($vk); $self->_assert_pass_injection_guard($op); if ($op =~ s/ _? \d+ $//x ) { return $self->_expand_expr($k, { $vk, $vv }); } if (my $x = $self->{expand_op}{$op}) { local our $Cur_Col_Meta = $k; return $self->$x($op, $vv, $k); } { # Old SQLA compat my $op = join(' ', split '_', $op); if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) { return { -op => [ $op, $ik, $vv ] }; } if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { return { -op => [ $self->{cmp}, $ik, { -op => [ $op, $vv ] } ] }; } } if (ref($vv) eq 'ARRAY') { my @raw = @$vv; my $logic = (defined($raw[0]) and $raw[0] =~ /^-(and|or)$/i) ? (shift(@raw), lc $1) : 'or'; my @values = map +{ $vk => $_ }, @raw; if ( $op =~ $self->{inequality_op} or $op =~ $self->{not_like_op} ) { if (lc($logic) eq 'or' and @values > 1) { belch "A multi-element arrayref as an argument to the inequality op '${\uc(join ' ', split '_', $op)}' " . 'is technically equivalent to an always-true 1=1 (you probably wanted ' . "to say ...{ \$inequality_op => [ -and => \@values ] }... instead)" ; } } unless (@values) { # try to DWIM on equality operators return ($self->_dwim_op_to_is($op, "Supplying an empty arrayref to '%s' is deprecated", "operator '%s' applied on an empty array (field '$k')" ) ? $self->sqlfalse : $self->sqltrue); } return $self->_expand_logop($logic => \@values, $k); } if (is_undef_value($vv)) { my $is = ($self->_dwim_op_to_is($op, "Supplying an undefined argument to '%s' is deprecated", "unexpected operator '%s' with undef operand", ) ? 'is' : 'is not'); return $self->_expand_hashpair($k => { $is, undef }); } local our $Cur_Col_Meta = $k; return +{ -op => [ $op, $ik, $self->_expand_expr($vv) ] }; } sub _dwim_op_to_is { my ($self, $raw, $empty, $fail) = @_; my $op = $self->_normalize_op($raw); if ($op =~ /^not$/i) { return 0; } if ($op =~ $self->{equality_op}) { return 1; } if ($op =~ $self->{like_op}) { belch(sprintf $empty, uc(join ' ', split '_', $op)); return 1; } if ($op =~ $self->{inequality_op}) { return 0; } if ($op =~ $self->{not_like_op}) { belch(sprintf $empty, uc(join ' ', split '_', $op)); return 0; } puke(sprintf $fail, $op); } sub _expand_func { my ($self, undef, $args) = @_; my ($func, @args) = @$args; return +{ -func => [ $func, map $self->expand_expr($_), @args ] }; } sub _expand_ident { my ($self, undef, $body) = @_; unless (defined($body) or (ref($body) and ref($body) eq 'ARRAY')) { puke "-ident requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts"; } my ($sep) = map +(defined() ? $_ : '.') , $self->{name_sep}; my @parts = map +($sep ? map split(/\Q${sep}\E/, $_), @$_ : @$_ ), ref($body) ? $body : [ $body ]; return { -ident => $parts[-1] } if $self->{_dequalify_idents}; unless ($self->{quote_char}) { $self->_assert_pass_injection_guard($_) for @parts; } return +{ -ident => \@parts }; } sub _expand_value { +{ -bind => [ our $Cur_Col_Meta, $_[2] ] }; } sub _expand_row { my ($self, undef, $args) = @_; +{ -row => [ map $self->expand_expr($_), @$args ] }; } sub _expand_op { my ($self, undef, $args) = @_; my ($op, @opargs) = @$args; if (my $exp = $self->{expand_op}{$op}) { return $self->$exp($op, \@opargs); } if (List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { return { -op => [ $op, @opargs ] }; } +{ -op => [ $op, map $self->expand_expr($_), @opargs ] }; } sub _expand_bool { my ($self, undef, $v) = @_; if (ref($v)) { return $self->_expand_expr($v); } puke "-bool => undef not supported" unless defined($v); return $self->_expand_expr({ -ident => $v }); } sub _expand_list { my ($self, undef, $expr) = @_; return { -op => [ ',', map $self->expand_expr($_), @{$expr->{-op}}[1..$#{$expr->{-op}}] ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ','; return +{ -op => [ ',', map $self->expand_expr($_), ref($expr) eq 'ARRAY' ? @$expr : $expr ] }; } sub _expand_logop { my ($self, $logop, $v, $k) = @_; $self->${\$self->{expand_op}{$logop}}($logop, $v, $k); } sub _expand_op_andor { my ($self, $logop, $v, $k) = @_; if (defined $k) { $v = [ map +{ $k, $_ }, (ref($v) eq 'HASH') ? (map +{ $_ => $v->{$_} }, sort keys %$v) : @$v, ]; } if (ref($v) eq 'HASH') { return undef unless keys %$v; return +{ -op => [ $logop, map $self->_expand_expr({ $_ => $v->{$_} }), sort keys %$v ] }; } if (ref($v) eq 'ARRAY') { $logop eq 'and' or $logop eq 'or' or puke "unknown logic: $logop"; my @expr = grep { (ref($_) eq 'ARRAY' and @$_) or (ref($_) eq 'HASH' and %$_) or 1 } @$v; my @res; while (my ($el) = splice @expr, 0, 1) { puke "Supplying an empty left hand side argument is not supported in array-pairs" unless defined($el) and length($el); my $elref = ref($el); if (!$elref) { local our $Expand_Depth = 0; push(@res, grep defined, $self->_expand_expr({ $el, shift(@expr) })); } elsif ($elref eq 'ARRAY') { push(@res, grep defined, $self->_expand_expr($el)) if @$el; } elsif (my $l = is_literal_value($el)) { push @res, { -literal => $l }; } elsif ($elref eq 'HASH') { local our $Expand_Depth = 0; push @res, grep defined, $self->_expand_expr($el) if %$el; } else { die "notreached"; } } # ??? # return $res[0] if @res == 1; return { -op => [ $logop, @res ] }; } die "notreached"; } sub _expand_op_is { my ($self, $op, $vv, $k) = @_; ($k, $vv) = @$vv unless defined $k; puke "$op can only take undef as argument" if defined($vv) and not ( ref($vv) eq 'HASH' and exists($vv->{-value}) and !defined($vv->{-value}) ); return +{ -op => [ $op.'_null', $self->expand_expr($k, -ident) ] }; } sub _expand_between { my ($self, $op, $vv, $k) = @_; my @rhs = map $self->_expand_expr($_), ref($vv) eq 'ARRAY' ? @$vv : $vv; unless ( (@rhs == 1 and ref($rhs[0]) eq 'HASH' and $rhs[0]->{-literal}) or (@rhs == 2 and defined($rhs[0]) and defined($rhs[1])) ) { puke "Operator '${\uc($op)}' requires either an arrayref with two defined values or expressions, or a single literal scalarref/arrayref-ref"; } return +{ -op => [ $op, $self->expand_expr($k), map $self->expand_expr($_, -value), @rhs ] } } sub _expand_in { my ($self, $op, $vv, $k) = @_; if (my $literal = is_literal_value($vv)) { my ($sql, @bind) = @$literal; my $opened_sql = $self->_open_outer_paren($sql); return +{ -op => [ $op, $self->expand_expr($k, -ident), { -literal => [ $opened_sql, @bind ] } ] }; } my $undef_err = 'SQL::Abstract before v1.75 used to generate incorrect SQL when the ' . "-${\uc($op)} operator was given an undef-containing list: !!!AUDIT YOUR CODE " . 'AND DATA!!! (the upcoming Data::Query-based version of SQL::Abstract ' . 'will emit the logically correct SQL instead of raising this exception)' ; puke("Argument passed to the '${\uc($op)}' operator can not be undefined") if !defined($vv); my @rhs = map $self->expand_expr($_, -value), map { defined($_) ? $_: puke($undef_err) } (ref($vv) eq 'ARRAY' ? @$vv : $vv); return $self->${\($op =~ /^not/ ? 'sqltrue' : 'sqlfalse')} unless @rhs; return +{ -op => [ $op, $self->expand_expr($k, -ident), @rhs ] }; } sub _expand_nest { my ($self, undef, $v) = @_; # DBIx::Class requires a nest warning to be emitted once but the private # method it overrode to do so no longer exists if ($self->{warn_once_on_nest}) { unless (our $Nest_Warned) { belch( "-nest in search conditions is deprecated, you most probably wanted:\n" .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }| ); $Nest_Warned = 1; } } return $self->_expand_expr($v); } sub _expand_values { my ($self, undef, $values) = @_; return { -values => [ map +( ref($_) eq 'HASH' ? $self->expand_expr($_) : +{ -row => [ map $self->expand_expr($_), @$_ ] } ), ref($values) eq 'ARRAY' ? @$values : $values ] }; } sub _recurse_where { my ($self, $where) = @_; # Special case: top level simple string treated as literal my $where_exp = (ref($where) ? $self->_expand_select_clause_where(undef, $where) : { -literal => [ $where ] }); # dispatch expanded expression my ($sql, @bind) = defined($where_exp) ? @{ $self->render_aqt($where_exp) || [] } : (); # DBIx::Class used to call _recurse_where in scalar context # something else might too... if (wantarray) { return ($sql, @bind); } else { belch "Calling _recurse_where in scalar context is deprecated and will go away before 2.0"; return $sql; } } sub _render_ident { my ($self, undef, $ident) = @_; return [ $self->_quote($ident) ]; } sub _render_row { my ($self, undef, $values) = @_; return $self->join_query_parts('', '(', $self->_render_op(undef, [ ',', @$values ]), ')' ); } sub _render_func { my ($self, undef, $rest) = @_; my ($func, @args) = @$rest; return $self->join_query_parts('', $self->_sqlcase($func), $self->join_query_parts('', '(', $self->join_query_parts(', ', @args), ')' ), ); } sub _render_bind { my ($self, undef, $bind) = @_; return [ '?', $self->_bindtype(@$bind) ]; } sub _render_literal { my ($self, undef, $literal) = @_; $self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]); return $literal; } sub _render_keyword { my ($self, undef, $keyword) = @_; return [ $self->_sqlcase( ref($keyword) ? $$keyword : join ' ', split '_', $keyword ) ]; } sub _render_op { my ($self, undef, $v) = @_; my ($op, @args) = @$v; if (my $r = $self->{render_op}{$op}) { return $self->$r($op, \@args); } { # Old SQLA compat my $op = join(' ', split '_', $op); my $ss = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}; if ($ss and @args > 1) { puke "Special op '${op}' requires first value to be identifier" unless my ($ident) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0]; my $k = join(($self->{name_sep}||'.'), @$ident); local our $Expand_Depth = 1; return [ $self->${\($ss->{handler})}($k, $op, $args[1]) ]; } if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) { return [ $self->${\($us->{handler})}($op, $args[0]) ]; } if ($ss) { return $self->_render_unop_paren($op, \@args); } } if (@args == 1) { return $self->_render_unop_prefix($op, \@args); } else { return $self->_render_op_multop($op, \@args); } die "notreached"; } sub _render_op_between { my ($self, $op, $args) = @_; my ($left, $low, $high) = @$args; my @rh = do { if (@$args == 2) { puke "Single arg to between must be a literal" unless $low->{-literal}; $low; } else { +($low, { -keyword => 'and' }, $high); } }; return $self->join_query_parts(' ', '(', $left, { -keyword => $op }, @rh, ')', ); } sub _render_op_in { my ($self, $op, $args) = @_; my ($lhs, @rhs) = @$args; return $self->join_query_parts(' ', $lhs, { -keyword => $op }, $self->join_query_parts(' ', '(', $self->join_query_parts(', ', @rhs), ')' ), ); } sub _render_op_andor { my ($self, $op, $args) = @_; return undef unless @$args; return $self->join_query_parts('', $args->[0]) if @$args == 1; my $inner = $self->_render_op_multop($op, $args); return undef unless defined($inner->[0]) and length($inner->[0]); return $self->join_query_parts(' ', '(', $inner, ')' ); } sub _render_op_multop { my ($self, $op, $args) = @_; my @parts = @$args; return undef unless @parts; return $self->render_aqt($parts[0]) if @parts == 1; my $join = ($op eq ',' ? ', ' : { -keyword => " ${op} " } ); return $self->join_query_parts($join, @parts); } sub _render_values { my ($self, undef, $values) = @_; my $inner = $self->join_query_parts(' ', { -keyword => 'values' }, $self->join_query_parts(', ', ref($values) eq 'ARRAY' ? @$values : $values ), ); return $self->join_query_parts('', (our $Render_Top_Level ? $inner : ('(', $inner, ')')) ); } sub join_query_parts { my ($self, $join, @parts) = @_; if (ref($join) eq 'HASH') { $join = $self->render_aqt($join)->[0]; } my @final = map +( ref($_) eq 'HASH' ? $self->render_aqt($_) : ((ref($_) eq 'ARRAY') ? $_ : [ $_ ]) ), @parts; return [ $self->{join_sql_parts}->( $join, grep defined && length, map $_->[0], @final ), (map @{$_}[1..$#$_], @final), ]; } sub _render_unop_paren { my ($self, $op, $v) = @_; return $self->join_query_parts('', '(', $self->_render_unop_prefix($op, $v), ')' ); } sub _render_unop_prefix { my ($self, $op, $v) = @_; my $op_sql = $self->{restore_old_unop_handling} ? $self->_sqlcase($op) : { -keyword => $op }; return $self->join_query_parts(' ', ($self->{restore_old_unop_handling} ? $self->_sqlcase($op) : { -keyword => \$op }), $v->[0] ); } sub _render_unop_postfix { my ($self, $op, $v) = @_; return $self->join_query_parts(' ', $v->[0], { -keyword => $op }, ); } # Some databases (SQLite) treat col IN (1, 2) different from # col IN ( (1, 2) ). Use this to strip all outer parens while # adding them back in the corresponding method sub _open_outer_paren { my ($self, $sql) = @_; while (my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs) { # there are closing parens inside, need the heavy duty machinery # to reevaluate the extraction starting from $sql (full reevaluation) if ($inner =~ /\)/) { require Text::Balanced; my (undef, $remainder) = do { # idiotic design - writes to $@ but *DOES NOT* throw exceptions local $@; Text::Balanced::extract_bracketed($sql, '()', qr/\s*/); }; # the entire expression needs to be a balanced bracketed thing # (after an extract no remainder sans trailing space) last if defined $remainder and $remainder =~ /\S/; } $sql = $inner; } $sql; } sub _where_field_IN { my ($self, $k, $op, $vals) = @_; @{$self->_render_op_in( $op, [ $self->expand_expr($k, -ident), map $self->expand_expr($_, -value), ref($vals) eq 'ARRAY' ? @$vals : $vals ] )}; } sub _where_field_BETWEEN { my ($self, $k, $op, $vals) = @_; @{$self->_render_op_between( $op, [ $self->expand_expr($k, -ident), ref($vals) eq 'ARRAY' ? @$vals : $vals ] )}; } #====================================================================== # ORDER BY #====================================================================== sub _expand_order_by { my ($self, $arg) = @_; return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg); return $self->expand_expr({ -list => $arg }) if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ','; my $expander = sub { my ($self, $dir, $expr) = @_; my @to_expand = ref($expr) eq 'ARRAY' ? @$expr : $expr; foreach my $arg (@to_expand) { if ( ref($arg) eq 'HASH' and keys %$arg > 1 and grep /^-(asc|desc)$/, keys %$arg ) { puke "ordering direction hash passed to order by must have exactly one key (-asc or -desc)"; } } my @exp = map +( defined($dir) ? { -op => [ $dir =~ /^-?(.*)$/ ,=> $_ ] } : $_ ), map $self->expand_expr($_, -ident), map ref($_) eq 'ARRAY' ? @$_ : $_, @to_expand; return undef unless @exp; return undef if @exp == 1 and not defined($exp[0]); return +{ -op => [ ',', @exp ] }; }; local @{$self->{expand}}{qw(asc desc)} = (($expander) x 2); return $self->$expander(undef, $arg); } sub _order_by { my ($self, $arg) = @_; return '' unless defined(my $expanded = $self->_expand_order_by($arg)); my ($sql, @bind) = @{ $self->render_aqt($expanded) }; return '' unless length($sql); my $final_sql = $self->_sqlcase(' order by ').$sql; return $final_sql unless wantarray; return ($final_sql, @bind); } # _order_by no longer needs to call this so doesn't but DBIC uses it. sub _order_by_chunks { my ($self, $arg) = @_; return () unless defined(my $expanded = $self->_expand_order_by($arg)); my @res = $self->_chunkify_order_by($expanded); (ref() ? $_->[0] : $_) .= '' for @res; return @res; } sub _chunkify_order_by { my ($self, $expanded) = @_; return grep length, @{ $self->render_aqt($expanded) } if $expanded->{-ident} or @{$expanded->{-literal}||[]} == 1; for ($expanded) { if (ref() eq 'HASH' and $_->{-op} and $_->{-op}[0] eq ',') { my ($comma, @list) = @{$_->{-op}}; return map $self->_chunkify_order_by($_), @list; } return $self->render_aqt($_); } } #====================================================================== # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES) #====================================================================== sub _table { my $self = shift; my $from = shift; $self->render_aqt( $self->expand_expr({ -list => $from }, -ident) )->[0]; } #====================================================================== # UTILITY FUNCTIONS #====================================================================== # highly optimized, as it's called way too often sub _quote { # my ($self, $label) = @_; return '' unless defined $_[1]; return ${$_[1]} if ref($_[1]) eq 'SCALAR'; puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH'; unless ($_[0]->{quote_char}) { if (ref($_[1]) eq 'ARRAY') { return join($_[0]->{name_sep}||'.', @{$_[1]}); } else { $_[0]->_assert_pass_injection_guard($_[1]); return $_[1]; } } my $qref = ref $_[0]->{quote_char}; my ($l, $r) = !$qref ? ($_[0]->{quote_char}, $_[0]->{quote_char}) : ($qref eq 'ARRAY') ? @{$_[0]->{quote_char}} : puke "Unsupported quote_char format: $_[0]->{quote_char}"; my $esc = $_[0]->{escape_char} || $r; # parts containing * are naturally unquoted return join( $_[0]->{name_sep}||'', map +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ), (ref($_[1]) eq 'ARRAY' ? @{$_[1]} : ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] ) ) ); } # Conversion, if applicable sub _convert { #my ($self, $arg) = @_; if (my $conv = $_[0]->{convert_where}) { return @{ $_[0]->join_query_parts('', $_[0]->_sqlcase($conv), '(' , $_[1] , ')' ) }; } return $_[1]; } # And bindtype sub _bindtype { #my ($self, $col, @vals) = @_; # called often - tighten code return $_[0]->{bindtype} eq 'columns' ? map {[$_[1], $_]} @_[2 .. $#_] : @_[2 .. $#_] ; } # Dies if any element of @bind is not in [colname => value] format # if bindtype is 'columns'. sub _assert_bindval_matches_bindtype { # my ($self, @bind) = @_; my $self = shift; if ($self->{bindtype} eq 'columns') { for (@_) { if (!defined $_ || ref($_) ne 'ARRAY' || @$_ != 2) { puke "bindtype 'columns' selected, you need to pass: [column_name => bind_value]" } } } } # Fix SQL case, if so requested sub _sqlcase { # LDNOTE: if $self->{case} is true, then it contains 'lower', so we # don't touch the argument ... crooked logic, but let's not change it! return $_[0]->{case} ? $_[1] : uc($_[1]); } #====================================================================== # DISPATCHING FROM REFKIND #====================================================================== sub _refkind { my ($self, $data) = @_; return 'UNDEF' unless defined $data; # blessed objects are treated like scalars my $ref = (Scalar::Util::blessed $data) ? '' : ref $data; return 'SCALAR' unless $ref; my $n_steps = 1; while ($ref eq 'REF') { $data = $$data; $ref = (Scalar::Util::blessed $data) ? '' : ref $data; $n_steps++ if $ref; } return ($ref||'SCALAR') . ('REF' x $n_steps); } sub _try_refkind { my ($self, $data) = @_; my @try = ($self->_refkind($data)); push @try, 'SCALAR_or_UNDEF' if $try[0] eq 'SCALAR' || $try[0] eq 'UNDEF'; push @try, 'FALLBACK'; return \@try; } sub _METHOD_FOR_refkind { my ($self, $meth_prefix, $data) = @_; my $method; for (@{$self->_try_refkind($data)}) { $method = $self->can($meth_prefix."_".$_) and last; } return $method || puke "cannot dispatch on '$meth_prefix' for ".$self->_refkind($data); } sub _SWITCH_refkind { my ($self, $data, $dispatch_table) = @_; my $coderef; for (@{$self->_try_refkind($data)}) { $coderef = $dispatch_table->{$_} and last; } puke "no dispatch entry for ".$self->_refkind($data) unless $coderef; $coderef->(); } #====================================================================== # VALUES, GENERATE, AUTOLOAD #====================================================================== # LDNOTE: original code from nwiger, didn't touch code in that section # I feel the AUTOLOAD stuff should not be the default, it should # only be activated on explicit demand by user. sub values { my $self = shift; my $data = shift || return; puke "Argument to ", __PACKAGE__, "->values must be a \\%hash" unless ref $data eq 'HASH'; my @all_bind; foreach my $k (sort keys %$data) { my $v = $data->{$k}; $self->_SWITCH_refkind($v, { ARRAYREF => sub { if ($self->{array_datatypes}) { # array datatype push @all_bind, $self->_bindtype($k, $v); } else { # literal SQL with bind my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); push @all_bind, @bind; } }, ARRAYREFREF => sub { # literal SQL with bind my ($sql, @bind) = @${$v}; $self->_assert_bindval_matches_bindtype(@bind); push @all_bind, @bind; }, SCALARREF => sub { # literal SQL without bind }, SCALAR_or_UNDEF => sub { push @all_bind, $self->_bindtype($k, $v); }, }); } return @all_bind; } sub generate { my $self = shift; my(@sql, @sqlq, @sqlv); for (@_) { my $ref = ref $_; if ($ref eq 'HASH') { for my $k (sort keys %$_) { my $v = $_->{$k}; my $r = ref $v; my $label = $self->_quote($k); if ($r eq 'ARRAY') { # literal SQL with bind my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); push @sqlq, "$label = $sql"; push @sqlv, @bind; } elsif ($r eq 'SCALAR') { # literal SQL without bind push @sqlq, "$label = $$v"; } else { push @sqlq, "$label = ?"; push @sqlv, $self->_bindtype($k, $v); } } push @sql, $self->_sqlcase('set'), join ', ', @sqlq; } elsif ($ref eq 'ARRAY') { # unlike insert(), assume these are ONLY the column names, i.e. for SQL for my $v (@$_) { my $r = ref $v; if ($r eq 'ARRAY') { # literal SQL with bind my ($sql, @bind) = @$v; $self->_assert_bindval_matches_bindtype(@bind); push @sqlq, $sql; push @sqlv, @bind; } elsif ($r eq 'SCALAR') { # literal SQL without bind # embedded literal SQL push @sqlq, $$v; } else { push @sqlq, '?'; push @sqlv, $v; } } push @sql, '(' . join(', ', @sqlq) . ')'; } elsif ($ref eq 'SCALAR') { # literal SQL push @sql, $$_; } else { # strings get case twiddled push @sql, $self->_sqlcase($_); } } my $sql = join ' ', @sql; # this is pretty tricky # if ask for an array, return ($stmt, @bind) # otherwise, s/?/shift @sqlv/ to put it inline if (wantarray) { return ($sql, @sqlv); } else { 1 while $sql =~ s/\?/my $d = shift(@sqlv); ref $d ? $d->[1] : $d/e; return $sql; } } sub DESTROY { 1 } sub AUTOLOAD { # This allows us to check for a local, then _form, attr my $self = shift; my($name) = $AUTOLOAD =~ /.*::(.+)/; puke "AUTOLOAD invoked for method name ${name} and allow_autoload option not set" unless $self->{allow_autoload}; return $self->generate($name, @_); } 1; __END__ =head1 NAME SQL::Abstract - Generate SQL from Perl data structures =head1 SYNOPSIS use SQL::Abstract; my $sql = SQL::Abstract->new; my($stmt, @bind) = $sql->select($source, \@fields, \%where, $order); my($stmt, @bind) = $sql->insert($table, \%fieldvals || \@values); my($stmt, @bind) = $sql->update($table, \%fieldvals, \%where); my($stmt, @bind) = $sql->delete($table, \%where); # Then, use these in your DBI statements my $sth = $dbh->prepare($stmt); $sth->execute(@bind); # Just generate the WHERE clause my($stmt, @bind) = $sql->where(\%where, $order); # Return values in the same order, for hashed queries # See PERFORMANCE section for more details my @bind = $sql->values(\%fieldvals); =head1 DESCRIPTION This module was inspired by the excellent L. However, in using that module I found that what I really wanted to do was generate SQL, but still retain complete control over my statement handles and use the DBI interface. So, I set out to create an abstract SQL generation module. While based on the concepts used by L, there are several important differences, especially when it comes to WHERE clauses. I have modified the concepts used to make the SQL easier to generate from Perl data structures and, IMO, more intuitive. The underlying idea is for this module to do what you mean, based on the data structures you provide it. The big advantage is that you don't have to modify your code every time your data changes, as this module figures it out. To begin with, an SQL INSERT is as easy as just specifying a hash of C pairs: my %data = ( name => 'Jimbo Bobson', phone => '123-456-7890', address => '42 Sister Lane', city => 'St. Louis', state => 'Louisiana', ); The SQL can then be generated with this: my($stmt, @bind) = $sql->insert('people', \%data); Which would give you something like this: $stmt = "INSERT INTO people (address, city, name, phone, state) VALUES (?, ?, ?, ?, ?)"; @bind = ('42 Sister Lane', 'St. Louis', 'Jimbo Bobson', '123-456-7890', 'Louisiana'); These are then used directly in your DBI code: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); =head2 Inserting and Updating Arrays If your database has array types (like for example Postgres), activate the special option C<< array_datatypes => 1 >> when creating the C object. Then you may use an arrayref to insert and update database array types: my $sql = SQL::Abstract->new(array_datatypes => 1); my %data = ( planets => [qw/Mercury Venus Earth Mars/] ); my($stmt, @bind) = $sql->insert('solar_system', \%data); This results in: $stmt = "INSERT INTO solar_system (planets) VALUES (?)" @bind = (['Mercury', 'Venus', 'Earth', 'Mars']); =head2 Inserting and Updating SQL In order to apply SQL functions to elements of your C<%data> you may specify a reference to an arrayref for the given hash value. For example, if you need to execute the Oracle C function on a value, you can say something like this: my %data = ( name => 'Bill', date_entered => \[ "to_date(?,'MM/DD/YYYY')", "03/02/2003" ], ); The first value in the array is the actual SQL. Any other values are optional and would be included in the bind values array. This gives you: my($stmt, @bind) = $sql->insert('people', \%data); $stmt = "INSERT INTO people (name, date_entered) VALUES (?, to_date(?,'MM/DD/YYYY'))"; @bind = ('Bill', '03/02/2003'); An UPDATE is just as easy, all you change is the name of the function: my($stmt, @bind) = $sql->update('people', \%data); Notice that your C<%data> isn't touched; the module will generate the appropriately quirky SQL for you automatically. Usually you'll want to specify a WHERE clause for your UPDATE, though, which is where handling C<%where> hashes comes in handy... =head2 Complex where statements This module can generate pretty complicated WHERE statements easily. For example, simple C pairs are taken to mean equality, and if you want to see if a field is within a set of values, you can use an arrayref. Let's say we wanted to SELECT some data based on this criteria: my %where = ( requestor => 'inna', worker => ['nwiger', 'rcwe', 'sfz'], status => { '!=', 'completed' } ); my($stmt, @bind) = $sql->select('tickets', '*', \%where); The above would give you something like this: $stmt = "SELECT * FROM tickets WHERE ( requestor = ? ) AND ( status != ? ) AND ( worker = ? OR worker = ? OR worker = ? )"; @bind = ('inna', 'completed', 'nwiger', 'rcwe', 'sfz'); Which you could then use in DBI code like so: my $sth = $dbh->prepare($stmt); $sth->execute(@bind); Easy, eh? =head1 METHODS The methods are simple. There's one for every major SQL operation, and a constructor you use first. The arguments are specified in a similar order for each method (table, then fields, then a where clause) to try and simplify things. =head2 new(option => 'value') The C function takes a list of options and values, and returns a new B object which can then be used to generate SQL through the methods below. The options accepted are: =over =item case If set to 'lower', then SQL will be generated in all lowercase. By default SQL is generated in "textbook" case meaning something like: SELECT a_field FROM a_table WHERE some_field LIKE '%someval%' Any setting other than 'lower' is ignored. =item cmp This determines what the default comparison operator is. By default it is C<=>, meaning that a hash like this: %where = (name => 'nwiger', email => 'nate@wiger.org'); Will generate SQL like this: WHERE name = 'nwiger' AND email = 'nate@wiger.org' However, you may want loose comparisons by default, so if you set C to C you would get SQL such as: WHERE name like 'nwiger' AND email like 'nate@wiger.org' You can also override the comparison on an individual basis - see the huge section on L at the bottom. =item sqltrue, sqlfalse Expressions for inserting boolean values within SQL statements. By default these are C<1=1> and C<1=0>. They are used by the special operators C<-in> and C<-not_in> for generating correct SQL even when the argument is an empty array (see below). =item logic This determines the default logical operator for multiple WHERE statements in arrays or hashes. If absent, the default logic is "or" for arrays, and "and" for hashes. This means that a WHERE array of the form: @where = ( event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'}, ); will generate SQL like this: WHERE event_date >= '2/13/99' OR event_date <= '4/24/03' This is probably not what you want given this query, though (look at the dates). To change the "OR" to an "AND", simply specify: my $sql = SQL::Abstract->new(logic => 'and'); Which will change the above C to: WHERE event_date >= '2/13/99' AND event_date <= '4/24/03' The logic can also be changed locally by inserting a modifier in front of an arrayref: @where = (-and => [event_date => {'>=', '2/13/99'}, event_date => {'<=', '4/24/03'} ]); See the L section for explanations. =item convert This will automatically convert comparisons using the specified SQL function for both column and value. This is mostly used with an argument of C or C, so that the SQL will have the effect of case-insensitive "searches". For example, this: $sql = SQL::Abstract->new(convert => 'upper'); %where = (keywords => 'MaKe iT CAse inSeNSItive'); Will turn out the following SQL: WHERE upper(keywords) like upper('MaKe iT CAse inSeNSItive') The conversion can be C, C, or any other SQL function that can be applied symmetrically to fields (actually B does not validate this option; it will just pass through what you specify verbatim). =item bindtype This is a kludge because many databases suck. For example, you can't just bind values using DBI's C for Oracle C or C fields. Instead, you have to use C: $sth->bind_param(1, 'reg data'); $sth->bind_param(2, $lots, {ora_type => ORA_CLOB}); The problem is, B will normally just return a C<@bind> array, which loses track of which field each slot refers to. Fear not. If you specify C in new, you can determine how C<@bind> is returned. Currently, you can specify either C (default) or C. If you specify C, you will get an array that looks like this: my $sql = SQL::Abstract->new(bindtype => 'columns'); my($stmt, @bind) = $sql->insert(...); @bind = ( [ 'column1', 'value1' ], [ 'column2', 'value2' ], [ 'column3', 'value3' ], ); You can then iterate through this manually, using DBI's C. $sth->prepare($stmt); my $i = 1; for (@bind) { my($col, $data) = @$_; if ($col eq 'details' || $col eq 'comments') { $sth->bind_param($i, $data, {ora_type => ORA_CLOB}); } elsif ($col eq 'image') { $sth->bind_param($i, $data, {ora_type => ORA_BLOB}); } else { $sth->bind_param($i, $data); } $i++; } $sth->execute; # execute without @bind now Now, why would you still use B if you have to do this crap? Basically, the advantage is still that you don't have to care which fields are or are not included. You could wrap that above C loop in a simple sub called C or something and reuse it repeatedly. You still get a layer of abstraction over manual SQL specification. Note that if you set L to C, the C<\[ $sql, @bind ]> construct (see L) will expect the bind values in this format. =item quote_char This is the character that a table or column name will be quoted with. By default this is an empty string, but you could set it to the character C<`>, to generate SQL like this: SELECT `a_field` FROM `a_table` WHERE `some_field` LIKE '%someval%' Alternatively, you can supply an array ref of two items, the first being the left hand quote character, and the second the right hand quote character. For example, you could supply C<['[',']']> for SQL Server 2000 compliant quotes that generates SQL like this: SELECT [a_field] FROM [a_table] WHERE [some_field] LIKE '%someval%' Quoting is useful if you have tables or columns names that are reserved words in your database's SQL dialect. =item escape_char This is the character that will be used to escape Ls appearing in an identifier before it has been quoted. The parameter default in case of a single L character is the quote character itself. When opening-closing-style quoting is used (L is an arrayref) this parameter defaults to the B L. Occurrences of the B L within the identifier are currently left untouched. The default for opening-closing-style quotes may change in future versions, thus you are B to specify the escape character explicitly. =item name_sep This is the character that separates a table and column name. It is necessary to specify this when the C option is selected, so that tables and column names can be individually quoted like this: SELECT `table`.`one_field` FROM `table` WHERE `table`.`other_field` = 1 =item injection_guard A regular expression C that is applied to any C<-function> and unquoted column name specified in a query structure. This is a safety mechanism to avoid injection attacks when mishandling user input e.g.: my %condition_as_column_value_pairs = get_values_from_user(); $sqla->select( ... , \%condition_as_column_value_pairs ); If the expression matches an exception is thrown. Note that literal SQL supplied via C<\'...'> or C<\['...']> is B checked in any way. Defaults to checking for C<;> and the C keyword (TransactSQL) =item array_datatypes When this option is true, arrayrefs in INSERT or UPDATE are interpreted as array datatypes and are passed directly to the DBI layer. When this option is false, arrayrefs are interpreted as literal SQL, just like refs to arrayrefs (but this behavior is for backwards compatibility; when writing new queries, use the "reference to arrayref" syntax for literal SQL). =item special_ops Takes a reference to a list of "special operators" to extend the syntax understood by L. See section L for details. =item unary_ops Takes a reference to a list of "unary operators" to extend the syntax understood by L. See section L for details. =back =head2 insert($table, \@values || \%fieldvals, \%options) This is the simplest function. You simply give it a table name and either an arrayref of values or hashref of field/value pairs. It returns an SQL INSERT statement and a list of bind values. See the sections on L and L for information on how to insert with those data types. The optional C<\%options> hash reference may contain additional options to generate the insert SQL. Currently supported options are: =over 4 =item returning Takes either a scalar of raw SQL fields, or an array reference of field names, and adds on an SQL C statement at the end. This allows you to return data generated by the insert statement (such as row IDs) without performing another C