X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=7d1ced1d2fbe59af693ed5598db485971401270e;hb=61bf0de5e9a3fd3d13dd7a97c2e8fb857f9d53c5;hp=27b115b3a9fd848d8f457b751a00988611235e3a;hpb=fdad5fab5f1d4f151b71205a46b839bcf1c28230;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 27b115b..7d1ced1 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -9,13 +9,12 @@ use DBI;
 use SQL::Abstract::Limit;
 use DBIx::Class::Storage::DBI::Cursor;
 use DBIx::Class::Storage::Statistics;
-use IO::File;
-use Scalar::Util 'blessed';
+use Scalar::Util qw/blessed weaken/;
 
 __PACKAGE__->mk_group_accessors('simple' =>
     qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
        _conn_pid _conn_tid disable_sth_caching cursor on_connect_do
-       transaction_depth/
+       transaction_depth unsafe/
 );
 
 BEGIN {
@@ -380,6 +379,23 @@ This only needs to be used in conjunction with L<quote_char>, and is used to
 specify the charecter that seperates elements (schemas, tables, columns) from 
 each other. In most cases this is simply a C<.>.
 
+=item unsafe
+
+This Storage driver normally installs its own C<HandleError>, sets
+C<RaiseError> on, and sets C<PrintError> off on all database handles,
+including those supplied by a coderef.  It does this so that it can
+have consistent and useful error behavior.
+
+If you set this option to a true value, Storage will not do its usual
+modifications to the database handle's C<RaiseError>, C<PrintError>, and
+C<HandleError> attributes, and instead relies on the settings in your
+connect_info DBI options (or the values you set in your connection
+coderef, in the case that you are connecting via coderef).
+
+Note that your custom settings can cause Storage to malfunction,
+especially if you set a C<HandleError> handler that suppresses exceptions
+and/or disable C<RaiseError>.
+
 =back
 
 These options can be mixed in with your other L<DBI> connection attributes,
@@ -390,12 +406,6 @@ Every time C<connect_info> is invoked, any previous settings for
 these options will be cleared before setting the new ones, regardless of
 whether any options are specified in the new C<connect_info>.
 
-Important note:  DBIC expects the returned database handle provided by 
-a subref argument to have RaiseError set on it.  If it doesn't, things
-might not work very well, YMMV.  If you don't use a subref, DBIC will
-force this setting for you anyways.  Setting HandleError to anything
-other than simple exception object wrapper might cause problems too.
-
 Another Important Note:
 
 DBIC can do some wonderful magic with handling exceptions,
@@ -470,7 +480,7 @@ sub connect_info {
 
   my $last_info = $dbi_info->[-1];
   if(ref $last_info eq 'HASH') {
-    for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
+    for my $storage_opt (qw/on_connect_do disable_sth_caching unsafe/) {
       if(my $value = delete $last_info->{$storage_opt}) {
         $self->$storage_opt($value);
       }
@@ -739,13 +749,13 @@ sub _connect {
   my ($self, @info) = @_;
 
   $self->throw_exception("You failed to provide any connection info")
-      if !@info;
+    if !@info;
 
   my ($old_connect_via, $dbh);
 
   if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
-      $old_connect_via = $DBI::connect_via;
-      $DBI::connect_via = 'connect';
+    $old_connect_via = $DBI::connect_via;
+    $DBI::connect_via = 'connect';
   }
 
   eval {
@@ -754,17 +764,23 @@ sub _connect {
     }
     else {
        $dbh = DBI->connect(@info);
-       $dbh->{RaiseError} = 1;
-       $dbh->{PrintError} = 0;
-       $dbh->{PrintWarn} = 0;
+    }
+
+    if(!$self->unsafe) {
+      my $weak_self = $self;
+      weaken($weak_self);
+      $dbh->{HandleError} = sub {
+          $weak_self->throw_exception("DBI Exception: $_[0]")
+      };
+      $dbh->{RaiseError} = 1;
+      $dbh->{PrintError} = 0;
     }
   };
 
   $DBI::connect_via = $old_connect_via if $old_connect_via;
 
-  if (!$dbh || $@) {
-    $self->throw_exception("DBI Connection failed: " . ($@ || $DBI::errstr));
-  }
+  $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
+    if !$dbh || $@;
 
   $dbh;
 }
@@ -831,88 +847,68 @@ sub txn_rollback {
 #  easier to override in NoBindVars without duping the rest.  It takes up
 #  all of _execute's args, and emits $sql, @bind.
 sub _prep_for_execute {
-  my ($self, $op, $extra_bind, $ident, @args) = @_;
+  my ($self, $op, $extra_bind, $ident, $args) = @_;
 
-  my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
+  my ($sql, @bind) = $self->sql_maker->$op($ident, @$args);
   unshift(@bind,
     map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
       if $extra_bind;
-  @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
 
-  return ($sql, @bind);
+  return ($sql, \@bind);
 }
 
-sub _execute {
-  my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+sub _dbh_execute {
+  my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
   
   if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) {
     $ident = $ident->from();
   }
-  
-  my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
-  unshift(@bind,
-    map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
-      if $extra_bind;
+
+  my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+
   if ($self->debug) {
       my @debug_bind =
-        map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
+        map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
       $self->debugobj->query_start($sql, @debug_bind);
   }
 
-  my ($rv, $sth);
-  RETRY: while (1) {
-    $sth = eval { $self->sth($sql,$op) };
-
-    if (!$sth || $@) {
-      $self->throw_exception(
-        'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
-      );
-    }
-
-    if ($sth) {
-      my $time = time();
-      $rv = eval {
-        my $placeholder_index = 1; 
+  my $sth = $self->sth($sql,$op);
 
-        foreach my $bound (@bind) {
+  my $placeholder_index = 1; 
 
-          my $attributes = {};
-          my($column_name, @data) = @$bound;
+  foreach my $bound (@$bind) {
+    my $attributes = {};
+    my($column_name, @data) = @$bound;
 
-          if( $bind_attributes ) {
-            $attributes = $bind_attributes->{$column_name}
-            if defined $bind_attributes->{$column_name};
-          }
+    if ($bind_attributes) {
+      $attributes = $bind_attributes->{$column_name}
+      if defined $bind_attributes->{$column_name};
+    }
 
-          foreach my $data (@data)
-          {
-            $data = ref $data ? ''.$data : $data; # stringify args
+    foreach my $data (@data) {
+      $data = ref $data ? ''.$data : $data; # stringify args
 
-            $sth->bind_param($placeholder_index, $data, $attributes);
-            $placeholder_index++;
-          }
-        }
-        $sth->execute();
-      };
-    
-      if ($@ || !$rv) {
-        $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr))
-          if $self->connected;
-        $self->_populate_dbh;
-      } else {
-        last RETRY;
-      }
-    } else {
-      $self->throw_exception("'$sql' did not generate a statement.");
+      $sth->bind_param($placeholder_index, $data, $attributes);
+      $placeholder_index++;
     }
-  } # While(1) to retry if disconencted
+  }
+
+  # Can this fail without throwing an exception anyways???
+  my $rv = $sth->execute();
+  $self->throw_exception($sth->errstr) if !$rv;
 
   if ($self->debug) {
      my @debug_bind =
-       map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind; 
+       map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind; 
      $self->debugobj->query_end($sql, @debug_bind);
   }
-  return (wantarray ? ($rv, $sth, @bind) : $rv);
+
+  return (wantarray ? ($rv, $sth, @$bind) : $rv);
+}
+
+sub _execute {
+    my $self = shift;
+    $self->dbh_do($self->can('_dbh_execute'), @_)
 }
 
 sub insert {
@@ -921,11 +917,8 @@ sub insert {
   my $ident = $source->from; 
   my $bind_attributes = $self->source_bind_attributes($source);
 
-  $self->throw_exception(
-    "Couldn't insert ".join(', ',
-      map "$_ => $to_insert->{$_}", keys %$to_insert
-    )." into ${ident}"
-  ) unless ($self->_execute('insert' => [], $source, $bind_attributes, $to_insert));
+  $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
+
   return $to_insert;
 }
 
@@ -948,8 +941,6 @@ sub insert_bulk {
 
 #  @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
 
-  my $rv;
-  
   ## This must be an arrayref, else nothing works!
   
   my $tuple_status = [];
@@ -957,47 +948,32 @@ sub insert_bulk {
   ##use Data::Dumper;
   ##print STDERR Dumper( $data, $sql, [@bind] );
 
-  if ($sth) {
-  
-    my $time = time();
-
-    ## Get the bind_attributes, if any exist
-    my $bind_attributes = $self->source_bind_attributes($source);
+  my $time = time();
 
-    ## Bind the values and execute
-    $rv = eval {
-
-     my $placeholder_index = 1; 
+  ## Get the bind_attributes, if any exist
+  my $bind_attributes = $self->source_bind_attributes($source);
 
-        foreach my $bound (@bind) {
+  ## Bind the values and execute
+  my $placeholder_index = 1; 
 
-          my $attributes = {};
-          my ($column_name, $data_index) = @$bound;
+  foreach my $bound (@bind) {
 
-          if( $bind_attributes ) {
-            $attributes = $bind_attributes->{$column_name}
-            if defined $bind_attributes->{$column_name};
-          }
+    my $attributes = {};
+    my ($column_name, $data_index) = @$bound;
 
-          my @data = map { $_->[$data_index] } @$data;
+    if( $bind_attributes ) {
+      $attributes = $bind_attributes->{$column_name}
+      if defined $bind_attributes->{$column_name};
+    }
 
-          $sth->bind_param_array( $placeholder_index, [@data], $attributes );
-          $placeholder_index++;
-      }
-      $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
+    my @data = map { $_->[$data_index] } @$data;
 
-    };
-   
-    if ($@ || !defined $rv) {
-      my $errors = '';
-      foreach my $tuple (@$tuple_status) {
-          $errors .= "\n" . $tuple->[1] if(ref $tuple);
-      }
-      $self->throw_exception("Error executing '$sql': ".($@ || $errors));
-    }
-  } else {
-    $self->throw_exception("'$sql' did not generate a statement.");
+    $sth->bind_param_array( $placeholder_index, [@data], $attributes );
+    $placeholder_index++;
   }
+  my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
+  $self->throw_exception($sth->errstr) if !$rv;
+
   if ($self->debug) {
       my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
       $self->debugobj->query_end($sql, @debug_bind);
@@ -1110,9 +1086,9 @@ sub _dbh_sth {
     ? $dbh->prepare($sql)
     : $dbh->prepare_cached($sql, {}, 3);
 
-  $self->throw_exception(
-    'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
-  ) if !$sth;
+  # XXX You would think RaiseError would make this impossible,
+  #  but apparently that's not true :(
+  $self->throw_exception($dbh->errstr) if !$sth;
 
   $sth;
 }
@@ -1253,8 +1229,9 @@ sub create_ddl_dir
   $version ||= $schema->VERSION || '1.x';
   $sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
 
-  eval "use SQL::Translator";
-  $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@;
+  $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.08: '}
+      . $self->_check_sqlt_message . q{'})
+          if !$self->_check_sqlt_version;
 
   my $sqlt = SQL::Translator->new({
 #      debug => 1,
@@ -1293,12 +1270,7 @@ sub create_ddl_dir
 
     if($preversion)
     {
-      eval "use SQL::Translator::Diff";
-      if($@)
-      {
-        warn("Can't diff versions without SQL::Translator::Diff: $@");
-        next;
-      }
+      require SQL::Translator::Diff;
 
       my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
 #      print "Previous version $prefilename\n";
@@ -1407,25 +1379,23 @@ sub deployment_statements {
       return join('', @rows);
   }
 
-  eval "use SQL::Translator";
-  if(!$@)
-  {
-    eval "use SQL::Translator::Parser::DBIx::Class;";
-    $self->throw_exception($@) if $@;
-    eval "use SQL::Translator::Producer::${type};";
-    $self->throw_exception($@) if $@;
-
-    # sources needs to be a parser arg, but for simplicty allow at top level 
-    # coming in
-    $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
-        if exists $sqltargs->{sources};
-
-    my $tr = SQL::Translator->new(%$sqltargs);
-    SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
-    return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
-  }
+  $self->throw_exception(q{Can't deploy without SQL::Translator 0.08: '}
+      . $self->_check_sqlt_message . q{'})
+          if !$self->_check_sqlt_version;
+
+  require SQL::Translator::Parser::DBIx::Class;
+  eval qq{use SQL::Translator::Producer::${type}};
+  $self->throw_exception($@) if $@;
+
+  # sources needs to be a parser arg, but for simplicty allow at top level 
+  # coming in
+  $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
+      if exists $sqltargs->{sources};
+
+  my $tr = SQL::Translator->new(%$sqltargs);
+  SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
+  return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
 
-  $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
   return;
 
 }
@@ -1433,16 +1403,21 @@ sub deployment_statements {
 sub deploy {
   my ($self, $schema, $type, $sqltargs, $dir) = @_;
   foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
-    for ( split(";\n", $statement)) {
-      next if($_ =~ /^--/);
-      next if(!$_);
-#      next if($_ =~ /^DROP/m);
-      next if($_ =~ /^BEGIN TRANSACTION/m);
-      next if($_ =~ /^COMMIT/m);
-      next if $_ =~ /^\s+$/; # skip whitespace only
-      $self->debugobj->query_start($_) if $self->debug;
-      $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions?
-      $self->debugobj->query_end($_) if $self->debug;
+    foreach my $line ( split(";\n", $statement)) {
+      next if($line =~ /^--/);
+      next if(!$line);
+#      next if($line =~ /^DROP/m);
+      next if($line =~ /^BEGIN TRANSACTION/m);
+      next if($line =~ /^COMMIT/m);
+      next if $line =~ /^\s+$/; # skip whitespace only
+      $self->debugobj->query_start($line) if $self->debug;
+      eval {
+        $self->dbh->do($line); # shouldn't be using ->dbh ?
+      };
+      if ($@) {
+        warn qq{$@ (running "${line}")};
+      }
+      $self->debugobj->query_end($line) if $self->debug;
     }
   }
 }
@@ -1481,6 +1456,22 @@ sub build_datetime_parser {
   return $type;
 }
 
+{
+    my $_check_sqlt_version; # private
+    my $_check_sqlt_message; # private
+    sub _check_sqlt_version {
+        return $_check_sqlt_version if defined $_check_sqlt_version;
+        eval 'use SQL::Translator 0.08';
+        $_check_sqlt_message = $@ ? $@ : '';
+        $_check_sqlt_version = $@ ? 0 : 1;
+    }
+
+    sub _check_sqlt_message {
+        _check_sqlt_version if !defined $_check_sqlt_message;
+        $_check_sqlt_message;
+    }
+}
+
 sub DESTROY {
   my $self = shift;
   return if !$self->_dbh;