[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / SQLAHacks.pm

package # Hide from PAUSE
  DBIx::Class::SQLAHacks;

use base qw/SQL::Abstract::Limit/;
use strict;
use warnings;
use Carp::Clan qw/^DBIx::Class/;

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 - 1;
  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) {
    if ($dbhname eq 'DB2') {
      return 'RowNumberOver';
    }
  }
  
  $self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}

sub select {
  my ($self, $table, $fields, $where, $order, @rest) = @_;
  local $self->{having_bind} = [];
  local $self->{from_bind} = [];

  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];
  croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
    # and anyway, SQL::Abstract::Limit will cause a barf if we don't first
  my ($sql, @where_bind) = $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, @{$self->{from_bind}}, @where_bind, @{$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) {
      if ($func eq 'distinct') {
        my $_fields = $fields->{$func};
        if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
          croak (
            'The select => { distinct => ... } syntax is not supported for multiple columns.'
           .' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
           .' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
          );
        }
        else {
          $_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
          carp (
            'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
           ." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
          );
        }
      }
      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->_fold_sqlbind( $fields );
  }
  else {
    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';
  if (ref $order eq 'HASH') {
    $order = [$self->_order_directions_hash($order)];
  } elsif (ref $order eq 'ARRAY') {
    $order = [map {
      if (ref $_ eq 'HASH') {
        $self->_order_directions_hash($_);
      } else {
        $_;
      }
    } @{ $order }];
  }
  return $self->SUPER::_order_directions($order);
}

