package # Hide from PAUSE
DBIx::Class::SQLAHacks;
-# This module is a subclass of SQL::Abstract::Limit and includes a number
-# of DBIC-specific workarounds, not yet suitable for inclusion into the
-# SQLA core
-
-use base qw/SQL::Abstract::Limit/;
+# This module is a subclass of SQL::Abstract and includes a number of
+# DBIC-specific workarounds, not yet suitable for inclusion into the
+# SQLA core.
+# It also provides all (and more than) the functionality of
+# SQL::Abstract::Limit, which proved to be very hard to keep updated
+
+use base qw/
+ SQL::Abstract
+ Class::Accessor::Grouped
+/;
+use mro 'c3';
use strict;
use warnings;
-use Carp::Clan qw/^DBIx::Class|^SQL::Abstract/;
-use Sub::Name();
+use List::Util 'first';
+use Sub::Name 'subname';
+use Carp::Clan qw/^DBIx::Class|^SQL::Abstract|^Try::Tiny/;
+use namespace::clean;
+
+__PACKAGE__->mk_group_accessors (simple => qw/quote_char name_sep limit_dialect/);
BEGIN {
# reinstall the carp()/croak() functions imported into SQL::Abstract
for my $f (qw/carp croak/) {
my $orig = \&{"SQL::Abstract::$f"};
- *{"SQL::Abstract::$f"} = Sub::Name::subname "SQL::Abstract::$f" =>
+ my $clan_import = \&{$f};
+ *{"SQL::Abstract::$f"} = subname "SQL::Abstract::$f" =>
sub {
if (Carp::longmess() =~ /DBIx::Class::SQLAHacks::[\w]+ .+? called \s at/x) {
- __PACKAGE__->can($f)->(@_);
+ $clan_import->(@_);
}
else {
goto $orig;
}
}
-
-# Tries to determine limit dialect.
-#
-sub new {
- my $self = shift->SUPER::new(@_);
-
- # This prevents the caching of $dbh in S::A::L, I believe
- # If limit_dialect is a ref (like a $dbh), go ahead and replace
- # it with what it resolves to:
- $self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
- if ref $self->{limit_dialect};
-
- $self;
-}
+# the "oh noes offset/top without limit" constant
+# limited to 32 bits for sanity (and consistency,
+# since it is ultimately handed to sprintf %u)
+# Implemented as a method, since ::Storage::DBI also
+# refers to it (i.e. for the case of software_limit or
+# as the value to abuse with MSSQL ordered subqueries)
+sub __max_int { 0xFFFFFFFF };
# !!! THIS IS ALSO HORRIFIC !!! /me ashamed
#
-# generate inner/outer select lists for various limit dialects
+# Generates inner/outer select lists for various limit dialects
# which result in one or more subqueries (e.g. RNO, Top, RowNum)
# Any non-root-table columns need to have their table qualifier
# turned into a column alias (otherwise names in subqueries clash
# and/or lose their source table)
#
-# returns inner/outer strings of SQL QUOTED selectors with aliases
+# Returns inner/outer strings of SQL QUOTED selectors with aliases
# (to be used in whatever select statement), and an alias index hashref
# of QUOTED SEL => QUOTED ALIAS pairs (to maybe be used for string-subst
-# higher up)
-#
-# If the $scan_order option is supplied, it signals that the limit dialect
-# needs to order the outer side of the query, which in turn means that the
-# inner select needs to bring out columns used in implicit (non-selected)
-# orders, and the order condition itself needs to be realiased to the proper
-# names in the outer query.
-#
-# In this case ($scan_order os true) we also return a hashref (order doesn't
-# matter) of QUOTED EXTRA-SEL => QUOTED ALIAS pairs, which is a list of extra
-# selectors that do *not* exist in the original select list
+# higher up).
+# If an order_by is supplied, the inner select needs to bring out columns
+# used in implicit (non-selected) orders, and the order condition itself
+# needs to be realiased to the proper names in the outer query. Thus we
+# also return a hashref (order doesn't matter) of QUOTED EXTRA-SEL =>
+# QUOTED ALIAS pairs, which is a list of extra selectors that do *not*
+# exist in the original select list
sub _subqueried_limit_attrs {
- my ($self, $rs_attrs, $scan_order) = @_;
+ my ($self, $rs_attrs) = @_;
croak 'Limit dialect implementation usable only in the context of DBIC (missing $rs_attrs)'
unless ref ($rs_attrs) eq 'HASH';
$in_sel_index->{$sql_sel}++;
$in_sel_index->{$self->_quote ($sql_alias)}++ if $sql_alias;
-# this *may* turn out to be necessary, not sure yet
-# my ($sql_unqualified_sel) = $sql_sel =~ / $re_sep (.+) $/x
-# if ! ref $s;
-# $in_sel_index->{$sql_unqualified_sel}++;
+ # record unqualified versions too, so we do not have
+ # to reselect the same column twice (in qualified and
+ # unqualified form)
+ if (! ref $s && $sql_sel =~ / $re_sep (.+) $/x) {
+ $in_sel_index->{$1}++;
+ }
}
# for possible further chaining)
my (@in_sel, @out_sel, %renamed);
for my $node (@sel) {
- if (List::Util::first { $_ =~ / (?<! $re_alias ) $re_sep /x } ($node->{as}, $node->{unquoted_sql}) ) {
- $node->{as} =~ s/ $re_sep /__/xg;
+ if (first { $_ =~ / (?<! ^ $re_alias ) $re_sep /x } ($node->{as}, $node->{unquoted_sql}) ) {
+ $node->{as} = $self->_unqualify_colname($node->{as});
my $quoted_as = $self->_quote($node->{as});
push @in_sel, sprintf '%s AS %s', $node->{sql}, $quoted_as;
push @out_sel, $quoted_as;
}
}
+ # see if the order gives us anything
my %extra_order_sel;
- if ($scan_order) {
- for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
- # order with bind
- $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
- $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
+ for my $chunk ($self->_order_by_chunks ($rs_attrs->{order_by})) {
+ # order with bind
+ $chunk = $chunk->[0] if (ref $chunk) eq 'ARRAY';
+ $chunk =~ s/\s+ (?: ASC|DESC ) \s* $//ix;
- next if $in_sel_index->{$chunk};
+ next if $in_sel_index->{$chunk};
- $extra_order_sel{$chunk} ||= $self->_quote (
- 'ORDER__BY__' . scalar keys %extra_order_sel
- );
- }
+ $extra_order_sel{$chunk} ||= $self->_quote (
+ 'ORDER__BY__' . scalar keys %extra_order_sel
+ );
}
+
return (
(map { join (', ', @$_ ) } (
\@in_sel,
);
}
+sub _unqualify_colname {
+ my ($self, $fqcn) = @_;
+ my $re_sep = quotemeta($self->name_sep || '.');
+ $fqcn =~ s/ $re_sep /__/xg;
+ return $fqcn;
+}
+
+#
+# Follow limit dialect implementations
+#
+
+# PostgreSQL and SQLite
+sub _LimitOffset {
+ my ( $self, $sql, $order, $rows, $offset ) = @_;
+ $sql .= $self->_order_by( $order ) . " LIMIT $rows";
+ $sql .= " OFFSET $offset" if +$offset;
+ return $sql;
+}
+
+# MySQL and any SQL::Statement based DBD
+sub _LimitXY {
+ my ( $self, $sql, $order, $rows, $offset ) = @_;
+ $sql .= $self->_order_by( $order ) . " LIMIT ";
+ $sql .= "$offset, " if +$offset;
+ $sql .= $rows;
+ return $sql;
+}
+
# ANSI standard Limit/Offset implementation. DB2 and MSSQL >= 2005 use this
sub _RowNumberOver {
my ($self, $sql, $rs_attrs, $rows, $offset ) = @_;
or croak "Unrecognizable SELECT: $sql";
# get selectors, and scan the order_by (if any)
- my ($in_sel, $out_sel, $alias_map, $extra_order_sel) = $self->_subqueried_limit_attrs (
- $rs_attrs, 'scan_order_by',
- );
+ my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
+ = $self->_subqueried_limit_attrs ( $rs_attrs );
# make up an order if none exists
my $requested_order = (delete $rs_attrs->{order_by}) || $self->_rno_default_order;
SELECT $mid_sel, ROW_NUMBER() OVER( $rno_ord ) AS $idx_name FROM (
SELECT $in_sel ${sql}${group_having}
) $qalias
-) $qalias WHERE $idx_name BETWEEN %d AND %d
+) $qalias WHERE $idx_name BETWEEN %u AND %u
EOS
}
# Informix specific limit, almost like LIMIT/OFFSET
+# According to SQLA::Limit informix also supports
+# SKIP X LIMIT Y (in addition to SKIP X FIRST Y)
sub _SkipFirst {
my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
return sprintf ('SELECT %s%s%s%s',
$offset
- ? sprintf ('SKIP %d ', $offset)
+ ? sprintf ('SKIP %u ', $offset)
: ''
,
- sprintf ('FIRST %d ', $rows),
+ sprintf ('FIRST %u ', $rows),
$sql,
$self->_parse_rs_attrs ($rs_attrs),
);
}
# Firebird specific limit, reverse of _SkipFirst for Informix
+# According to SQLA::Limit firebird/interbase also supports
+# ROWS X TO Y (in addition to FIRST X SKIP Y)
sub _FirstSkip {
my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
or croak "Unrecognizable SELECT: $sql";
return sprintf ('SELECT %s%s%s%s',
- sprintf ('FIRST %d ', $rows),
+ sprintf ('FIRST %u ', $rows),
$offset
- ? sprintf ('SKIP %d ', $offset)
+ ? sprintf ('SKIP %u ', $offset)
: ''
,
$sql,
SELECT $outsel, ROWNUM $idx_name FROM (
SELECT $insel ${sql}${order_group_having}
) $qalias
-) $qalias WHERE $idx_name BETWEEN %d AND %d
+) $qalias WHERE $idx_name BETWEEN %u AND %u
EOS
# get selectors
my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
- = $self->_subqueried_limit_attrs ($rs_attrs, 'outer_order_by');
+ = $self->_subqueried_limit_attrs ($rs_attrs);
my $requested_order = delete $rs_attrs->{order_by};
$mid_sel .= ', ' . $extra_order_sel->{$extra_col};
}
+
+ # since whatever order bindvals there are, they will be realiased
+ # and need to show up in front of the entire initial inner subquery
+ # Unshift *from_bind* to make this happen (horrible, horrible, but
+ # we don't have another mechanism yet)
+ unshift @{$self->{from_bind}}, @{$self->{order_bind}};
}
# and this is order re-alias magic
my $quoted_rs_alias = $self->_quote ($rs_attrs->{alias});
- $sql = sprintf ('SELECT TOP %d %s %s %s %s',
+ $sql = sprintf ('SELECT TOP %u %s %s %s %s',
$rows + ($offset||0),
$in_sel,
$sql,
$order_by_inner,
);
- $sql = sprintf ('SELECT TOP %d %s FROM ( %s ) %s %s',
+ $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
$rows,
$mid_sel,
$sql,
$order_by_reversed,
) if $offset;
- $sql = sprintf ('SELECT TOP %d %s FROM ( %s ) %s %s',
+ $sql = sprintf ('SELECT TOP %u %s FROM ( %s ) %s %s',
$rows,
$out_sel,
$sql,
$order_by_requested,
) if ( ($offset && $order_by_requested) || ($mid_sel ne $out_sel) );
+ $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger
return $sql;
}
+# This for Sybase ASE, to use SET ROWCOUNT when there is no offset, and
+# GenericSubQ otherwise.
+sub _RowCountOrGenericSubQ {
+ my $self = shift;
+ my ($sql, $rs_attrs, $rows, $offset) = @_;
+
+ return $self->_GenericSubQ(@_) if $offset;
-# While we're at it, this should make LIMIT queries more efficient,
-# without digging into things too deeply
-sub _find_syntax {
- my ($self, $syntax) = @_;
- return $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
+ return sprintf <<"EOF", $rows, $sql;
+SET ROWCOUNT %d
+%s
+SET ROWCOUNT 0
+EOF
}
-# Quotes table names, handles "limit" dialects (e.g. where rownum between x and
-# y)
-sub select {
- my ($self, $table, $fields, $where, $rs_attrs, @rest) = @_;
+# This is the most evil limit "dialect" (more of a hack) for *really*
+# stupid databases. It works by ordering the set by some unique column,
+# and calculating amount of rows that have a less-er value (thus
+# emulating a RowNum-like index). Of course this implies the set can
+# only be ordered by a single unique columns.
+sub _GenericSubQ {
+ my ($self, $sql, $rs_attrs, $rows, $offset) = @_;
+
+ my $root_rsrc = $rs_attrs->{_rsroot_source_handle}->resolve;
+ my $root_tbl_name = $root_rsrc->name;
- $self->{"${_}_bind"} = [] for (qw/having from order/);
+ # mangle the input sql as we will be replacing the selector
+ $sql =~ s/^ \s* SELECT \s+ .+? \s+ (?= \b FROM \b )//ix
+ or croak "Unrecognizable SELECT: $sql";
- if (not ref($table) or ref($table) eq 'SCALAR') {
- $table = $self->_quote($table);
+ my ($order_by, @rest) = do {
+ local $self->{quote_char};
+ $self->_order_by_chunks ($rs_attrs->{order_by})
+ };
+
+ unless (
+ $order_by
+ &&
+ ! @rest
+ &&
+ ( ! ref $order_by
+ ||
+ ( ref $order_by eq 'ARRAY' and @$order_by == 1 )
+ )
+ ) {
+ croak (
+ 'Generic Subquery Limit does not work on resultsets without an order, or resultsets '
+ . 'with complex order criteria (multicolumn and/or functions). Provide a single, '
+ . 'unique-column order criteria.'
+ );
}
- @rest = (-1) unless defined $rest[0];
- croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
- # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
+ ($order_by) = @$order_by if ref $order_by;
+
+ $order_by =~ s/\s+ ( ASC|DESC ) \s* $//ix;
+ my $direction = lc ($1 || 'asc');
- my ($sql, @where_bind) = $self->SUPER::select(
- $table, $self->_recurse_fields($fields), $where, $rs_attrs, @rest
+ my ($unq_sort_col) = $order_by =~ /(?:^|\.)([^\.]+)$/;
+
+ my $inf = $root_rsrc->storage->_resolve_column_info (
+ $rs_attrs->{from}, [$order_by, $unq_sort_col]
);
- return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}, @{$self->{order_bind}} ) : $sql;
-}
-# Quotes table names, and handles default inserts
-sub insert {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table);
+ my $ord_colinfo = $inf->{$order_by} || croak "Unable to determine source of order-criteria '$order_by'";
- # SQLA will emit INSERT INTO $table ( ) VALUES ( )
- # which is sadly understood only by MySQL. Change default behavior here,
- # until SQLA2 comes with proper dialect support
- if (! $_[0] or (ref $_[0] eq 'HASH' and !keys %{$_[0]} ) ) {
- my $sql = "INSERT INTO ${table} DEFAULT VALUES";
+ if ($ord_colinfo->{-result_source}->name ne $root_tbl_name) {
+ croak "Generic Subquery Limit order criteria can be only based on the root-source '"
+ . $root_rsrc->source_name . "' (aliased as '$rs_attrs->{alias}')";
+ }
- if (my $ret = ($_[1]||{})->{returning} ) {
- $sql .= $self->_insert_returning ($ret);
- }
+ # make sure order column is qualified
+ $order_by = "$rs_attrs->{alias}.$order_by"
+ unless $order_by =~ /^$rs_attrs->{alias}\./;
- return $sql;
+ my $is_u;
+ my $ucs = { $root_rsrc->unique_constraints };
+ for (values %$ucs ) {
+ if (@$_ == 1 && "$rs_attrs->{alias}.$_->[0]" eq $order_by) {
+ $is_u++;
+ last;
+ }
}
+ croak "Generic Subquery Limit order criteria column '$order_by' must be unique (no unique constraint found)"
+ unless $is_u;
+
+ my ($in_sel, $out_sel, $alias_map, $extra_order_sel)
+ = $self->_subqueried_limit_attrs ($rs_attrs);
+
+ my $cmp_op = $direction eq 'desc' ? '>' : '<';
+ my $count_tbl_alias = 'rownum__emulation';
- $self->SUPER::insert($table, @_);
+ my $order_sql = $self->_order_by (delete $rs_attrs->{order_by});
+ my $group_having_sql = $self->_parse_rs_attrs($rs_attrs);
+
+ # add the order supplement (if any) as this is what will be used for the outer WHERE
+ $in_sel .= ", $_" for keys %{$extra_order_sel||{}};
+
+ $sql = sprintf (<<EOS,
+SELECT $out_sel
+ FROM (
+ SELECT $in_sel ${sql}${group_having_sql}
+ ) %s
+WHERE ( SELECT COUNT(*) FROM %s %s WHERE %s $cmp_op %s ) %s
+$order_sql
+EOS
+ ( map { $self->_quote ($_) } (
+ $rs_attrs->{alias},
+ $root_tbl_name,
+ $count_tbl_alias,
+ "$count_tbl_alias.$unq_sort_col",
+ $order_by,
+ )),
+ $offset
+ ? sprintf ('BETWEEN %u AND %u', $offset, $offset + $rows - 1)
+ : sprintf ('< %u', $rows )
+ ,
+ );
+
+ $sql =~ s/\s*\n\s*/ /g; # easier to read in the debugger
+ return $sql;
}
-# Just quotes table names.
-sub update {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table);
- $self->SUPER::update($table, @_);
+#
+# Actual SQL::Abstract overrid^Whacks
+#
+
+# Handle limit-dialect selection
+sub select {
+ my ($self, $table, $fields, $where, $rs_attrs, $limit, $offset) = @_;
+
+
+ $fields = $self->_recurse_fields($fields);
+
+ if (defined $offset) {
+ croak ('A supplied offset must be a non-negative integer')
+ if ( $offset =~ /\D/ or $offset < 0 );
+ }
+ $offset ||= 0;
+
+ if (defined $limit) {
+ croak ('A supplied limit must be a positive integer')
+ if ( $limit =~ /\D/ or $limit <= 0 );
+ }
+ elsif ($offset) {
+ $limit = $self->__max_int;
+ }
+
+
+ my ($sql, @bind);
+ if ($limit) {
+ # this is legacy code-flow from SQLA::Limit, it is not set in stone
+
+ ($sql, @bind) = $self->next::method ($table, $fields, $where);
+
+ my $limiter =
+ $self->can ('emulate_limit') # also backcompat hook from SQLA::Limit
+ ||
+ do {
+ my $dialect = $self->limit_dialect
+ or croak "Unable to generate SQL-limit - no limit dialect specified on $self, and no emulate_limit method found";
+ $self->can ("_$dialect")
+ or croak "SQLAHacks does not implement the requested dialect '$dialect'";
+ }
+ ;
+
+ $sql = $self->$limiter ($sql, $rs_attrs, $limit, $offset);
+ }
+ else {
+ ($sql, @bind) = $self->next::method ($table, $fields, $where, $rs_attrs);
+ }
+
+ push @{$self->{where_bind}}, @bind;
+
+# this *must* be called, otherwise extra binds will remain in the sql-maker
+ my @all_bind = $self->_assemble_binds;
+
+ return wantarray ? ($sql, @all_bind) : $sql;
}
-# Just quotes table names.
-sub delete {
+sub _assemble_binds {
my $self = shift;
- my $table = shift;
- $table = $self->_quote($table);
- $self->SUPER::delete($table, @_);
+ return map { @{ (delete $self->{"${_}_bind"}) || [] } } (qw/from where having order/);
}
-sub _emulate_limit {
- my $self = shift;
- # my ( $syntax, $sql, $order, $rows, $offset ) = @_;
+# Handle default inserts
+sub insert {
+# optimized due to hotttnesss
+# my ($self, $table, $data, $options) = @_;
- if ($_[3] == -1) {
- return $_[1] . $self->_parse_rs_attrs($_[2]);
- } else {
- return $self->SUPER::_emulate_limit(@_);
+ # SQLA will emit INSERT INTO $table ( ) VALUES ( )
+ # which is sadly understood only by MySQL. Change default behavior here,
+ # until SQLA2 comes with proper dialect support
+ if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
+ my $sql = "INSERT INTO $_[1] DEFAULT VALUES";
+
+ if (my $ret = ($_[3]||{})->{returning} ) {
+ $sql .= $_[0]->_insert_returning ($ret);
+ }
+
+ return $sql;
}
+
+ next::method(@_);
}
sub _recurse_fields {
return $self->_parse_rs_attrs ($arg);
}
else {
- my ($sql, @bind) = $self->SUPER::_order_by ($arg);
+ my ($sql, @bind) = $self->next::method($arg);
push @{$self->{order_bind}}, @bind;
return $sql;
}
}
-sub _order_directions {
- my ($self, $order) = @_;
-
- # strip bind values - none of the current _order_directions users support them
- return $self->SUPER::_order_directions( [ map
- { ref $_ ? $_->[0] : $_ }
- $self->_order_by_chunks ($order)
- ]);
-}
-
sub _table {
- my ($self, $from) = @_;
- if (ref $from eq 'ARRAY') {
- return $self->_recurse_from(@$from);
- } elsif (ref $from eq 'HASH') {
- return $self->_make_as($from);
- } else {
- return $from; # would love to quote here but _table ends up getting called
- # twice during an ->select without a limit clause due to
- # the way S::A::Limit->select works. should maybe consider
- # bypassing this and doing S::A::select($self, ...) in
- # our select method above. meantime, quoting shims have
- # been added to select/insert/update/delete here
+# optimized due to hotttnesss
+# my ($self, $from) = @_;
+ if (my $ref = ref $_[1] ) {
+ if ($ref eq 'ARRAY') {
+ return $_[0]->_recurse_from(@{$_[1]});
+ }
+ elsif ($ref eq 'HASH') {
+ return $_[0]->_make_as($_[1]);
+ }
}
+
+ return $_[0]->next::method ($_[1]);
}
sub _generate_join_clause {
} elsif (ref $cond eq 'ARRAY') {
return join(' OR ', map { $self->_join_condition($_) } @$cond);
} else {
- die "Can't handle this yet!";
+ croak "Can't handle this yet!";
}
}
-sub limit_dialect {
- my $self = shift;
- if (@_) {
- $self->{limit_dialect} = shift;
- undef $self->{_cached_syntax};
- }
- return $self->{limit_dialect};
-}
-
-# Set to an array-ref to specify separate left and right quotes for table names.
-# A single scalar is equivalen to [ $char, $char ]
-sub quote_char {
- my $self = shift;
- $self->{quote_char} = shift if @_;
- return $self->{quote_char};
-}
-
-# Character separating quoted table names.
-sub name_sep {
- my $self = shift;
- $self->{name_sep} = shift if @_;
- return $self->{name_sep};
-}
1;