[Bast-commits] r6209 - in DBIx-Class/0.08/branches/oracle-tweaks:
lib/DBIx/Class lib/DBIx/Class/SQLAHacks
lib/DBIx/Class/Storage lib/DBIx/Class/Storage/DBI/Oracle t
nniuq at dev.catalyst.perl.org
nniuq at dev.catalyst.perl.org
Mon May 11 14:24:27 GMT 2009
Author: nniuq
Date: 2009-05-11 14:24:27 +0000 (Mon, 11 May 2009)
New Revision: 6209
Added:
DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks.pm
DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks/
DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks/OracleJoins.pm
Modified:
DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage.pm
DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI.pm
DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm
DBIx-Class/0.08/branches/oracle-tweaks/t/41orrible.t
DBIx-Class/0.08/branches/oracle-tweaks/t/42toplimit.t
DBIx-Class/0.08/branches/oracle-tweaks/t/76joins.t
Log:
Moved DBIC::SQL::Abstract inner classes to DBIx::Class::SQLAHacks namespace to decouple 41orrible.t tests from use of DBD::Oracle in Oracle Generic driver.
Added: DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks/OracleJoins.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks/OracleJoins.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks/OracleJoins.pm 2009-05-11 14:24:27 UTC (rev 6209)
@@ -0,0 +1,170 @@
+package # Hide from PAUSE
+DBIx::Class::SQLAHacks::OracleJoins;
+
+use base qw( DBIx::Class::SQLAHacks );
+
+sub select {
+ my ($self, $table, $fields, $where, $order, @rest) = @_;
+
+ if (ref($table) eq 'ARRAY') {
+ $where = $self->_oracle_joins($where, @{ $table });
+ }
+
+ return $self->SUPER::select($table, $fields, $where, $order, @rest);
+}
+
+sub _recurse_from {
+ my ($self, $from, @join) = @_;
+
+ my @sqlf = $self->_make_as($from);
+
+ foreach my $j (@join) {
+ my ($to, $on) = @{ $j };
+
+ if (ref $to eq 'ARRAY') {
+ push (@sqlf, $self->_recurse_from(@{ $to }));
+ }
+ else {
+ push (@sqlf, $self->_make_as($to));
+ }
+ }
+
+ return join q{, }, @sqlf;
+}
+
+sub _oracle_joins {
+ my ($self, $where, $from, @join) = @_;
+ my $join_where = {};
+ $self->_recurse_oracle_joins($join_where, $from, @join);
+ if (keys %$join_where) {
+ if (!defined($where)) {
+ $where = $join_where;
+ } else {
+ if (ref($where) eq 'ARRAY') {
+ $where = { -or => $where };
+ }
+ $where = { -and => [ $join_where, $where ] };
+ }
+ }
+ return $where;
+}
+
+sub _recurse_oracle_joins {
+ my ($self, $where, $from, @join) = @_;
+
+ foreach my $j (@join) {
+ my ($to, $on) = @{ $j };
+
+ if (ref $to eq 'ARRAY') {
+ $self->_recurse_oracle_joins($where, @{ $to });
+ }
+
+ my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
+ my $left_join = q{};
+ my $right_join = q{};
+
+ if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
+ #TODO: Support full outer joins -- this would happen much earlier in
+ #the sequence since oracle 8's full outer join syntax is best
+ #described as INSANE.
+ die "Can't handle full outer joins in Oracle 8 yet!\n"
+ if $to_jt->{-join_type} =~ /full/i;
+
+ $left_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
+ && $to_jt->{-join_type} !~ /inner/i;
+
+ $right_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
+ && $to_jt->{-join_type} !~ /inner/i;
+ }
+
+ foreach my $lhs (keys %{ $on }) {
+ $where->{$lhs . $left_join} = \"= $on->{ $lhs }$right_join";
+ }
+ }
+}
+
+1;
+
+=pod
+
+=head1 NAME
+
+DBIx::Class::SQLAHacks::OracleJoins - Pre-ANSI Joins-via-Where-Clause Syntax
+
+=head1 PURPOSE
+
+This module was originally written to support Oracle < 9i where ANSI joins
+weren't supported at all, but became the module for Oracle >= 8 because
+Oracle's optimising of ANSI joins is horrible. (See:
+http://scsys.co.uk:8001/7495)
+
+=head1 SYNOPSIS
+
+Not intended for use directly; used as the sql_maker_class for schemas and components.
+
+=head1 DESCRIPTION
+
+Implements pre-ANSI joins specified in the where clause. Instead of:
+
+ SELECT x FROM y JOIN z ON y.id = z.id
+
+It will write:
+
+ SELECT x FROM y, z WHERE y.id = z.id
+
+It should properly support left joins, and right joins. Full outer joins are
+not possible due to the fact that Oracle requires the entire query be written
+to union the results of a left and right join, and by the time this module is
+called to create the where query and table definition part of the sql query,
+it's already too late.
+
+=head1 METHODS
+
+=over
+
+=item select ($\@$;$$@)
+
+Replaces DBIx::Class::SQLAHacks's select() method, which calls _oracle_joins()
+to modify the column and table list before calling SUPER::select().
+
+=item _recurse_from ($$\@)
+
+Recursive subroutine that builds the table list.
+
+=item _oracle_joins ($$$@)
+
+Creates the left/right relationship in the where query.
+
+=back
+
+=head1 BUGS
+
+Does not support full outer joins.
+Probably lots more.
+
+=head1 SEE ALSO
+
+=over
+
+=item L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> - Storage class using this
+
+=item L<DBIx::Class::SQLAHacks> - Parent module
+
+=item L<DBIx::Class> - Duh
+
+=back
+
+=head1 AUTHOR
+
+Justin Wheeler C<< <jwheeler at datademons.com> >>
+
+=head1 CONTRIBUTORS
+
+David Jack Olrik C<< <djo at cpan.org> >>
+
+=head1 LICENSE
+
+This module is licensed under the same terms as Perl itself.
+
+=cut
+
Added: DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks.pm (rev 0)
+++ DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/SQLAHacks.pm 2009-05-11 14:24:27 UTC (rev 6209)
@@ -0,0 +1,415 @@
+
+package # Hide from PAUSE
+DBIx::Class::SQLAHacks; # Would merge upstream, but nate doesn't reply :(
+
+
+use base qw/SQL::Abstract::Limit/;
+
+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;
+}
+
+
+
+# Some databases (sqlite) do not handle multiple parenthesis
+# around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
+# is interpreted as x IN 1 or something similar.
+#
+# Since we currently do not have access to the SQLA AST, resort
+# to barbaric mutilation of any SQL supplied in literal form
+
+sub _strip_outer_paren {
+ my ($self, $arg) = @_;
+
+ return $self->_SWITCH_refkind ($arg, {
+ ARRAYREFREF => sub {
+ $$arg->[0] = __strip_outer_paren ($$arg->[0]);
+ return $arg;
+ },
+ SCALARREF => sub {
+ return \__strip_outer_paren( $$arg );
+ },
+ FALLBACK => sub {
+ return $arg
+ },
+ });
+}
+
+sub __strip_outer_paren {
+ my $sql = shift;
+
+ if ($sql and not ref $sql) {
+ while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
+ $sql = $1;
+ }
+ }
+
+ return $sql;
+}
+
+sub _where_field_IN {
+ my ($self, $lhs, $op, $rhs) = @_;
+ $rhs = $self->_strip_outer_paren ($rhs);
+ return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
+}
+
+sub _where_field_BETWEEN {
+ my ($self, $lhs, $op, $rhs) = @_;
+ $rhs = $self->_strip_outer_paren ($rhs);
+ return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
+}
+
+
+
+# DB2 is the only remaining DB using this. Even though we are not sure if
+# RowNumberOver is still needed here (should be part of SQLA) leave the
+# code in place
+sub _RowNumberOver {
+ my ($self, $sql, $order, $rows, $offset ) = @_;
+
+ $offset += 1;
+ my $last = $rows + $offset;
+ my ( $order_by ) = $self->_order_by( $order );
+
+ $sql = <<"SQL";
+SELECT * FROM
+(
+ SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
+ $sql
+ $order_by
+ ) Q1
+) Q2
+WHERE ROW_NUM BETWEEN $offset AND $last
+
+SQL
+
+ return $sql;
+}
+
+
+# While we're at it, this should make LIMIT queries more efficient,
+# without digging into things too deeply
+use Scalar::Util 'blessed';
+sub _find_syntax {
+ my ($self, $syntax) = @_;
+
+ # DB2 is the only remaining DB using this. Even though we are not sure if
+ # RowNumberOver is still needed here (should be part of SQLA) leave the
+ # code in place
+ my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
+ if(ref($self) && $dbhname && $dbhname eq 'DB2') {
+ return 'RowNumberOver';
+ }
+
+ $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
+}
+
+sub select {
+ my ($self, $table, $fields, $where, $order, @rest) = @_;
+ if (ref $table eq 'SCALAR') {
+ $table = $$table;
+ }
+ elsif (not ref $table) {
+ $table = $self->_quote($table);
+ }
+ local $self->{rownum_hack_count} = 1
+ if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
+ @rest = (-1) unless defined $rest[0];
+ die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
+ # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
+ local $self->{having_bind} = [];
+ my ($sql, @ret) = $self->SUPER::select(
+ $table, $self->_recurse_fields($fields), $where, $order, @rest
+ );
+ $sql .=
+ $self->{for} ?
+ (
+ $self->{for} eq 'update' ? ' FOR UPDATE' :
+ $self->{for} eq 'shared' ? ' FOR SHARE' :
+ ''
+ ) :
+ ''
+ ;
+ return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
+}
+
+sub insert {
+ my $self = shift;
+ my $table = shift;
+ $table = $self->_quote($table) unless ref($table);
+ $self->SUPER::insert($table, @_);
+}
+
+sub update {
+ my $self = shift;
+ my $table = shift;
+ $table = $self->_quote($table) unless ref($table);
+ $self->SUPER::update($table, @_);
+}
+
+sub delete {
+ my $self = shift;
+ my $table = shift;
+ $table = $self->_quote($table) unless ref($table);
+ $self->SUPER::delete($table, @_);
+}
+
+sub _emulate_limit {
+ my $self = shift;
+ if ($_[3] == -1) {
+ return $_[1].$self->_order_by($_[2]);
+ } else {
+ return $self->SUPER::_emulate_limit(@_);
+ }
+}
+
+sub _recurse_fields {
+ my ($self, $fields, $params) = @_;
+ my $ref = ref $fields;
+ return $self->_quote($fields) unless $ref;
+ return $$fields if $ref eq 'SCALAR';
+
+ if ($ref eq 'ARRAY') {
+ return join(', ', map {
+ $self->_recurse_fields($_)
+ .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
+ ? ' AS col'.$self->{rownum_hack_count}++
+ : '')
+ } @$fields);
+ } elsif ($ref eq 'HASH') {
+ foreach my $func (keys %$fields) {
+ return $self->_sqlcase($func)
+ .'( '.$self->_recurse_fields($fields->{$func}).' )';
+ }
+ }
+ # Is the second check absolutely necessary?
+ elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
+ return $self->_bind_to_sql( $fields );
+ }
+ else {
+ Carp::croak($ref . qq{ unexpected in _recurse_fields()})
+ }
+}
+
+sub _order_by {
+ my $self = shift;
+ my $ret = '';
+ my @extra;
+ if (ref $_[0] eq 'HASH') {
+ if (defined $_[0]->{group_by}) {
+ $ret = $self->_sqlcase(' group by ')
+ .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
+ }
+ if (defined $_[0]->{having}) {
+ my $frag;
+ ($frag, @extra) = $self->_recurse_where($_[0]->{having});
+ push(@{$self->{having_bind}}, @extra);
+ $ret .= $self->_sqlcase(' having ').$frag;
+ }
+ if (defined $_[0]->{order_by}) {
+ $ret .= $self->_order_by($_[0]->{order_by});
+ }
+ if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
+ return $self->SUPER::_order_by($_[0]);
+ }
+ } elsif (ref $_[0] eq 'SCALAR') {
+ $ret = $self->_sqlcase(' order by ').${ $_[0] };
+ } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
+ my @order = @{+shift};
+ $ret = $self->_sqlcase(' order by ')
+ .join(', ', map {
+ my $r = $self->_order_by($_, @_);
+ $r =~ s/^ ?ORDER BY //i;
+ $r;
+ } @order);
+ } else {
+ $ret = $self->SUPER::_order_by(@_);
+ }
+ return $ret;
+}
+
+sub _order_directions {
+ my ($self, $order) = @_;
+ $order = $order->{order_by} if ref $order eq 'HASH';
+ return $self->SUPER::_order_directions($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
+ }
+}
+
+sub _recurse_from {
+ my ($self, $from, @join) = @_;
+ my @sqlf;
+ push(@sqlf, $self->_make_as($from));
+ foreach my $j (@join) {
+ my ($to, $on) = @$j;
+
+ # check whether a join type exists
+ my $join_clause = '';
+ my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
+ if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
+ $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
+ } else {
+ $join_clause = ' JOIN ';
+ }
+ push(@sqlf, $join_clause);
+
+ if (ref $to eq 'ARRAY') {
+ push(@sqlf, '(', $self->_recurse_from(@$to), ')');
+ } else {
+ push(@sqlf, $self->_make_as($to));
+ }
+ push(@sqlf, ' ON ', $self->_join_condition($on));
+ }
+ return join('', @sqlf);
+}
+
+sub _bind_to_sql {
+ my $self = shift;
+ my $arr = shift;
+ my $sql = shift @$$arr;
+ $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
+ return $sql
+}
+
+sub _make_as {
+ my ($self, $from) = @_;
+ return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
+ : ref $_ eq 'REF' ? $self->_bind_to_sql($_)
+ : $self->_quote($_))
+ } reverse each %{$self->_skip_options($from)});
+}
+
+sub _skip_options {
+ my ($self, $hash) = @_;
+ my $clean_hash = {};
+ $clean_hash->{$_} = $hash->{$_}
+ for grep {!/^-/} keys %$hash;
+ return $clean_hash;
+}
+
+sub _join_condition {
+ my ($self, $cond) = @_;
+ if (ref $cond eq 'HASH') {
+ my %j;
+ for (keys %$cond) {
+ my $v = $cond->{$_};
+ if (ref $v) {
+ # XXX no throw_exception() in this package and croak() fails with strange results
+ Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
+ if ref($v) ne 'SCALAR';
+ $j{$_} = $v;
+ }
+ else {
+ my $x = '= '.$self->_quote($v); $j{$_} = \$x;
+ }
+ };
+ return scalar($self->_recurse_where(\%j));
+ } elsif (ref $cond eq 'ARRAY') {
+ return join(' OR ', map { $self->_join_condition($_) } @$cond);
+ } else {
+ die "Can't handle this yet!";
+ }
+}
+
+sub _quote {
+ my ($self, $label) = @_;
+ return '' unless defined $label;
+ return "*" if $label eq '*';
+ return $label unless $self->{quote_char};
+ if(ref $self->{quote_char} eq "ARRAY"){
+ return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
+ if !defined $self->{name_sep};
+ my $sep = $self->{name_sep};
+ return join($self->{name_sep},
+ map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
+ split(/\Q$sep\E/,$label));
+ }
+ return $self->SUPER::_quote($label);
+}
+
+sub limit_dialect {
+ my $self = shift;
+ $self->{limit_dialect} = shift if @_;
+ return $self->{limit_dialect};
+}
+
+sub quote_char {
+ my $self = shift;
+ $self->{quote_char} = shift if @_;
+ return $self->{quote_char};
+}
+
+sub name_sep {
+ my $self = shift;
+ $self->{name_sep} = shift if @_;
+ return $self->{name_sep};
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+DBIx::Class::SQLAHacks - Things desired to be merged into SQL::Abstract
+
+=head1 METHODS
+
+=head2 new
+
+Tries to determine limit dialect.
+
+=head2 select
+
+Quotes table names, handles "limit" dialects (e.g. where rownum between x and
+y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
+
+=head2 insert update delete
+
+Just quotes table names.
+
+=head2 limit_dialect
+
+Specifies the dialect of used for implementing an SQL "limit" clause for
+restricting the number of query results returned. Valid values are: RowNum.
+
+See L<DBIx::Class::Storage::DBI/connect_info> for details.
+
+=head2 name_sep
+
+Character separating quoted table names.
+
+See L<DBIx::Class::Storage::DBI/connect_info> for details.
+
+=head2 quote_char
+
+Set to an array-ref to specify separate left and right quotes for table names.
+
+See L<DBIx::Class::Storage::DBI/connect_info> for details.
+
+=cut
+
Modified: DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm 2009-05-11 13:39:33 UTC (rev 6208)
+++ DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI/Oracle/WhereJoins.pm 2009-05-11 14:24:27 UTC (rev 6209)
@@ -5,95 +5,8 @@
use strict;
use warnings;
-__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract::Oracle');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::OracleJoins');
-BEGIN {
- package # Hide from PAUSE
- DBIC::SQL::Abstract::Oracle;
-
- use base qw( DBIC::SQL::Abstract );
-
- sub select {
- my ($self, $table, $fields, $where, $order, @rest) = @_;
-
- if (ref($table) eq 'ARRAY') {
- $where = $self->_oracle_joins($where, @{ $table });
- }
-
- return $self->SUPER::select($table, $fields, $where, $order, @rest);
- }
-
- sub _recurse_from {
- my ($self, $from, @join) = @_;
-
- my @sqlf = $self->_make_as($from);
-
- foreach my $j (@join) {
- my ($to, $on) = @{ $j };
-
- if (ref $to eq 'ARRAY') {
- push (@sqlf, $self->_recurse_from(@{ $to }));
- }
- else {
- push (@sqlf, $self->_make_as($to));
- }
- }
-
- return join q{, }, @sqlf;
- }
-
- sub _oracle_joins {
- my ($self, $where, $from, @join) = @_;
- my $join_where = {};
- $self->_recurse_oracle_joins($join_where, $from, @join);
- if (keys %$join_where) {
- if (!defined($where)) {
- $where = $join_where;
- } else {
- if (ref($where) eq 'ARRAY') {
- $where = { -or => $where };
- }
- $where = { -and => [ $join_where, $where ] };
- }
- }
- return $where;
- }
-
- sub _recurse_oracle_joins {
- my ($self, $where, $from, @join) = @_;
-
- foreach my $j (@join) {
- my ($to, $on) = @{ $j };
-
- if (ref $to eq 'ARRAY') {
- $self->_recurse_oracle_joins($where, @{ $to });
- }
-
- my $to_jt = ref $to eq 'ARRAY' ? $to->[0] : $to;
- my $left_join = q{};
- my $right_join = q{};
-
- if (ref $to_jt eq 'HASH' and exists $to_jt->{-join_type}) {
- #TODO: Support full outer joins -- this would happen much earlier in
- #the sequence since oracle 8's full outer join syntax is best
- #described as INSANE.
- die "Can't handle full outer joins in Oracle 8 yet!\n"
- if $to_jt->{-join_type} =~ /full/i;
-
- $left_join = q{(+)} if $to_jt->{-join_type} =~ /left/i
- && $to_jt->{-join_type} !~ /inner/i;
-
- $right_join = q{(+)} if $to_jt->{-join_type} =~ /right/i
- && $to_jt->{-join_type} !~ /inner/i;
- }
-
- foreach my $lhs (keys %{ $on }) {
- $where->{$lhs . $left_join} = \"= $on->{ $lhs }$right_join";
- }
- }
- }
-}
-
1;
__END__
@@ -135,34 +48,8 @@
=head1 METHODS
-This module replaces a subroutine contained in DBIC::SQL::Abstract:
+See L<DBIx::Class::SQLAHacks::OracleJoins> for implementation details.
-=over
-
-=item sql_maker
-
-=back
-
-It also creates a new module in its BEGIN { } block called
-DBIC::SQL::Abstract::Oracle which has the following methods:
-
-=over
-
-=item select ($\@$;$$@)
-
-Replaces DBIC::SQL::Abstract's select() method, which calls _oracle_joins()
-to modify the column and table list before calling SUPER::select().
-
-=item _recurse_from ($$\@)
-
-Recursive subroutine that builds the table list.
-
-=item _oracle_joins ($$$@)
-
-Creates the left/right relationship in the where query.
-
-=back
-
=head1 BUGS
Does not support full outer joins.
@@ -172,8 +59,10 @@
=over
-=item L<DBIC::SQL::Abstract>
+=item L<DBIx::Class::SQLAHacks>
+=item L<DBIx::Class::SQLAHacks::OracleJoins>
+
=item L<DBIx::Class::Storage::DBI::Oracle::Generic>
=item L<DBIx::Class>
Modified: DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI.pm 2009-05-11 13:39:33 UTC (rev 6208)
+++ DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage/DBI.pm 2009-05-11 14:24:27 UTC (rev 6209)
@@ -7,7 +7,7 @@
use warnings;
use Carp::Clan qw/^DBIx::Class/;
use DBI;
-use SQL::Abstract::Limit;
+use DBIx::Class::SQLAHacks;
use DBIx::Class::Storage::DBI::Cursor;
use DBIx::Class::Storage::Statistics;
use Scalar::Util qw/blessed weaken/;
@@ -29,379 +29,9 @@
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
-__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
-BEGIN {
-package # Hide from PAUSE
- DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
-
-use base qw/SQL::Abstract::Limit/;
-
-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;
-}
-
-
-
-# Some databases (sqlite) do not handle multiple parenthesis
-# around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
-# is interpreted as x IN 1 or something similar.
-#
-# Since we currently do not have access to the SQLA AST, resort
-# to barbaric mutilation of any SQL supplied in literal form
-
-sub _strip_outer_paren {
- my ($self, $arg) = @_;
-
- return $self->_SWITCH_refkind ($arg, {
- ARRAYREFREF => sub {
- $$arg->[0] = __strip_outer_paren ($$arg->[0]);
- return $arg;
- },
- SCALARREF => sub {
- return \__strip_outer_paren( $$arg );
- },
- FALLBACK => sub {
- return $arg
- },
- });
-}
-
-sub __strip_outer_paren {
- my $sql = shift;
-
- if ($sql and not ref $sql) {
- while ($sql =~ /^ \s* \( (.*) \) \s* $/x ) {
- $sql = $1;
- }
- }
-
- return $sql;
-}
-
-sub _where_field_IN {
- my ($self, $lhs, $op, $rhs) = @_;
- $rhs = $self->_strip_outer_paren ($rhs);
- return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
-}
-
-sub _where_field_BETWEEN {
- my ($self, $lhs, $op, $rhs) = @_;
- $rhs = $self->_strip_outer_paren ($rhs);
- return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
-}
-
-
-
-# DB2 is the only remaining DB using this. Even though we are not sure if
-# RowNumberOver is still needed here (should be part of SQLA) leave the
-# code in place
-sub _RowNumberOver {
- my ($self, $sql, $order, $rows, $offset ) = @_;
-
- $offset += 1;
- my $last = $rows + $offset;
- my ( $order_by ) = $self->_order_by( $order );
-
- $sql = <<"SQL";
-SELECT * FROM
-(
- SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
- $sql
- $order_by
- ) Q1
-) Q2
-WHERE ROW_NUM BETWEEN $offset AND $last
-
-SQL
-
- return $sql;
-}
-
-
-# While we're at it, this should make LIMIT queries more efficient,
-# without digging into things too deeply
-use Scalar::Util 'blessed';
-sub _find_syntax {
- my ($self, $syntax) = @_;
-
- # DB2 is the only remaining DB using this. Even though we are not sure if
- # RowNumberOver is still needed here (should be part of SQLA) leave the
- # code in place
- my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
- if(ref($self) && $dbhname && $dbhname eq 'DB2') {
- return 'RowNumberOver';
- }
-
- $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
-}
-
-sub select {
- my ($self, $table, $fields, $where, $order, @rest) = @_;
- if (ref $table eq 'SCALAR') {
- $table = $$table;
- }
- elsif (not ref $table) {
- $table = $self->_quote($table);
- }
- local $self->{rownum_hack_count} = 1
- if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
- @rest = (-1) unless defined $rest[0];
- die "LIMIT 0 Does Not Compute" if $rest[0] == 0;
- # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
- local $self->{having_bind} = [];
- my ($sql, @ret) = $self->SUPER::select(
- $table, $self->_recurse_fields($fields), $where, $order, @rest
- );
- $sql .=
- $self->{for} ?
- (
- $self->{for} eq 'update' ? ' FOR UPDATE' :
- $self->{for} eq 'shared' ? ' FOR SHARE' :
- ''
- ) :
- ''
- ;
- return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
-}
-
-sub insert {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table) unless ref($table);
- $self->SUPER::insert($table, @_);
-}
-
-sub update {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table) unless ref($table);
- $self->SUPER::update($table, @_);
-}
-
-sub delete {
- my $self = shift;
- my $table = shift;
- $table = $self->_quote($table) unless ref($table);
- $self->SUPER::delete($table, @_);
-}
-
-sub _emulate_limit {
- my $self = shift;
- if ($_[3] == -1) {
- return $_[1].$self->_order_by($_[2]);
- } else {
- return $self->SUPER::_emulate_limit(@_);
- }
-}
-
-sub _recurse_fields {
- my ($self, $fields, $params) = @_;
- my $ref = ref $fields;
- return $self->_quote($fields) unless $ref;
- return $$fields if $ref eq 'SCALAR';
-
- if ($ref eq 'ARRAY') {
- return join(', ', map {
- $self->_recurse_fields($_)
- .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
- ? ' AS col'.$self->{rownum_hack_count}++
- : '')
- } @$fields);
- } elsif ($ref eq 'HASH') {
- foreach my $func (keys %$fields) {
- return $self->_sqlcase($func)
- .'( '.$self->_recurse_fields($fields->{$func}).' )';
- }
- }
- # Is the second check absolutely necessary?
- elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
- return $self->_bind_to_sql( $fields );
- }
- else {
- Carp::croak($ref . qq{ unexpected in _recurse_fields()})
- }
-}
-
-sub _order_by {
- my $self = shift;
- my $ret = '';
- my @extra;
- if (ref $_[0] eq 'HASH') {
- if (defined $_[0]->{group_by}) {
- $ret = $self->_sqlcase(' group by ')
- .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
- }
- if (defined $_[0]->{having}) {
- my $frag;
- ($frag, @extra) = $self->_recurse_where($_[0]->{having});
- push(@{$self->{having_bind}}, @extra);
- $ret .= $self->_sqlcase(' having ').$frag;
- }
- if (defined $_[0]->{order_by}) {
- $ret .= $self->_order_by($_[0]->{order_by});
- }
- if (grep { $_ =~ /^-(desc|asc)/i } keys %{$_[0]}) {
- return $self->SUPER::_order_by($_[0]);
- }
- } elsif (ref $_[0] eq 'SCALAR') {
- $ret = $self->_sqlcase(' order by ').${ $_[0] };
- } elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
- my @order = @{+shift};
- $ret = $self->_sqlcase(' order by ')
- .join(', ', map {
- my $r = $self->_order_by($_, @_);
- $r =~ s/^ ?ORDER BY //i;
- $r;
- } @order);
- } else {
- $ret = $self->SUPER::_order_by(@_);
- }
- return $ret;
-}
-
-sub _order_directions {
- my ($self, $order) = @_;
- $order = $order->{order_by} if ref $order eq 'HASH';
- return $self->SUPER::_order_directions($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
- }
-}
-
-sub _recurse_from {
- my ($self, $from, @join) = @_;
- my @sqlf;
- push(@sqlf, $self->_make_as($from));
- foreach my $j (@join) {
- my ($to, $on) = @$j;
-
- # check whether a join type exists
- my $join_clause = '';
- my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
- if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
- $join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
- } else {
- $join_clause = ' JOIN ';
- }
- push(@sqlf, $join_clause);
-
- if (ref $to eq 'ARRAY') {
- push(@sqlf, '(', $self->_recurse_from(@$to), ')');
- } else {
- push(@sqlf, $self->_make_as($to));
- }
- push(@sqlf, ' ON ', $self->_join_condition($on));
- }
- return join('', @sqlf);
-}
-
-sub _bind_to_sql {
- my $self = shift;
- my $arr = shift;
- my $sql = shift @$$arr;
- $sql =~ s/\?/$self->_quote((shift @$$arr)->[1])/eg;
- return $sql
-}
-
-sub _make_as {
- my ($self, $from) = @_;
- return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
- : ref $_ eq 'REF' ? $self->_bind_to_sql($_)
- : $self->_quote($_))
- } reverse each %{$self->_skip_options($from)});
-}
-
-sub _skip_options {
- my ($self, $hash) = @_;
- my $clean_hash = {};
- $clean_hash->{$_} = $hash->{$_}
- for grep {!/^-/} keys %$hash;
- return $clean_hash;
-}
-
-sub _join_condition {
- my ($self, $cond) = @_;
- if (ref $cond eq 'HASH') {
- my %j;
- for (keys %$cond) {
- my $v = $cond->{$_};
- if (ref $v) {
- # XXX no throw_exception() in this package and croak() fails with strange results
- Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
- if ref($v) ne 'SCALAR';
- $j{$_} = $v;
- }
- else {
- my $x = '= '.$self->_quote($v); $j{$_} = \$x;
- }
- };
- return scalar($self->_recurse_where(\%j));
- } elsif (ref $cond eq 'ARRAY') {
- return join(' OR ', map { $self->_join_condition($_) } @$cond);
- } else {
- die "Can't handle this yet!";
- }
-}
-
-sub _quote {
- my ($self, $label) = @_;
- return '' unless defined $label;
- return "*" if $label eq '*';
- return $label unless $self->{quote_char};
- if(ref $self->{quote_char} eq "ARRAY"){
- return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
- if !defined $self->{name_sep};
- my $sep = $self->{name_sep};
- return join($self->{name_sep},
- map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
- split(/\Q$sep\E/,$label));
- }
- return $self->SUPER::_quote($label);
-}
-
-sub limit_dialect {
- my $self = shift;
- $self->{limit_dialect} = shift if @_;
- return $self->{limit_dialect};
-}
-
-sub quote_char {
- my $self = shift;
- $self->{quote_char} = shift if @_;
- return $self->{quote_char};
-}
-
-sub name_sep {
- my $self = shift;
- $self->{name_sep} = shift if @_;
- return $self->{name_sep};
-}
-
-} # End of BEGIN block
-
=head1 NAME
DBIx::Class::Storage::DBI - DBI storage handler
@@ -1976,38 +1606,7 @@
be with raw DBI.
-=head1 SQL METHODS
-The module defines a set of methods within the DBIC::SQL::Abstract
-namespace. These build on L<SQL::Abstract::Limit> to provide the
-SQL query functions.
-
-The following methods are extended:-
-
-=over 4
-
-=item delete
-
-=item insert
-
-=item select
-
-=item update
-
-=item limit_dialect
-
-See L</connect_info> for details.
-
-=item quote_char
-
-See L</connect_info> for details.
-
-=item name_sep
-
-See L</connect_info> for details.
-
-=back
-
=head1 AUTHORS
Matt S. Trout <mst at shadowcatsystems.co.uk>
Modified: DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage.pm
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage.pm 2009-05-11 13:39:33 UTC (rev 6208)
+++ DBIx-Class/0.08/branches/oracle-tweaks/lib/DBIx/Class/Storage.pm 2009-05-11 14:24:27 UTC (rev 6209)
@@ -328,7 +328,7 @@
=head2 sql_maker
Returns a C<sql_maker> object - normally an object of class
-C<DBIC::SQL::Abstract>.
+C<DBIx::Class::SQLAHacks>.
=cut
Modified: DBIx-Class/0.08/branches/oracle-tweaks/t/41orrible.t
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/t/41orrible.t 2009-05-11 13:39:33 UTC (rev 6208)
+++ DBIx-Class/0.08/branches/oracle-tweaks/t/41orrible.t 2009-05-11 14:24:27 UTC (rev 6209)
@@ -2,14 +2,14 @@
use warnings;
use Test::More;
-use DBIx::Class::Storage::DBI::Oracle::WhereJoins;
+use DBIx::Class::SQLAHacks::OracleJoins;
use lib qw(t/lib);
use DBIC::SqlMakerTest;
plan tests => 4;
-my $sa = new DBIC::SQL::Abstract::Oracle;
+my $sa = new DBIx::Class::SQLAHacks::OracleJoins;
$sa->limit_dialect('RowNum');
Modified: DBIx-Class/0.08/branches/oracle-tweaks/t/42toplimit.t
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/t/42toplimit.t 2009-05-11 13:39:33 UTC (rev 6208)
+++ DBIx-Class/0.08/branches/oracle-tweaks/t/42toplimit.t 2009-05-11 14:24:27 UTC (rev 6209)
@@ -6,7 +6,7 @@
plan tests => 1;
-my $sa = new DBIC::SQL::Abstract;
+my $sa = new DBIx::Class::SQLAHacks;
$sa->limit_dialect( 'Top' );
Modified: DBIx-Class/0.08/branches/oracle-tweaks/t/76joins.t
===================================================================
--- DBIx-Class/0.08/branches/oracle-tweaks/t/76joins.t 2009-05-11 13:39:33 UTC (rev 6208)
+++ DBIx-Class/0.08/branches/oracle-tweaks/t/76joins.t 2009-05-11 14:24:27 UTC (rev 6209)
@@ -33,7 +33,7 @@
}
# test the abstract join => SQL generator
-my $sa = new DBIC::SQL::Abstract;
+my $sa = new DBIx::Class::SQLAHacks;
my @j = (
{ child => 'person' },
More information about the Bast-commits
mailing list