sub _order_directions_hash {
  my ($self, $order) = @_;
  my @new_order;
  foreach my $key (keys %{ $order }) {
    if ($key =~ /^-(desc|asc)/i ) {
      my $direction = $1;
      my $type = ref $order->{ $key };
      if ($type eq 'ARRAY') {
        push @new_order, map( "$_ $direction", @{ $order->{ $key } } );
      } elsif (!$type) {
        push @new_order, "$order->{$key} $direction";
      } else {
        croak "hash order_by can only contain Scalar or Array, not $type";
      }
    } else {
      croak "$key is not a valid direction, use -asc or -desc";
    }
  }
  return @new_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 _fold_sqlbind {
  my ($self, $sqlbind) = @_;
  my $sql = shift @$$sqlbind;
  push @{$self->{from_bind}}, @$$sqlbind;
  return $sql;
}

sub _make_as {
  my ($self, $from) = @_;
  return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
                        : ref $_ eq 'REF'    ? $self->_fold_sqlbind($_)
                        : $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) {
        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 - This module is a subclass of SQL::Abstract::Limit
and includes a number of DBIC-specific workarounds, not yet suitable for
inclusion into SQLA proper.

=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
Commit	Line	Data
6f4ddea1	1	package # Hide from PAUSE
855c6fd0	2	DBIx::Class::SQLAHacks;
6f4ddea1	3
6f4ddea1	4	use base qw/SQL::Abstract::Limit/;
e3764383	5	use strict;
e3764383	6	use warnings;
db56cf3d	7	use Carp::Clan qw/^DBIx::Class/;
6f4ddea1	8
	9	sub new {
	10	my $self = shift->SUPER::new(@_);
	11
	12	# This prevents the caching of $dbh in S::A::L, I believe
	13	# If limit_dialect is a ref (like a $dbh), go ahead and replace
	14	# it with what it resolves to:
	15	$self->{limit_dialect} = $self->_find_syntax($self->{limit_dialect})
	16	if ref $self->{limit_dialect};
	17
	18	$self;
	19	}
	20
	21
6f4ddea1	22	# Some databases (sqlite) do not handle multiple parenthesis
	23	# around in/between arguments. A tentative x IN ( ( 1, 2 ,3) )
	24	# is interpreted as x IN 1 or something similar.
	25	#
	26	# Since we currently do not have access to the SQLA AST, resort
	27	# to barbaric mutilation of any SQL supplied in literal form
	28
	29	sub _strip_outer_paren {
	30	my ($self, $arg) = @_;
	31
	32	return $self->_SWITCH_refkind ($arg, {
	33	ARRAYREFREF => sub {
	34	$$arg->[0] = __strip_outer_paren ($$arg->[0]);
	35	return $arg;
	36	},
	37	SCALARREF => sub {
	38	return \__strip_outer_paren( $$arg );
	39	},
	40	FALLBACK => sub {
	41	return $arg
	42	},
	43	});
	44	}
	45
	46	sub __strip_outer_paren {
	47	my $sql = shift;
	48
	49	if ($sql and not ref $sql) {
	50	while ($sql =~ /^ \s* \( (.) \) \s $/x ) {
	51	$sql = $1;
	52	}
	53	}
	54
	55	return $sql;
	56	}
	57
	58	sub _where_field_IN {
	59	my ($self, $lhs, $op, $rhs) = @_;
	60	$rhs = $self->_strip_outer_paren ($rhs);
	61	return $self->SUPER::_where_field_IN ($lhs, $op, $rhs);
	62	}
	63
	64	sub _where_field_BETWEEN {
	65	my ($self, $lhs, $op, $rhs) = @_;
	66	$rhs = $self->_strip_outer_paren ($rhs);
	67	return $self->SUPER::_where_field_BETWEEN ($lhs, $op, $rhs);
	68	}
	69
	70
	71
	72	# DB2 is the only remaining DB using this. Even though we are not sure if
	73	# RowNumberOver is still needed here (should be part of SQLA) leave the
	74	# code in place
	75	sub _RowNumberOver {
	76	my ($self, $sql, $order, $rows, $offset ) = @_;
	77
	78	$offset += 1;
03e1d9af	79	my $last = $rows + $offset - 1;
6f4ddea1	80	my ( $order_by ) = $self->_order_by( $order );
	81
	82	$sql = <<"SQL";
	83	SELECT * FROM
	84	(
	85	SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
	86	$sql
	87	$order_by
	88	) Q1
	89	) Q2
	90	WHERE ROW_NUM BETWEEN $offset AND $last
	91
	92	SQL
	93
	94	return $sql;
	95	}
	96
	97
	98	# While we're at it, this should make LIMIT queries more efficient,
	99	# without digging into things too deeply
	100	use Scalar::Util 'blessed';
	101	sub _find_syntax {
	102	my ($self, $syntax) = @_;
	103
	104	# DB2 is the only remaining DB using this. Even though we are not sure if
	105	# RowNumberOver is still needed here (should be part of SQLA) leave the
	106	# code in place
	107	my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
a964a928	108	if(ref($self) && $dbhname) {
	109	if ($dbhname eq 'DB2') {
	110	return 'RowNumberOver';
	111	}
6f4ddea1	112	}
	113
	114	$self->{_cached_syntax} \|\|= $self->SUPER::_find_syntax($syntax);
	115	}
	116
	117	sub select {
	118	my ($self, $table, $fields, $where, $order, @rest) = @_;
db56cf3d	119	local $self->{having_bind} = [];
	120	local $self->{from_bind} = [];
	121
6f4ddea1	122	if (ref $table eq 'SCALAR') {
	123	$table = $$table;
	124	}
	125	elsif (not ref $table) {
	126	$table = $self->_quote($table);
	127	}
	128	local $self->{rownum_hack_count} = 1
	129	if (defined $rest[0] && $self->{limit_dialect} eq 'RowNum');
	130	@rest = (-1) unless defined $rest[0];
e8fcf76f	131	croak "LIMIT 0 Does Not Compute" if $rest[0] == 0;
6f4ddea1	132	# and anyway, SQL::Abstract::Limit will cause a barf if we don't first
db56cf3d	133	my ($sql, @where_bind) = $self->SUPER::select(
6f4ddea1	134	$table, $self->_recurse_fields($fields), $where, $order, @rest
	135	);
	136	$sql .=
	137	$self->{for} ?
	138	(
	139	$self->{for} eq 'update' ? ' FOR UPDATE' :
	140	$self->{for} eq 'shared' ? ' FOR SHARE' :
	141	''
	142	) :
	143	''
	144	;
db56cf3d	145	return wantarray ? ($sql, @{$self->{from_bind}}, @where_bind, @{$self->{having_bind}}) : $sql;
6f4ddea1	146	}
	147
	148	sub insert {
	149	my $self = shift;
	150	my $table = shift;
	151	$table = $self->_quote($table) unless ref($table);
	152	$self->SUPER::insert($table, @_);
	153	}
	154
	155	sub update {
	156	my $self = shift;
	157	my $table = shift;
	158	$table = $self->_quote($table) unless ref($table);
	159	$self->SUPER::update($table, @_);
	160	}
	161
	162	sub delete {
	163	my $self = shift;
	164	my $table = shift;
	165	$table = $self->_quote($table) unless ref($table);
	166	$self->SUPER::delete($table, @_);
	167	}
	168
	169	sub _emulate_limit {
	170	my $self = shift;
	171	if ($_[3] == -1) {
	172	return $_[1].$self->_order_by($_[2]);
	173	} else {
	174	return $self->SUPER::_emulate_limit(@_);
	175	}
	176	}
	177
	178	sub _recurse_fields {
	179	my ($self, $fields, $params) = @_;
	180	my $ref = ref $fields;
	181	return $self->_quote($fields) unless $ref;
	182	return $$fields if $ref eq 'SCALAR';
	183
	184	if ($ref eq 'ARRAY') {
	185	return join(', ', map {
	186	$self->_recurse_fields($_)
	187	.(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
	188	? ' AS col'.$self->{rownum_hack_count}++
	189	: '')
	190	} @$fields);
	191	} elsif ($ref eq 'HASH') {
	192	foreach my $func (keys %$fields) {
db56cf3d	193	if ($func eq 'distinct') {
	194	my $_fields = $fields->{$func};
	195	if (ref $_fields eq 'ARRAY' && @{$_fields} > 1) {
04ebc6f4	196	croak (
	197	'The select => { distinct => ... } syntax is not supported for multiple columns.'
	198	.' Instead please use { group_by => [ qw/' . (join ' ', @$_fields) . '/ ] }'
	199	.' or { select => [ qw/' . (join ' ', @$_fields) . '/ ], distinct => 1 }'
	200	);
db56cf3d	201	}
	202	else {
	203	$_fields = @{$_fields}[0] if ref $_fields eq 'ARRAY';
04ebc6f4	204	carp (
	205	'The select => { distinct => ... } syntax will be deprecated in DBIC version 0.09,'
	206	." please use { group_by => '${_fields}' } or { select => '${_fields}', distinct => 1 }"
	207	);
db56cf3d	208	}
db56cf3d	209	}
6f4ddea1	210	return $self->_sqlcase($func)
	211	.'( '.$self->_recurse_fields($fields->{$func}).' )';
	212	}
	213	}
	214	# Is the second check absolutely necessary?
	215	elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
db56cf3d	216	return $self->_fold_sqlbind( $fields );
6f4ddea1	217	}
6f4ddea1	218	else {
e8fcf76f	219	croak($ref . qq{ unexpected in _recurse_fields()})
6f4ddea1	220	}
	221	}
	222
	223	sub _order_by {
	224	my $self = shift;
	225	my $ret = '';
	226	my @extra;
	227	if (ref $_[0] eq 'HASH') {
	228	if (defined $_[0]->{group_by}) {
	229	$ret = $self->_sqlcase(' group by ')
	230	.$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
	231	}
	232	if (defined $_[0]->{having}) {
	233	my $frag;
	234	($frag, @extra) = $self->_recurse_where($_[0]->{having});
	235	push(@{$self->{having_bind}}, @extra);
	236	$ret .= $self->_sqlcase(' having ').$frag;
	237	}
	238	if (defined $_[0]->{order_by}) {
	239	$ret .= $self->_order_by($_[0]->{order_by});
	240	}
	241	if (grep { $_ =~ /^-(desc\|asc)/i } keys %{$_[0]}) {
	242	return $self->SUPER::_order_by($_[0]);
	243	}
	244	} elsif (ref $_[0] eq 'SCALAR') {
	245	$ret = $self->_sqlcase(' order by ').${ $_[0] };
	246	} elsif (ref $_[0] eq 'ARRAY' && @{$_[0]}) {
	247	my @order = @{+shift};
	248	$ret = $self->_sqlcase(' order by ')
	249	.join(', ', map {
	250	my $r = $self->_order_by($_, @_);
	251	$r =~ s/^ ?ORDER BY //i;
	252	$r;
	253	} @order);
	254	} else {
	255	$ret = $self->SUPER::_order_by(@_);
	256	}
	257	return $ret;
	258	}
	259
	260	sub _order_directions {
	261	my ($self, $order) = @_;
	262	$order = $order->{order_by} if ref $order eq 'HASH';
fd4cb60a	263	if (ref $order eq 'HASH') {
	264	$order = [$self->_order_directions_hash($order)];
	265	} elsif (ref $order eq 'ARRAY') {
	266	$order = [map {
	267	if (ref $_ eq 'HASH') {
	268	$self->_order_directions_hash($_);
	269	} else {
	270	$_;
	271	}
	272	} @{ $order }];
	273	}
6f4ddea1	274	return $self->SUPER::_order_directions($order);
	275	}
	276
