X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FOracle%2FGeneric.pm;h=256bbc9678470827170ba56fc5964342809d4e17;hb=8273e845426f0187b4ad6c4a1b42286fa09a648f;hp=b9bf0953f67bab8746364d76b1862e29cd29a4ce;hpb=90d7422fc60a3bad71cc67dc20106ef68046664e;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 b9bf095..256bbc9 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -2,6 +2,9 @@ package DBIx::Class::Storage::DBI::Oracle::Generic;
 
 use strict;
 use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use DBIx::Class::Carp;
 use Scope::Guard ();
 use Context::Preserve 'preserve_context';
 use Try::Tiny;
@@ -10,6 +13,10 @@ use namespace::clean;
 
 __PACKAGE__->sql_limit_dialect ('RowNum');
 __PACKAGE__->sql_quote_char ('"');
+__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
+__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
+
+sub __cache_queries_with_max_lob_parts { 2 }
 
 =head1 NAME
 
@@ -77,14 +84,6 @@ versions before 9.0.
 
 =cut
 
-use base qw/DBIx::Class::Storage::DBI/;
-use mro 'c3';
-
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
-__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
-
-sub __cache_queries_with_max_lob_parts { 2 }
-
 sub _determine_supports_insert_returning {
   my $self = shift;
 
@@ -159,13 +158,13 @@ sub _dbh_get_autoinc_seq {
   my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
 
   # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
-  $schema ||= uc( ($self->_dbi_connect_info||[])->[1] || '');
+  $schema ||= \'= USER';
 
   my ($sql, @bind) = $sql_maker->select (
     '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
@@ -175,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
@@ -183,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;
 
@@ -253,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;
 }
 
@@ -424,28 +433,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.
@@ -486,68 +502,117 @@ sub _prep_for_execute {
   my $self = shift;
   my ($op) = @_;
 
+  return $self->next::method(@_)
+    if $op eq 'insert';
+
   my ($sql, $bind) = $self->next::method(@_);
 
-  return ($sql, $bind) if $op ne 'select';
+  my $lob_bind_indices = { map {
+    (
+      $bind->[$_][0]{sqlt_datatype}
+        and
+      $self->_is_lob_type($bind->[$_][0]{sqlt_datatype})
+    ) ? ( $_ => 1 ) : ()
+  } ( 0 .. $#$bind ) };
 
-  my @sql_part = split /\?/, $sql;
-  my ($new_sql, @new_binds);
+  return ($sql, $bind) unless %$lob_bind_indices;
 
-  foreach my $bound (@$bind) {
-    my $data_type = $bound->[0]{sqlt_datatype}||'';
+  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;
 
-    if ($self->_is_lob_type($data_type)) {
-      if (my ($col, $eq) = $sql_part[0] =~ /(?<=\s)([\w."]+)(\s*=\s*)$/) {
-        my $data = $bound->[1];
+    my $where_sql;
+    ($final_sql, $where_sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
 
-        $data = "$data" if ref $data;
+    if (my $set_bind_count = $final_sql =~ y/?//) {
 
-        my @parts = unpack '(a2000)*', $data;
+      delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1));
 
-        my @sql_frag;
+      # bail if only the update part contains blobs
+      return ($sql, $bind) unless %$lob_bind_indices;
 
-        for my $idx (0..$#parts) {
-          push @sql_frag,
-"UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR($col, 2000, ".($idx*2000+1)."))) = ?";
-        }
+      @final_binds = splice @$bind, 0, $set_bind_count;
+      $lob_bind_indices = { map
+        { $_ - $set_bind_count => $lob_bind_indices->{$_} }
+        keys %$lob_bind_indices
+      };
+    }
 
-        my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
+    # 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;
+  }
+  elsif ($op ne 'select' and $op ne 'delete') {
+    $self->throw_exception("Unsupported \$op: $op");
+  }
 
-        $sql_part[0] =~ s/(?<=\s)([\w."]+)(\s*=\s*)$/$sql_frag/;
+  my @sql_parts = split /\?/, $sql;
 
-        $new_sql .= shift @sql_part;
+  my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x;
 
-        for my $idx (0..$#parts) {
-          push @new_binds, [
-            {
-              %{ $bound->[0] },
-              _ora_lob_autosplit_part => $idx,
-              dbd_attrs => undef,
-            },
-            $parts[$idx]
-          ];
-        }
+  for my $b_idx (0 .. $#$bind) {
+    my $bound = $bind->[$b_idx];
+
+    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;
+
+      my @parts = unpack '(a2000)*', $data;
+
+      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),
+        );
       }
-      else {
-        $new_sql .= shift(@sql_part) . '?';
 
-        push @new_binds, [
+      my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
+
+      $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
+
+      $final_sql .= shift @sql_parts;
+
+      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_part) . '?';
-      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
+      ;
     }
   }
-  $new_sql .= join '', @sql_part;
 
-  return ($new_sql, \@new_binds);
+  if (@sql_parts > 1) {
+    carp "There are more placeholders than binds, this should not happen!";
+    @sql_parts = join ('?', @sql_parts);
+  }
+
+  $final_sql .= $sql_parts[0];
+
+  return ($final_sql, \@final_binds);
 }
 
 # Savepoints stuff.
@@ -644,7 +709,7 @@ and child rows of the hierarchy.
   #     person me
   # CONNECT BY
   #     parentid = prior persionid
-  
+
 
   connect_by_nocycle => { parentid => 'prior personid' }