X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=aabb975114085c32b9d858e0701bf6f9fdf70619;hb=484c9dda865880cd4e1cda8e0117f1d073a6aa7e;hp=623da440202449dae03ef6e818b6d8662c7be3f7;hpb=20a2c9543ec0c19b46a0b4bab7dcc2d0cd9138a5;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 623da44..aabb975 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -3,25 +3,94 @@ package DBIx::Class::Storage::DBI; use strict; use warnings; use DBI; +use SQL::Abstract::Limit; +use DBIx::Class::Storage::DBI::Cursor; -use base qw/DBIx::Class/; +BEGIN { -__PACKAGE__->load_components(qw/SQL::Abstract SQL Exception AccessorGroup/); +package DBIC::SQL::Abstract; # Temporary. Merge upstream. -__PACKAGE__->mk_group_accessors('simple' => qw/connect_info _dbh/); +use base qw/SQL::Abstract::Limit/; -sub new { - bless({}, ref $_[0] || $_[0]); +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; + } +} + +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 = ''; + if (ref($to) eq 'HASH' and exists($to->{-join_type})) { + $join_clause = ' '.uc($to->{-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 _make_as { + my ($self, $from) = @_; + return join(' ', map { $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 get_simple { - my ($self, $get) = @_; - return $self->{$get}; +sub _join_condition { + my ($self, $cond) = @_; + die "no chance" unless ref $cond eq 'HASH'; + my %j; + for (keys %$cond) { my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x; }; + return $self->_recurse_where(\%j); } -sub set_simple { - my ($self, $set, $val) = @_; - return $self->{$set} = $val; +sub _quote { + my ($self, $label) = @_; + return '' unless defined $label; + return $self->SUPER::_quote($label); +} + +} # End of BEGIN block + +use base qw/DBIx::Class/; + +__PACKAGE__->load_components(qw/Exception AccessorGroup/); + +__PACKAGE__->mk_group_accessors('simple' => + qw/connect_info _dbh _sql_maker debug cursor/); + +sub new { + my $new = bless({}, ref $_[0] || $_[0]); + $new->cursor("DBIx::Class::Storage::DBI::Cursor"); + $new->debug(1) if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}; + return $new; } =head1 NAME @@ -49,6 +118,14 @@ sub dbh { return $self->_dbh; } +sub sql_maker { + my ($self) = @_; + unless ($self->_sql_maker) { + $self->_sql_maker(new DBIC::SQL::Abstract( limit_dialect => $self->dbh )); + } + return $self->_sql_maker; +} + sub _populate_dbh { my ($self) = @_; my @info = @{$self->connect_info || []}; @@ -80,50 +157,59 @@ Issues a rollback again the current dbh sub rollback { $_[0]->dbh->rollback; } +sub _execute { + my ($self, $op, $extra_bind, $ident, @args) = @_; + my ($sql, @bind) = $self->sql_maker->$op($ident, @args); + unshift(@bind, @$extra_bind) if $extra_bind; + warn "$sql: @bind" if $self->debug; + my $sth = $self->sth($sql); + @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args + my $rv = $sth->execute(@bind); + return (wantarray ? ($rv, $sth, @bind) : $rv); +} + sub insert { my ($self, $ident, $to_insert) = @_; - my $sql = $self->create_sql('insert', [ keys %{$to_insert} ], $ident, undef); - my $sth = $self->sth($sql); - $sth->execute(values %{$to_insert}); $self->throw( "Couldn't insert ".join(', ', map "$_ => $to_insert->{$_}", keys %$to_insert)." into ${ident}" ) - unless $sth->rows; + unless ($self->_execute('insert' => [], $ident, $to_insert) > 0); return $to_insert; } sub update { - my ($self, $ident, $to_update, $condition) = @_; - my $attrs = { }; - my $set_sql = $self->_cond_resolve($to_update, $attrs, ','); - $set_sql =~ s/^\(//; - $set_sql =~ s/\)$//; - my $cond_sql = $self->_cond_resolve($condition, $attrs); - my $sql = $self->create_sql('update', $set_sql, $ident, $cond_sql); - my $sth = $self->sth($sql); - my $rows = $sth->execute( @{$attrs->{bind}||[]} ); - return $rows; + return shift->_execute('update' => [], @_); } sub delete { - my ($self, $ident, $condition) = @_; - my $attrs = { }; - my $cond_sql = $self->_cond_resolve($condition, $attrs); - my $sql = $self->create_sql('delete', undef, $ident, $cond_sql); - #warn "$sql ".join(', ',@{$attrs->{bind}||[]}); - my $sth = $self->sth($sql); - return $sth->execute( @{$attrs->{bind}||[]} ); + return shift->_execute('delete' => [], @_); } -sub select { +sub _select { my ($self, $ident, $select, $condition, $attrs) = @_; - $attrs ||= { }; - #my $select_sql = $self->_cond_resolve($select, $attrs, ','); - my $cond_sql = $self->_cond_resolve($condition, $attrs); - 1 while $cond_sql =~ s/^\s*\(\s*(.*ORDER.*)\s*\)\s*$/$1/; - my $sql = $self->create_sql('select', $select, $ident, $cond_sql); - #warn $sql.' '.join(', ', @{$attrs->{bind}||[]}); - my $sth = $self->sth($sql); - $sth->execute( @{$attrs->{bind}||[]} ); - return $sth; + my $order = $attrs->{order_by}; + if (ref $condition eq 'SCALAR') { + $order = $1 if $$condition =~ s/ORDER BY (.*)$//i; + } + my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order); + if ($attrs->{software_limit} || + $self->sql_maker->_default_limit_syntax eq "GenericSubQ") { + $attrs->{software_limit} = 1; + } else { + push @args, $attrs->{rows}, $attrs->{offset}; + } + return $self->_execute(@args); +} + +sub select { + my $self = shift; + my ($ident, $select, $condition, $attrs) = @_; + my ($rv, $sth, @bind) = $self->_select(@_); + return $self->cursor->new($sth, \@bind, $attrs); +} + +sub select_single { + my $self = shift; + my ($rv, $sth, @bind) = $self->_select(@_); + return $sth->fetchrow_array; } sub sth { @@ -136,7 +222,9 @@ sub sth { =head1 AUTHORS -Matt S. Trout +Matt S. Trout + +Andy Grundman =head1 LICENSE