X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FOracle%2FGeneric.pm;h=c107934024b81109180f6d0ffca3481b1e11cf23;hb=9720202815dbafee0d9e944e3f8258d4aca446d4;hp=12a14d3f429b8f0bce41708ead3148b7523726e7;hpb=fcb52f084cfd136ebd017f1faac89bd8d6c25dee;p=dbsrgits%2FDBIx-Class-Historic.git

diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
index 12a14d3..c107934 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -164,7 +164,7 @@ sub _dbh_get_autoinc_seq {
     'ALL_TRIGGERS',
     [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
     {
-      $schema ? (OWNER => $schema) : (),
+      OWNER => $schema,
       TABLE_NAME => $table || $source_name,
       TRIGGERING_EVENT => { -like => '%INSERT%' },  # this will also catch insert_or_update
       TRIGGER_TYPE => { -like => '%BEFORE%' },      # we care only about 'before' triggers
@@ -174,6 +174,7 @@ sub _dbh_get_autoinc_seq {
 
   # to find all the triggers that mention the column in question a simple
   # regex grep since the trigger_body above is a LONG and hence not searchable
+  # via -like
   my @triggers = ( map
     { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
     ( grep
@@ -182,10 +183,15 @@ sub _dbh_get_autoinc_seq {
     )
   );
 
-  # extract all sequence names mentioned in each trigger
-  for (@triggers) {
-    $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
-  }
+  # extract all sequence names mentioned in each trigger, throw away
+  # triggers without apparent sequences
+  @triggers = map {
+    my @seqs = $_->{body} =~ / ( [\.\w\"\-]+ ) \. nextval /xig;
+    @seqs
+      ? { %$_, sequences => \@seqs }
+      : ()
+    ;
+  } @triggers;
 
   my $chosen_trigger;
 
@@ -252,8 +258,12 @@ sub _sequence_fetch {
   my ( $self, $type, $seq ) = @_;
 
   # use the maker to leverage quoting settings
-  my $sql_maker = $self->sql_maker;
-  my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
+  my $sth = $self->_dbh->prepare_cached(
+    $self->sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] )
+  );
+  $sth->execute;
+  my ($id) = $sth->fetchrow_array;
+  $sth->finish;
   return $id;
 }
 
@@ -274,55 +284,47 @@ sub _ping {
 }
 
 sub _dbh_execute {
-  my ($self, $dbh, $sql, @args) = @_;
+  my ($self, $dbh, $sql, $bind) = @_;
 
-  my (@res, $tried);
-  my $want = wantarray;
-  my $next = $self->next::can;
-  do {
-    try {
-      my $exec = sub {
-        # Turn off sth caching for multi-part LOBs. See _prep_for_execute above.
-        local $self->{disable_sth_caching} = 1
-          if first {
-            ($_->[0]{_ora_lob_autosplit_part}||0)
-              > (__cache_queries_with_max_lob_parts-1)
-          } @{ $args[0] };
-
-        $self->$next($dbh, $sql, @args)
-      };
+  # Turn off sth caching for multi-part LOBs. See _prep_for_execute above.
+  local $self->{disable_sth_caching} = 1 if first {
+    ($_->[0]{_ora_lob_autosplit_part}||0)
+      >
+    (__cache_queries_with_max_lob_parts - 1)
+  } @$bind;
 
-      if (!defined $want) {
-        $exec->();
-      }
-      elsif (! $want) {
-        $res[0] = $exec->();
-      }
-      else {
-        @res = $exec->();
-      }
+  my $next = $self->next::can;
 
-      $tried++;
-    }
-    catch {
-      if (! $tried and $_ =~ /ORA-01003/) {
-        # ORA-01003: no statement parsed (someone changed the table somehow,
-        # invalidating your cursor.)
-        delete $dbh->{CachedKids}{$sql};
-      }
-      else {
-        $self->throw_exception($_);
+  # if we are already in a txn we can't retry anything
+  return shift->$next(@_)
+    if $self->transaction_depth;
+
+  # cheat the blockrunner - we do want to rerun things regardless of outer state
+  local $self->{_in_do_block};
+
+  return DBIx::Class::Storage::BlockRunner->new(
+    storage => $self,
+    run_code => $next,
+    run_args => \@_,
+    wrap_txn => 0,
+    retry_handler => sub {
+      # ORA-01003: no statement parsed (someone changed the table somehow,
+      # invalidating your cursor.)
+      return 0 if ($_[0]->retried_count or $_[0]->last_exception !~ /ORA-01003/);
+
+      # re-prepare towards new table data
+      if (my $dbh = $_[0]->storage->_dbh) {
+        delete $dbh->{CachedKids}{$_[0]->run_args->[2]};
       }
-    };
-  } while (! $tried++);
-
-  return wantarray ? @res : $res[0];
+      return 1;
+    },
+  )->run;
 }
 
-sub _dbh_execute_array {
+sub _dbh_execute_for_fetch {
   #my ($self, $sth, $tuple_status, @extra) = @_;
 
-  # DBD::Oracle warns loudly on partial execute_array failures
+  # DBD::Oracle warns loudly on partial execute_for_fetch failures
   local $_[1]->{PrintWarn} = 0;
 
   shift->next::method(@_);
@@ -423,28 +425,35 @@ sub _dbi_attrs_for_bind {
   $attrs;
 }
 
-my $dbd_loaded;
 sub bind_attribute_by_data_type {
   my ($self, $dt) = @_;
 
-  $dbd_loaded ||= do {
-    require DBD::Oracle;
-    if ($DBD::Oracle::VERSION eq '1.23') {
-      $self->throw_exception(
-        "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
-        "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
-      );
+  if ($self->_is_lob_type($dt)) {
+
+    # this is a hot-ish codepath, store an escape-flag in the DBD namespace, so that
+    # things like Class::Unload work (unlikely but possible)
+    unless ($DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__) {
+
+      # no earlier - no later
+      if ($DBD::Oracle::VERSION eq '1.23') {
+        $self->throw_exception(
+          "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
+          "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)"
+        );
+      }
+
+      $DBD::Oracle::__DBIC_DBD_VERSION_CHECK_OK__ = 1;
     }
-    1;
-  };
 
-  if ($self->_is_lob_type($dt)) {
     return {
       ora_type => $self->_is_text_lob_type($dt)
         ? DBD::Oracle::ORA_CLOB()
         : DBD::Oracle::ORA_BLOB()
     };
   }
+  else {
+    return undef;
+  }
 }
 
 # Handle blob columns in WHERE.
@@ -485,94 +494,106 @@ sub _prep_for_execute {
   my $self = shift;
   my ($op) = @_;
 
-  my ($sql, $bind) = $self->next::method(@_);
+  return $self->next::method(@_)
+    if $op eq 'insert';
 
-  return ($sql, $bind) if $op eq 'insert';
+  my ($sql, $bind) = $self->next::method(@_);
 
-  my $blob_bind_index;
-  for (0 .. $#$bind) {
-    $blob_bind_index->{$_} = 1 if $self->_is_lob_type(
+  my $lob_bind_indices = { map {
+    (
       $bind->[$_][0]{sqlt_datatype}
-    );
-  }
+        and
+      $self->_is_lob_type($bind->[$_][0]{sqlt_datatype})
+    ) ? ( $_ => 1 ) : ()
+  } ( 0 .. $#$bind ) };
 
-  return ($sql, $bind) unless $blob_bind_index;
+  return ($sql, $bind) unless %$lob_bind_indices;
 
-  my (@sql_parts, $new_sql, @new_binds);
-
-  if ($op eq 'select' || $op eq 'delete') {
-    @sql_parts = split /\?/, $sql;
-  }
-  elsif ($op eq 'update') {
+  my ($final_sql, @final_binds);
+  if ($op eq 'update') {
     $self->throw_exception('Update with complex WHERE clauses currently not supported')
       if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs;
 
-    my ($set_part, $where_part) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
+    my $where_sql;
+    ($final_sql, $where_sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
+
+    if (my $set_bind_count = $final_sql =~ y/?//) {
 
-    my $set_bind_count = $set_part =~ y/?//;
-    @new_binds = splice @$bind, 0, $set_bind_count;
+      delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1));
 
-    @sql_parts = split /\?/, $where_part;
-    $new_sql  = $set_part;
+      # bail if only the update part contains blobs
+      return ($sql, $bind) unless %$lob_bind_indices;
+
+      @final_binds = splice @$bind, 0, $set_bind_count;
+      $lob_bind_indices = { map
+        { $_ - $set_bind_count => $lob_bind_indices->{$_} }
+        keys %$lob_bind_indices
+      };
+    }
+
+    # if we got that far - assume the where SQL is all we got
+    # (the first part is already shoved into $final_sql)
+    $sql = $where_sql;
   }
-  else {
+  elsif ($op ne 'select' and $op ne 'delete') {
     $self->throw_exception("Unsupported \$op: $op");
   }
 
+  my @sql_parts = split /\?/, $sql;
+
   my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x;
 
   for my $b_idx (0 .. $#$bind) {
     my $bound = $bind->[$b_idx];
 
-    if ($blob_bind_index->{$b_idx}) {
-      if (my ($col, $eq) = $sql_parts[0] =~ $col_equality_re) {
-        my $data = $bound->[1];
+    if (
+      $lob_bind_indices->{$b_idx}
+        and
+      my ($col, $eq) = $sql_parts[0] =~ $col_equality_re
+    ) {
+      my $data = $bound->[1];
 
-        $data = "$data" if ref $data;
+      $data = "$data" if ref $data;
 
-        my @parts = unpack '(a2000)*', $data;
+      my @parts = unpack '(a2000)*', $data;
 
-        my @sql_frag;
+      my @sql_frag;
 
-        for my $idx (0..$#parts) {
-          push @sql_frag, sprintf (
-            'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
-            $col, ($idx*2000 + 1),
-          );
-        }
-
-        my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
+      for my $idx (0..$#parts) {
+        push @sql_frag, sprintf (
+          'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
+          $col, ($idx*2000 + 1),
+        );
+      }
 
-        $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
+      my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
 
-        $new_sql .= shift @sql_parts;
+      $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
 
-        for my $idx (0..$#parts) {
-          push @new_binds, [
-            {
-              %{ $bound->[0] },
-              _ora_lob_autosplit_part => $idx,
-              dbd_attrs => undef,
-            },
-            $parts[$idx]
-          ];
-        }
-      }
-      else {
-        $new_sql .= shift(@sql_parts) . '?';
+      $final_sql .= shift @sql_parts;
 
-        push @new_binds, [
+      for my $idx (0..$#parts) {
+        push @final_binds, [
           {
             %{ $bound->[0] },
+            _ora_lob_autosplit_part => $idx,
             dbd_attrs => undef,
           },
-          $bound->[1],
+          $parts[$idx]
         ];
       }
     }
     else {
-      $new_sql .= shift(@sql_parts) . '?';
-      push @new_binds, $bound;
+      $final_sql .= shift(@sql_parts) . '?';
+      push @final_binds, $lob_bind_indices->{$b_idx}
+        ? [
+          {
+            %{ $bound->[0] },
+            dbd_attrs => undef,
+          },
+          $bound->[1],
+        ] : $bound
+      ;
     }
   }
 
@@ -581,9 +602,9 @@ sub _prep_for_execute {
     @sql_parts = join ('?', @sql_parts);
   }
 
-  $new_sql .= $sql_parts[0];
+  $final_sql .= $sql_parts[0];
 
-  return ($new_sql, \@new_binds);
+  return ($final_sql, \@final_binds);
 }
 
 # Savepoints stuff.
@@ -680,7 +701,7 @@ and child rows of the hierarchy.
   #     person me
   # CONNECT BY
   #     parentid = prior persionid
-  
+
 
   connect_by_nocycle => { parentid => 'prior personid' }