fd4cb60a	277	sub _order_directions_hash {
fd4cb60a	278	my ($self, $order) = @_;
e3764383	279	my @new_order;
	280	foreach my $key (keys %{ $order }) {
	281	if ($key =~ /^-(desc\|asc)/i ) {
	282	my $direction = $1;
	283	my $type = ref $order->{ $key };
	284	if ($type eq 'ARRAY') {
	285	push @new_order, map( "$_ $direction", @{ $order->{ $key } } );
	286	} elsif (!$type) {
	287	push @new_order, "$order->{$key} $direction";
	288	} else {
	289	croak "hash order_by can only contain Scalar or Array, not $type";
	290	}
	291	} else {
	292	croak "$key is not a valid direction, use -asc or -desc";
	293	}
	294	}
	295	return @new_order;
fd4cb60a	296	}
fd4cb60a	297
6f4ddea1	298	sub _table {
	299	my ($self, $from) = @_;
	300	if (ref $from eq 'ARRAY') {
	301	return $self->_recurse_from(@$from);
	302	} elsif (ref $from eq 'HASH') {
	303	return $self->_make_as($from);
	304	} else {
	305	return $from; # would love to quote here but _table ends up getting called
	306	# twice during an ->select without a limit clause due to
	307	# the way S::A::Limit->select works. should maybe consider
	308	# bypassing this and doing S::A::select($self, ...) in
	309	# our select method above. meantime, quoting shims have
	310	# been added to select/insert/update/delete here
	311	}
	312	}
	313
	314	sub _recurse_from {
	315	my ($self, $from, @join) = @_;
	316	my @sqlf;
	317	push(@sqlf, $self->_make_as($from));
	318	foreach my $j (@join) {
	319	my ($to, $on) = @$j;
	320
	321	# check whether a join type exists
	322	my $join_clause = '';
	323	my $to_jt = ref($to) eq 'ARRAY' ? $to->[0] : $to;
	324	if (ref($to_jt) eq 'HASH' and exists($to_jt->{-join_type})) {
	325	$join_clause = ' '.uc($to_jt->{-join_type}).' JOIN ';
	326	} else {
	327	$join_clause = ' JOIN ';
	328	}
	329	push(@sqlf, $join_clause);
	330
	331	if (ref $to eq 'ARRAY') {
	332	push(@sqlf, '(', $self->_recurse_from(@$to), ')');
	333	} else {
	334	push(@sqlf, $self->_make_as($to));
	335	}
	336	push(@sqlf, ' ON ', $self->_join_condition($on));
	337	}
	338	return join('', @sqlf);
	339	}
	340
