X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=d54b1c13a5210cc0d3fbb67ff80c1b5029db54e2;hb=1d996af5628494239833f555de01e8075a40ef95;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..d54b1c1 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -3,25 +3,150 @@ 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 select {
+  my ($self, $table, $fields, $where, $order, @rest) = @_;
+  @rest = (-1) unless defined $rest[0];
+  $self->SUPER::select($table, $self->_recurse_fields($fields), 
+                         $where, $order, @rest);
+}
+
+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) = @_;
+  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($_) } @$fields);
+  } elsif ($ref eq 'HASH') {
+    foreach my $func (keys %$fields) {
+      return $self->_sqlcase($func)
+        .'( '.$self->_recurse_fields($fields->{$func}).' )';
+    }
+  }
+}
+
+sub _order_by {
+  my $self = shift;
+  my $ret = '';
+  if (ref $_[0] eq 'HASH') {
+    if (defined $_[0]->{group_by}) {
+      $ret = $self->_sqlcase(' group by ')
+               .$self->_recurse_fields($_[0]->{group_by});
+    }
+    if (defined $_[0]->{order_by}) {
+      $ret .= $self->SUPER::_order_by($_[0]->{order_by});
+    }
+  } else {
+    $ret = $self->SUPER::_order_by(@_);
+  }
+  return $ret;
 }
 
-sub get_simple {
-  my ($self, $get) = @_;
-  return $self->{$get};
+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 set_simple {
-  my ($self, $set, $val) = @_;
-  return $self->{$set} = $val;
+sub _make_as {
+  my ($self, $from) = @_;
+  return join(' ', map { (ref $_ eq 'SCALAR' ? $$_ : $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 $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x; };
+    return $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 $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/);
+
+our $TRANSACTION = 0;
+
+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 
@@ -36,8 +161,6 @@ This class represents the connection to the database
 
 =head1 METHODS
 
-=over 4
-
 =cut
 
 sub dbh {
@@ -49,6 +172,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 || []};
@@ -60,83 +191,118 @@ sub _connect {
   return DBI->connect(@info);
 }
 
-=item commit
+=head2 txn_begin
 
-  $class->commit;
-
-Issues a commit again the current dbh
+Calls begin_work on the current dbh.
 
 =cut
 
-sub commit { $_[0]->dbh->commit; }
+sub txn_begin {
+  $_[0]->dbh->begin_work if $TRANSACTION++ == 0 and $_[0]->dbh->{AutoCommit};
+}
+
+=head2 txn_commit
+
+Issues a commit against the current dbh.
+
+=cut
 
-=item rollback
+sub txn_commit {
+  if ($TRANSACTION == 0) {
+    $_[0]->dbh->commit;
+  }
+  else {
+    $_[0]->dbh->commit if --$TRANSACTION == 0;    
+  }
+}
 
-  $class->rollback;
+=head2 txn_rollback
 
-Issues a rollback again the current dbh
+Issues a rollback against the current dbh.
 
 =cut
 
-sub rollback { $_[0]->dbh->rollback; }
+sub txn_rollback {
+  if ($TRANSACTION == 0) {
+    $_[0]->dbh->rollback;
+  }
+  else {
+    --$TRANSACTION == 0 ? $_[0]->dbh->rollback : die $@;    
+  }
+}
+
+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,$op);
+  @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));
   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;
+  }
+  if (exists $attrs->{group_by}) {
+    $order = { group_by => $attrs->{group_by},
+               ($order ? (order_by => $order) : ()) };
+  }
+  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 {
-  shift->dbh->prepare(@_);
+  my ($self, $sql, $op) = @_;
+  my $meth = (defined $op && $op ne 'select' ? 'prepare_cached' : 'prepare');
+  return $self->dbh->$meth($sql);
 }
 
 1;
 
-=back
-
 =head1 AUTHORS
 
-Matt S. Trout <perl-stuff@trout.me.uk>
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+Andy Grundman <andy@hybridized.org>
 
 =head1 LICENSE