X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FOracle%2FGeneric.pm;h=92a920a75a898c5ad26e9ad7708ad2798edf4793;hb=5db2758de644d53e07cd3e05f0e9037bf40116fc;hp=cb5d62bd01a76d4a72027eded051999ef6c0ecba;hpb=7a63d4457137972821c5cb38d33d63994e41fcdf;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
index cb5d62b..92a920a 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -26,6 +26,9 @@ This class implements autoincrements for Oracle.
 
 use Carp::Clan qw/^DBIx::Class/;
 
+use DBD::Oracle qw( :ora_types );
+#use constant ORA_BLOB => 113;  ## ORA_CLOB is 112
+
 use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
 
 # __PACKAGE__->load_components(qw/PK::Auto/);
@@ -55,8 +58,23 @@ sub _dbh_get_autoinc_seq {
   # trigger_body is a LONG
   $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
 
-  my $sth = $dbh->prepare($sql);
-  $sth->execute( uc($source->name) );
+  my $sth;
+
+  # check for fully-qualified name (eg. SCHEMA.TABLENAME)
+  if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
+    $sql = q{
+      SELECT trigger_body FROM ALL_TRIGGERS t
+      WHERE t.owner = ? AND t.table_name = ?
+      AND t.triggering_event = 'INSERT'
+      AND t.status = 'ENABLED'
+    };
+    $sth = $dbh->prepare($sql);
+    $sth->execute( uc($schema), uc($table) );
+  }
+  else {
+    $sth = $dbh->prepare($sql);
+    $sth->execute( uc( $source->name ) );
+  }
   while (my ($insert_trigger) = $sth->fetchrow_array) {
     return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
   }
@@ -69,42 +87,65 @@ sub _sequence_fetch {
   return $id;
 }
 
+=head2 connected
+
+Returns true if we have an open (and working) database connection, false if it is not (yet)
+open (or does not work). (Executes a simple SELECT to make sure it works.)
+
+The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
+OCIPing but just gets the server version, which doesn't help if someone killed
+your session.
+
+=cut
+
+sub connected {
+  my $self = shift;
+
+  if (not $self->SUPER::connected(@_)) {
+    return 0;
+  }
+  else {
+    my $dbh = $self->_dbh;
+
+    local $dbh->{RaiseError} = 1;
+
+    eval {
+      my $ping_sth = $dbh->prepare_cached("select 1 from dual");
+      $ping_sth->execute;
+      $ping_sth->finish;
+    };
+
+    return $@ ? 0 : 1;
+  }
+}
+
 sub _dbh_execute {
   my $self = shift;
   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 
   my $wantarray = wantarray;
-  my @res;
-  my $exception;
 
-  my $try = 2;
-  
-  while ($try--) {
-    eval {
-      if ($wantarray) {
-        @res    = $self->SUPER::_dbh_execute(@_);
+  my (@res, $exception, $retried);
+
+  RETRY: {
+    do {
+      eval {
+        if ($wantarray) {
+          @res    = $self->SUPER::_dbh_execute(@_);
+        } else {
+          $res[0] = $self->SUPER::_dbh_execute(@_);
+        }
+      };
+      $exception = $@;
+      if ($exception =~ /ORA-01003/) {
+        # ORA-01003: no statement parsed (someone changed the table somehow,
+        # invalidating your cursor.)
+        my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+        delete $dbh->{CachedKids}{$sql};
       } else {
-        $res[0] = $self->SUPER::_dbh_execute(@_);
+        last RETRY;
       }
-    };
-    $exception = $@;
-    if ($exception =~ /ORA-(?:00028|01012)/) {
-# ORA-00028: your session has been killed
-# ORA-01012: not logged on
-      $self->disconnect;
-
-      $self->throw_exception($exception) if $self->{_in_dbh_do};
-      $self->throw_exception($exception) if $self->transaction_depth;
-
-      $self->ensure_connected;
-    } elsif ($exception =~ /ORA-01003/) { # invalid cursor
-# ORA-01003: no statement parsed (someone renamed a column or something,
-# invalidating your cursor.)
-      my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
-      delete $dbh->{CachedKids}{$sql};
-    } else {
-      last;
-    }
+    } while (not $retried++);
   }
 
   $self->throw_exception($exception) if $exception;
@@ -152,6 +193,48 @@ sub _svp_begin {
     $self->dbh->do("SAVEPOINT $name");
 }
 
+=head2 source_bind_attributes
+
+Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
+with the driver assuming your input is the deprecated LONG type if you
+encode it as a hex string.  That ain't gonna fly at larger values, where
+you'll discover you have to do what this does.
+
+This method had to be overridden because we need to set ora_field to the
+actual column, and that isn't passed to the call (provided by Storage) to
+bind_attribute_by_data_type.
+
+According to L<DBD::Oracle>, the ora_field isn't always necessary, but
+adding it doesn't hurt, and will save your bacon if you're modifying a
+table with more than one LOB column.
+
+=cut
+
+sub source_bind_attributes 
+{
+	my $self = shift;
+	my($source) = @_;
+
+	my %bind_attributes;
+
+	foreach my $column ($source->columns) {
+		my $data_type = $source->column_info($column)->{data_type} || '';
+		next unless $data_type;
+
+		my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
+
+		if ($data_type =~ /^[BC]LOB$/i) {
+			$column_bind_attrs{'ora_type'}
+				= uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
+			$column_bind_attrs{'ora_field'} = $column;
+		}
+
+		$bind_attributes{$column} = \%column_bind_attrs;
+	}
+
+	return \%bind_attributes;
+}
+
 # Oracle automatically releases a savepoint when you start another one with the
 # same name.
 sub _svp_release { 1 }