db56cf3d	341	sub _fold_sqlbind {
	342	my ($self, $sqlbind) = @_;
	343	my $sql = shift @$$sqlbind;
	344	push @{$self->{from_bind}}, @$$sqlbind;
	345	return $sql;
6f4ddea1	346	}
	347
	348	sub _make_as {
	349	my ($self, $from) = @_;
db56cf3d	350	return join(' ', map { (ref $_ eq 'SCALAR' ? $$_
	351	: ref $_ eq 'REF' ? $self->_fold_sqlbind($_)
	352	: $self->_quote($_))
6f4ddea1	353	} reverse each %{$self->_skip_options($from)});
	354	}
	355
	356	sub _skip_options {
	357	my ($self, $hash) = @_;
	358	my $clean_hash = {};
	359	$clean_hash->{$_} = $hash->{$_}
	360	for grep {!/^-/} keys %$hash;
	361	return $clean_hash;
	362	}
	363
	364	sub _join_condition {
	365	my ($self, $cond) = @_;
	366	if (ref $cond eq 'HASH') {
	367	my %j;
	368	for (keys %$cond) {
	369	my $v = $cond->{$_};
	370	if (ref $v) {
e8fcf76f	371	croak (ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
6f4ddea1	372	if ref($v) ne 'SCALAR';
	373	$j{$_} = $v;
	374	}
	375	else {
	376	my $x = '= '.$self->_quote($v); $j{$_} = \$x;
	377	}
	378	};
	379	return scalar($self->_recurse_where(\%j));
	380	} elsif (ref $cond eq 'ARRAY') {
	381	return join(' OR ', map { $self->_join_condition($_) } @$cond);
	382	} else {
	383	die "Can't handle this yet!";
	384	}
	385	}
	386
	387	sub _quote {
	388	my ($self, $label) = @_;
	389	return '' unless defined $label;
	390	return "" if $label eq '';
	391	return $label unless $self->{quote_char};
	392	if(ref $self->{quote_char} eq "ARRAY"){
	393	return $self->{quote_char}->[0] . $label . $self->{quote_char}->[1]
	394	if !defined $self->{name_sep};
	395	my $sep = $self->{name_sep};
	396	return join($self->{name_sep},
	397	map { $self->{quote_char}->[0] . $_ . $self->{quote_char}->[1] }
	398	split(/\Q$sep\E/,$label));
	399	}
	400	return $self->SUPER::_quote($label);
	401	}
	402
	403	sub limit_dialect {
	404	my $self = shift;
	405	$self->{limit_dialect} = shift if @_;
	406	return $self->{limit_dialect};
	407	}
	408
	409	sub quote_char {
	410	my $self = shift;
	411	$self->{quote_char} = shift if @_;
	412	return $self->{quote_char};
	413	}
	414
	415	sub name_sep {
	416	my $self = shift;
	417	$self->{name_sep} = shift if @_;
	418	return $self->{name_sep};
	419	}
	420
	421	1;
	422
	423	__END__
	424
	425	=pod
	426
	427	=head1 NAME
	428
855c6fd0	429	DBIx::Class::SQLAHacks - This module is a subclass of SQL::Abstract::Limit
	430	and includes a number of DBIC-specific workarounds, not yet suitable for
	431	inclusion into SQLA proper.
6f4ddea1	432
	433	=head1 METHODS
	434
	435	=head2 new
	436
	437	Tries to determine limit dialect.
	438
	439	=head2 select
	440
	441	Quotes table names, handles "limit" dialects (e.g. where rownum between x and
	442	y), supports SELECT ... FOR UPDATE and SELECT ... FOR SHARE.
	443
	444	=head2 insert update delete
	445
	446	Just quotes table names.
	447
	448	=head2 limit_dialect
	449
	450	Specifies the dialect of used for implementing an SQL "limit" clause for
	451	restricting the number of query results returned. Valid values are: RowNum.
	452
	453	See L<DBIx::Class::Storage::DBI/connect_info> for details.
	454
	455	=head2 name_sep
	456
	457	Character separating quoted table names.
	458
	459	See L<DBIx::Class::Storage::DBI/connect_info> for details.
	460
	461	=head2 quote_char
	462
	463	Set to an array-ref to specify separate left and right quotes for table names.
	464
	465	See L<DBIx::Class::Storage::DBI/connect_info> for details.
	466
	467	=cut
	468