Introduce GOVERNANCE document and empty RESOLUTIONS file.
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Oracle / Generic.pm
index 87e5b05..336070a 100644 (file)
@@ -2,11 +2,21 @@ 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 ();
-use Try::Tiny;
+use Context::Preserve 'preserve_context';
+use DBIx::Class::_Util qw( modver_gt_or_eq modver_gt_or_eq_and_lt dbic_internal_try );
 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
 
 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
@@ -17,7 +27,6 @@ DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
   use base 'DBIx::Class::Core';
   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
   __PACKAGE__->set_primary_key('id');
-  __PACKAGE__->sequence('mysequence');
 
   # Somewhere in your Code
   # add some data to a table with a hierarchical relationship
@@ -46,7 +55,7 @@ DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
   my $rs = $schema->resultset('Person')->search({},
     {
       'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
-      'connect_by' => { 'parentid' => { '-prior' => \'persionid' },
+      'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
       'order_siblings_by' => { -asc => 'name' },
     };
   );
@@ -60,7 +69,7 @@ DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
   # START WITH
   #     firstname = 'foo' and lastname = 'bar'
   # CONNECT BY
-  #     parentid = prior persionid
+  #     parentid = prior personid
   # ORDER SIBLINGS BY
   #     firstname ASC
 
@@ -68,29 +77,39 @@ DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
 
 This class implements base Oracle support. The subclass
 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
-versions before 9.
+versions before 9.0.
 
 =head1 METHODS
 
 =cut
 
-use base qw/DBIx::Class::Storage::DBI/;
-use mro 'c3';
+sub _determine_supports_insert_returning {
+  my $self = shift;
+
+# TODO find out which version supports the RETURNING syntax
+# 8i has it and earlier docs are a 404 on oracle.com
+
+  return 1
+    if $self->_server_info->{normalized_dbms_version} >= 8.001;
+
+  return 0;
+}
 
-__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
+__PACKAGE__->_use_insert_returning_bound (1);
 
 sub deployment_statements {
   my $self = shift;;
   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
 
   $sqltargs ||= {};
-  my $quote_char = $self->schema->storage->sql_maker->quote_char;
-  $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
-  $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
 
-  my $oracle_version = try { $self->_get_dbh->get_info(18) };
-
-  $sqltargs->{producer_args}{oracle_version} = $oracle_version;
+  if (
+    ! exists $sqltargs->{producer_args}{oracle_version}
+      and
+    my $dver = $self->_server_info->{dbms_version}
+  ) {
+    $sqltargs->{producer_args}{oracle_version} = $dver;
+  }
 
   $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
 }
@@ -98,9 +117,10 @@ sub deployment_statements {
 sub _dbh_last_insert_id {
   my ($self, $dbh, $source, @columns) = @_;
   my @ids = ();
+  my $ci = $source->columns_info(\@columns);
   foreach my $col (@columns) {
-    my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
-    my $id = $self->_sequence_fetch( 'currval', $seq );
+    my $seq = ( $ci->{$col}{sequence} ||= $self->get_autoinc_seq($source,$col));
+    my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
     push @ids, $id;
   }
   return @ids;
@@ -110,15 +130,20 @@ sub _dbh_get_autoinc_seq {
   my ($self, $dbh, $source, $col) = @_;
 
   my $sql_maker = $self->sql_maker;
+  my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
 
   my $source_name;
   if ( ref $source->name eq 'SCALAR' ) {
     $source_name = ${$source->name};
+
+    # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
+    # stuff unless it is already quoted
+    $source_name = uc ($source_name) if $source_name !~ /\"/;
   }
   else {
     $source_name = $source->name;
+    $source_name = uc($source_name) unless $ql;
   }
-  $source_name = uc($source_name) unless $sql_maker->quote_char;
 
   # trigger_body is a LONG
   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
@@ -127,29 +152,115 @@ sub _dbh_get_autoinc_seq {
   local $sql_maker->{bindtype} = 'normal';
 
   # look up the correct sequence automatically
-  my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
+  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 ||= \'= USER';
+
   my ($sql, @bind) = $sql_maker->select (
     'ALL_TRIGGERS',
-    ['trigger_body'],
+    [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
     {
-      $schema ? (owner => $schema) : (),
-      table_name => $table || $source_name,
-      triggering_event => { -like => '%INSERT%' },
-      status => 'ENABLED',
+      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
+      STATUS => 'ENABLED',
      },
   );
-  my $sth = $dbh->prepare($sql);
-  $sth->execute (@bind);
 
-  while (my ($insert_trigger) = $sth->fetchrow_array) {
-    return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
+  # 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
+      { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
+      @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
+    )
+  );
+
+  # 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;
+
+  # if only one trigger matched things are easy
+  if (@triggers == 1) {
+
+    if ( @{$triggers[0]{sequences}} == 1 ) {
+      $chosen_trigger = $triggers[0];
+    }
+    else {
+      $self->throw_exception( sprintf (
+        "Unable to introspect trigger '%s' for column '%s.%s' (references multiple sequences). "
+      . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
+        $triggers[0]{name},
+        $source_name,
+        $col,
+        $col,
+      ) );
+    }
   }
-  $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
+  # got more than one matching trigger - see if we can narrow it down
+  elsif (@triggers > 1) {
+
+    my @candidates = grep
+      { $_->{body} =~ / into \s+ \:new\.$col /xi }
+      @triggers
+    ;
+
+    if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
+      $chosen_trigger = $candidates[0];
+    }
+    else {
+      $self->throw_exception( sprintf (
+        "Unable to reliably select a BEFORE INSERT trigger for column '%s.%s' (possibilities: %s). "
+      . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
+        $source_name,
+        $col,
+        ( join ', ', map { "'$_->{name}'" } @triggers ),
+        $col,
+      ) );
+    }
+  }
+
+  if ($chosen_trigger) {
+    my $seq_name = $chosen_trigger->{sequences}[0];
+
+    $seq_name = "$chosen_trigger->{schema}.$seq_name"
+      unless $seq_name =~ /\./;
+
+    return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
+    return $seq_name;
+  }
+
+  $self->throw_exception( sprintf (
+    "No suitable BEFORE INSERT triggers found for column '%s.%s'. "
+  . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
+    $source_name,
+    $col,
+    $col,
+  ));
 }
 
 sub _sequence_fetch {
   my ( $self, $type, $seq ) = @_;
-  my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
+
+  # use the maker to leverage quoting settings
+  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;
 }
 
@@ -161,51 +272,69 @@ sub _ping {
   local $dbh->{RaiseError} = 1;
   local $dbh->{PrintError} = 0;
 
-  return try {
+  ( dbic_internal_try {
     $dbh->do('select 1 from dual');
     1;
-  } catch {
-    0;
-  };
+  })
+    ? 1
+    : 0
+  ;
 }
 
 sub _dbh_execute {
-  my $self = shift;
-  my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+  #my ($self, $dbh, $sql, $bind, $bind_attrs) = @_;
+  my ($self, $sql, $bind) = @_[0,2,3];
 
-  my (@res, $tried);
-  my $wantarray = wantarray();
-  my $next = $self->next::can;
-  do {
-    try {
-      my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
+  # Turn off sth caching for multi-part LOBs. See _prep_for_execute below
+  local $self->{disable_sth_caching} = 1 if grep {
+    ($_->[0]{_ora_lob_autosplit_part}||0)
+      >
+    (__cache_queries_with_max_lob_parts - 1)
+  } @$bind;
 
-      if (!defined $wantarray) {
-        $exec->();
-      }
-      elsif (! $wantarray) {
-        $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.)
-        my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
+  # if we are already in a txn we can't retry anything
+  return shift->$next(@_)
+    if $self->transaction_depth;
+
+  # Cheat the blockrunner we are just about to create:
+  # We *do* want to rerun things regardless of outer state
+  local $self->{_in_do_block}
+    if $self->{_in_do_block};
+
+  DBIx::Class::Storage::BlockRunner->new(
+    storage => $self,
+    wrap_txn => 0,
+    retry_handler => sub {
+      # ORA-01003: no statement parsed (someone changed the table somehow,
+      # invalidating your cursor.)
+      if (
+        $_[0]->failed_attempt_count == 1
+          and
+        $_[0]->last_exception =~ /ORA-01003/
+          and
+        my $dbh = $_[0]->storage->_dbh
+      ) {
         delete $dbh->{CachedKids}{$sql};
+        return 1;
       }
       else {
-        $self->throw_exception($_);
+        return 0;
       }
-    };
-  } while (! $tried++);
+    },
+  )->run( $next, @_ );
+}
+
+sub _dbh_execute_for_fetch {
+  #my ($self, $source, $sth, $proto_bind, $cols, $data) = @_;
 
-  return $wantarray ? @res : $res[0];
+  # Older DBD::Oracle warns loudly on partial execute_for_fetch failures
+  # before https://metacpan.org/source/PYTHIAN/DBD-Oracle-1.28/Changes#L7-9
+  local $_[2]->{PrintWarn} = 0
+    unless modver_gt_or_eq( 'DBD::Oracle', '1.28' );
+
+  shift->next::method(@_);
 }
 
 =head2 get_autoinc_seq
@@ -225,10 +354,6 @@ sub get_autoinc_seq {
 This sets the proper DateTime::Format module for use with
 L<DBIx::Class::InflateColumn::DateTime>.
 
-=cut
-
-sub datetime_parser_type { return "DateTime::Format::Oracle"; }
-
 =head2 connect_call_datetime_setup
 
 Used as:
@@ -277,70 +402,230 @@ sub connect_call_datetime_setup {
   );
 }
 
-=head2 source_bind_attributes
+### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
+### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
+#
+# 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.
+#
+sub _dbi_attrs_for_bind {
+  my ($self, $ident, $bind) = @_;
+
+  my $attrs = $self->next::method($ident, $bind);
+
+  # Push the column name into all bind attrs, make sure to *NOT* write into
+  # the existing $attrs->[$idx]{..} hashref, as it is cached by the call to
+  # next::method above.
+  # FIXME - this code will go away when the LobWriter refactor lands
+  $attrs->[$_]
+    and
+  keys %{ $attrs->[$_] }
+    and
+  $bind->[$_][0]{dbic_colname}
+    and
+  $attrs->[$_] = { %{$attrs->[$_]}, ora_field => $bind->[$_][0]{dbic_colname} }
+    for 0 .. $#$attrs;
+
+  $attrs;
+}
 
-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.
+sub bind_attribute_by_data_type {
+  my ($self, $dt) = @_;
 
-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.
+  if ($self->_is_lob_type($dt)) {
 
-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.
+    # no earlier - no later
+    $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)"
+    ) if modver_gt_or_eq_and_lt( 'DBD::Oracle', '1.23', '1.24' );
 
-=cut
+    return {
+      ora_type => $self->_is_text_lob_type($dt)
+        ? DBD::Oracle::ORA_CLOB()
+        : DBD::Oracle::ORA_BLOB()
+    };
+  }
+  else {
+    return undef;
+  }
+}
 
-sub source_bind_attributes
-{
-  require DBD::Oracle;
+# Handle blob columns in WHERE.
+#
+# For equality comparisons:
+#
+# We split data intended for comparing to a LOB into 2000 character chunks and
+# compare them using dbms_lob.substr on the LOB column.
+#
+# We turn off DBD::Oracle LOB binds for these partial LOB comparisons by passing
+# dbd_attrs => undef, because these are regular varchar2 comparisons and
+# otherwise the query will fail.
+#
+# Since the most common comparison size is likely to be under 4000 characters
+# (TEXT comparisons previously deployed to other RDBMSes) we disable
+# prepare_cached for queries with more than two part comparisons to a LOB
+# column. This is done in _dbh_execute (above) which was previously overridden
+# to gracefully recover from an Oracle error. This is to be careful to not
+# exhaust your application's open cursor limit.
+#
+# See:
+# http://itcareershift.com/blog1/2011/02/21/oracle-max-number-of-open-cursors-complete-reference-for-the-new-oracle-dba/
+# on the open_cursor limit.
+#
+# For everything else:
+#
+# We assume that everything that is not a LOB comparison, will most likely be a
+# LIKE query or some sort of function invocation. This may prove to be a naive
+# assumption in the future, but for now it should cover the two most likely
+# things users would want to do with a BLOB or CLOB, an equality test or a LIKE
+# query (on a CLOB.)
+#
+# For these expressions, the bind must NOT have the attributes of a LOB bind for
+# DBD::Oracle, otherwise the query will fail. This is done by passing
+# dbd_attrs => undef.
+
+sub _prep_for_execute {
   my $self = shift;
-  my($source) = @_;
+  my ($op) = @_;
+
+  return $self->next::method(@_)
+    if $op eq 'insert';
+
+  my ($sql, $bind) = $self->next::method(@_);
+
+  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 %$lob_bind_indices;
+
+  my ($final_sql, @final_binds);
+  if ($op eq 'update') {
+    $self->throw_exception('Update with complex WHERE clauses involving BLOB columns currently not supported')
+      if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs;
 
-  my %bind_attributes;
+    my $where_sql;
+    ($final_sql, $where_sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
 
-  foreach my $column ($source->columns) {
-    my $data_type = $source->column_info($column)->{data_type} || '';
-    next unless $data_type;
+    if (my $set_bind_count = $final_sql =~ y/?//) {
 
-    my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
+      delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1));
+
+      # 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;
+  }
+  elsif ($op ne 'select' and $op ne 'delete') {
+    $self->throw_exception("Unsupported \$op: $op");
+  }
 
-    if ($data_type =~ /^[BC]LOB$/i) {
-      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"
+  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 (
+      $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),
         );
       }
 
-      $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
-        ? DBD::Oracle::ORA_CLOB()
-        : DBD::Oracle::ORA_BLOB()
+      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,
+          },
+          $parts[$idx]
+        ];
+      }
+    }
+    else {
+      $final_sql .= shift(@sql_parts) . '?';
+      push @final_binds, $lob_bind_indices->{$b_idx}
+        ? [
+          {
+            %{ $bound->[0] },
+            dbd_attrs => undef,
+          },
+          $bound->[1],
+        ] : $bound
       ;
-      $column_bind_attrs{'ora_field'} = $column;
     }
+  }
 
-    $bind_attributes{$column} = \%column_bind_attrs;
+  if (@sql_parts > 1) {
+    carp "There are more placeholders than binds, this should not happen!";
+    @sql_parts = join ('?', @sql_parts);
   }
 
-  return \%bind_attributes;
+  $final_sql .= $sql_parts[0];
+
+  return ($final_sql, \@final_binds);
 }
 
-sub _svp_begin {
+# Savepoints stuff.
+
+sub _exec_svp_begin {
   my ($self, $name) = @_;
-  $self->_get_dbh->do("SAVEPOINT $name");
+  $self->_dbh->do("SAVEPOINT $name");
 }
 
 # Oracle automatically releases a savepoint when you start another one with the
 # same name.
-sub _svp_release { 1 }
+sub _exec_svp_release { 1 }
 
-sub _svp_rollback {
+sub _exec_svp_rollback {
   my ($self, $name) = @_;
-  $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
+  $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
 }
 
 =head2 relname_to_table_alias
@@ -352,7 +637,7 @@ Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 MD5 hash.
 
-See L<DBIx::Class::Storage/"relname_to_table_alias">.
+See L<DBIx::Class::Storage::DBI/relname_to_table_alias>.
 
 =cut
 
@@ -362,25 +647,9 @@ sub relname_to_table_alias {
 
   my $alias = $self->next::method(@_);
 
-  return $alias if length($alias) <= 30;
-
-  # get a base64 md5 of the alias with join_count
-  require Digest::MD5;
-  my $ctx = Digest::MD5->new;
-  $ctx->add($alias);
-  my $md5 = $ctx->b64digest;
-
-  # remove alignment mark just in case
-  $md5 =~ s/=*\z//;
-
-  # truncate and prepend to truncated relname without vowels
-  (my $devoweled = $relname) =~ s/[aeiou]//g;
-  my $shortened = substr($devoweled, 0, 18);
-
-  my $new_alias =
-    $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
-
-  return $new_alias;
+  # we need to shorten here in addition to the shortening in SQLA itself,
+  # since the final relnames are crucial for the join optimizer
+  return $self->sql_maker->_shorten_identifier($alias);
 }
 
 =head2 with_deferred_fk_checks
@@ -408,8 +677,8 @@ sub with_deferred_fk_checks {
     $self->_do_query('alter session set constraints = immediate');
   });
 
-  return Context::Preserve::preserve_context(sub { $sub->() },
-    after => sub { $txn_scope_guard->commit });
+  return
+    preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
 }
 
 =head1 ATTRIBUTES
@@ -437,7 +706,7 @@ and child rows of the hierarchy.
   #     person me
   # CONNECT BY
   #     parentid = prior persionid
-  
+
 
   connect_by_nocycle => { parentid => 'prior personid' }
 
@@ -496,14 +765,18 @@ It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
   # ORDER SIBLINGS BY
   #     firstname ASC
 
-=head1 AUTHOR
+=head1 FURTHER QUESTIONS?
 
-See L<DBIx::Class/CONTRIBUTORS>.
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 
-=head1 LICENSE
+=head1 COPYRIGHT AND LICENSE
 
-You may distribute this code under the same terms as Perl itself.
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
 
 =cut
 
 1;
+# vim:sts=2 sw=2: