[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Oracle / Generic.pm

package DBIx::Class::Storage::DBI::Oracle::Generic;

use strict;
use warnings;
use Scope::Guard ();
use Context::Preserve 'preserve_context';
use Try::Tiny;
use namespace::clean;

__PACKAGE__->sql_limit_dialect ('RowNum');

=head1 NAME

DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class

=head1 SYNOPSIS

  # In your result (table) classes
  use base 'DBIx::Class::Core';
  __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  __PACKAGE__->set_primary_key('id');

  # Somewhere in your Code
  # add some data to a table with a hierarchical relationship
  $schema->resultset('Person')->create ({
        firstname => 'foo',
        lastname => 'bar',
        children => [
            {
                firstname => 'child1',
                lastname => 'bar',
                children => [
                    {
                        firstname => 'grandchild',
                        lastname => 'bar',
                    }
                ],
            },
            {
                firstname => 'child2',
                lastname => 'bar',
            },
        ],
    });

  # select from the hierarchical relationship
  my $rs = $schema->resultset('Person')->search({},
    {
      'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
      'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
      'order_siblings_by' => { -asc => 'name' },
    };
  );

  # this will select the whole tree starting from person "foo bar", creating
  # following query:
  # SELECT
  #     me.persionid me.firstname, me.lastname, me.parentid
  # FROM
  #     person me
  # START WITH
  #     firstname = 'foo' and lastname = 'bar'
  # CONNECT BY
  #     parentid = prior personid
  # ORDER SIBLINGS BY
  #     firstname ASC

=head1 DESCRIPTION

This class implements base Oracle support. The subclass
L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
versions before 9.

=head1 METHODS

=cut

use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';

__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');

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;

  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);
}

sub _dbh_last_insert_id {
  my ($self, $dbh, $source, @columns) = @_;
  my @ids = ();
  foreach my $col (@columns) {
    my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
    my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
    push @ids, $id;
  }
  return @ids;
}

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;
  }

  # trigger_body is a LONG
  local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);

  # disable default bindtype
  local $sql_maker->{bindtype} = 'normal';


  # look up the correct sequence automatically
  my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
  my ($sql, @bind) = $sql_maker->select (
    'ALL_TRIGGERS',
    [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
    {
      $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
      STATUS => 'ENABLED',
     },
  );

  # 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
  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
  for (@triggers) {
    $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
  }

  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,
      ) );
    }
  }
  # 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 ) = @_;

  # 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" ] ) );
  return $id;
}

sub _ping {
  my $self = shift;

  my $dbh = $self->_dbh or return 0;

  local $dbh->{RaiseError} = 1;
  local $dbh->{PrintError} = 0;

  return try {
    $dbh->do('select 1 from dual');
    1;
  } catch {
    0;
  };
}

sub _dbh_execute {
  my $self = shift;
  my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;

  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) };

      if (!defined $wantarray) {
        $exec->();
      }
      elsif (! $wantarray) {
        $res[0] = $exec->();
      }
      else {
        @res = $exec->();
      }

      $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);
        delete $dbh->{CachedKids}{$sql};
      }
      else {
        $self->throw_exception($_);
      }
    };
  } while (! $tried++);

  return $wantarray ? @res : $res[0];
}

=head2 get_autoinc_seq

Returns the sequence name for an autoincrement column

=cut

sub get_autoinc_seq {
  my ($self, $source, $col) = @_;

  $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
}

=head2 datetime_parser_type

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:

    on_connect_call => 'datetime_setup'

In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
and the necessary environment variables for L<DateTime::Format::Oracle>, which
is used by it.

Maximum allowable precision is used, unless the environment variables have
already been set.

These are the defaults used:

  $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
  $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
  $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';

To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
for your timestamps, use something like this:

  use Time::HiRes 'time';
  my $ts = DateTime->from_epoch(epoch => time);

=cut

sub connect_call_datetime_setup {
  my $self = shift;

  my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
  my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
    'YYYY-MM-DD HH24:MI:SS.FF';
  my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
    'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';

  $self->_do_query(
    "alter session set nls_date_format = '$date_format'"
  );
  $self->_do_query(
    "alter session set nls_timestamp_format = '$timestamp_format'"
  );
  $self->_do_query(
    "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
  );
}

=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
{
  require DBD::Oracle;
  my $self = shift;
  my($source) = @_;

  my %bind_attributes;

  foreach my $column ($source->columns) {
    my $data_type = $source->column_info($column)->{data_type}
      or next;

    my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);

    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"
        );
      }

      $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
        ? DBD::Oracle::ORA_CLOB()
        : DBD::Oracle::ORA_BLOB()
      ;
      $column_bind_attrs{'ora_field'} = $column;
    }

    $bind_attributes{$column} = \%column_bind_attrs;
  }

  return \%bind_attributes;
}

sub _svp_begin {
  my ($self, $name) = @_;
  $self->_get_dbh->do("SAVEPOINT $name");
}

# Oracle automatically releases a savepoint when you start another one with the
# same name.
sub _svp_release { 1 }

sub _svp_rollback {
  my ($self, $name) = @_;
  $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
}

=head2 relname_to_table_alias

L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
queries.

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">.

=cut

sub relname_to_table_alias {
  my $self = shift;
  my ($relname, $join_count) = @_;

  my $alias = $self->next::method(@_);

  return $self->sql_maker->_shorten_identifier($alias, [$relname]);
}

=head2 with_deferred_fk_checks

Runs a coderef between:

  alter session set constraints = deferred
  ...
  alter session set constraints = immediate

to defer foreign key checks.

Constraints must be declared C<DEFERRABLE> for this to work.

=cut

sub with_deferred_fk_checks {
  my ($self, $sub) = @_;

  my $txn_scope_guard = $self->txn_scope_guard;

  $self->_do_query('alter session set constraints = deferred');

  my $sg = Scope::Guard->new(sub {
    $self->_do_query('alter session set constraints = immediate');
  });

  return
    preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
}

=head1 ATTRIBUTES

Following additional attributes can be used in resultsets.

=head2 connect_by or connect_by_nocycle

=over 4

=item Value: \%connect_by

=back

A hashref of conditions used to specify the relationship between parent rows
and child rows of the hierarchy.


  connect_by => { parentid => 'prior personid' }

  # adds a connect by statement to the query:
  # SELECT
  #     me.persionid me.firstname, me.lastname, me.parentid
  # FROM
  #     person me
  # CONNECT BY
  #     parentid = prior persionid
  

  connect_by_nocycle => { parentid => 'prior personid' }

  # adds a connect by statement to the query:
  # SELECT
  #     me.persionid me.firstname, me.lastname, me.parentid
  # FROM
  #     person me
  # CONNECT BY NOCYCLE
  #     parentid = prior persionid


=head2 start_with

=over 4

=item Value: \%condition

=back

A hashref of conditions which specify the root row(s) of the hierarchy.

It uses the same syntax as L<DBIx::Class::ResultSet/search>

  start_with => { firstname => 'Foo', lastname => 'Bar' }

  # SELECT
  #     me.persionid me.firstname, me.lastname, me.parentid
  # FROM
  #     person me
  # START WITH
  #     firstname = 'foo' and lastname = 'bar'
  # CONNECT BY
  #     parentid = prior persionid

=head2 order_siblings_by

=over 4

=item Value: ($order_siblings_by | \@order_siblings_by)

=back

Which column(s) to order the siblings by.

It uses the same syntax as L<DBIx::Class::ResultSet/order_by>

  'order_siblings_by' => 'firstname ASC'

  # SELECT
  #     me.persionid me.firstname, me.lastname, me.parentid
  # FROM
  #     person me
  # CONNECT BY
  #     parentid = prior persionid
  # ORDER SIBLINGS BY
  #     firstname ASC

=head1 AUTHOR

See L<DBIx::Class/CONTRIBUTORS>.

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

=cut

1;
Commit	Line	Data
18360aed	1	package DBIx::Class::Storage::DBI::Oracle::Generic;
	2
	3	use strict;
	4	use warnings;
b7b18f32	5	use Scope::Guard ();
6298a324	6	use Context::Preserve 'preserve_context';
ed7ab0f4	7	use Try::Tiny;
fd323bf1	8	use namespace::clean;
18360aed	9
6a247f33	10	__PACKAGE__->sql_limit_dialect ('RowNum');
6a247f33	11
7137528d	12	=head1 NAME
7137528d	13
7a84c41b	14	DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
7137528d	15
	16	=head1 SYNOPSIS
	17
d88ecca6	18	# In your result (table) classes
d88ecca6	19	use base 'DBIx::Class::Core';
2e46b6eb	20	__PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
7137528d	21	__PACKAGE__->set_primary_key('id');
7137528d	22
c0024355	23	# Somewhere in your Code
	24	# add some data to a table with a hierarchical relationship
	25	$schema->resultset('Person')->create ({
	26	firstname => 'foo',
	27	lastname => 'bar',
	28	children => [
	29	{
	30	firstname => 'child1',
	31	lastname => 'bar',
	32	children => [
	33	{
	34	firstname => 'grandchild',
	35	lastname => 'bar',
	36	}
	37	],
	38	},
	39	{
	40	firstname => 'child2',
	41	lastname => 'bar',
	42	},
	43	],
	44	});
	45
	46	# select from the hierarchical relationship
	47	my $rs = $schema->resultset('Person')->search({},
	48	{
	49	'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
e6600283	50	'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
25ca709b	51	'order_siblings_by' => { -asc => 'name' },
c0024355	52	};
	53	);
	54
	55	# this will select the whole tree starting from person "foo bar", creating
	56	# following query:
	57	# SELECT
	58	# me.persionid me.firstname, me.lastname, me.parentid
	59	# FROM
	60	# person me
	61	# START WITH
	62	# firstname = 'foo' and lastname = 'bar'
	63	# CONNECT BY
e6600283	64	# parentid = prior personid
c0024355	65	# ORDER SIBLINGS BY
	66	# firstname ASC
	67
7137528d	68	=head1 DESCRIPTION
7137528d	69
6c0230de	70	This class implements base Oracle support. The subclass
	71	L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
	72	versions before 9.
7137528d	73
	74	=head1 METHODS
	75
	76	=cut
	77
db56cf3d	78	use base qw/DBIx::Class::Storage::DBI/;
2ad62d97	79	use mro 'c3';
18360aed	80
d5dedbd6	81	__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
c0024355	82
dd2600c6	83	sub deployment_statements {
	84	my $self = shift;;
	85	my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
	86
	87	$sqltargs \|\|= {};
032b2366	88	my $quote_char = $self->schema->storage->sql_maker->quote_char;
	89	$sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
	90	$sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
dd2600c6	91
96736321	92	if (
	93	! exists $sqltargs->{producer_args}{oracle_version}
	94	and
	95	my $dver = $self->_server_info->{dbms_version}
	96	) {
	97	$sqltargs->{producer_args}{oracle_version} = $dver;
	98	}
a4433d8e	99
38aead8e	100	$self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
dd2600c6	101	}
dd2600c6	102
18360aed	103	sub _dbh_last_insert_id {
2e46b6eb	104	my ($self, $dbh, $source, @columns) = @_;
	105	my @ids = ();
	106	foreach my $col (@columns) {
	107	my $seq = ($source->column_info($col)->{sequence} \|\|= $self->get_autoinc_seq($source,$col));
07cda1c5	108	my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
2e46b6eb	109	push @ids, $id;
	110	}
	111	return @ids;
18360aed	112	}
	113
	114	sub _dbh_get_autoinc_seq {
	115	my ($self, $dbh, $source, $col) = @_;
	116
032b2366	117	my $sql_maker = $self->sql_maker;
07cda1c5	118	my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
cb464582	119
e6dd7b42	120	my $source_name;
032b2366	121	if ( ref $source->name eq 'SCALAR' ) {
032b2366	122	$source_name = ${$source->name};
07cda1c5	123
	124	# the ALL_TRIGGERS match further on is case sensitive - thus uppercase
	125	# stuff unless it is already quoted
	126	$source_name = uc ($source_name) if $source_name !~ /\"/;
e6dd7b42	127	}
e6dd7b42	128	else {
032b2366	129	$source_name = $source->name;
07cda1c5	130	$source_name = uc($source_name) unless $ql;
e6dd7b42	131	}
38aead8e	132
032b2366	133	# trigger_body is a LONG
	134	local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
	135
	136	# disable default bindtype
	137	local $sql_maker->{bindtype} = 'normal';
	138
07cda1c5	139
032b2366	140	# look up the correct sequence automatically
07cda1c5	141	my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
032b2366	142	my ($sql, @bind) = $sql_maker->select (
032b2366	143	'ALL_TRIGGERS',
07cda1c5	144	[qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
032b2366	145	{
07cda1c5	146	$schema ? (OWNER => $schema) : (),
	147	TABLE_NAME => $table \|\| $source_name,
	148	TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
	149	TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
	150	STATUS => 'ENABLED',
032b2366	151	},
032b2366	152	);
e6dd7b42	153
6f5f880d	154	# to find all the triggers that mention the column in question a simple
	155	# regex grep since the trigger_body above is a LONG and hence not searchable
	156	my @triggers = ( map
	157	{ my %inf; @inf{qw/body schema name/} = @$_; \%inf }
	158	( grep
07cda1c5	159	{ $_->[0] =~ /\:new\.${ql}${col}${qr} \| \:new\.$col/xi }
6f5f880d	160	@{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
	161	)
	162	);
	163
	164	# extract all sequence names mentioned in each trigger
	165	for (@triggers) {
	166	$_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
	167	}
	168
	169	my $chosen_trigger;
	170
	171	# if only one trigger matched things are easy
	172	if (@triggers == 1) {
	173
	174	if ( @{$triggers[0]{sequences}} == 1 ) {
	175	$chosen_trigger = $triggers[0];
	176	}
	177	else {
	178	$self->throw_exception( sprintf (
	179	"Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
	180	. "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
	181	$triggers[0]{name},
	182	$source_name,
	183	$col,
	184	$col,
	185	) );
	186	}
	187	}
	188	# got more than one matching trigger - see if we can narrow it down
	189	elsif (@triggers > 1) {
df6e3f5c	190
6f5f880d	191	my @candidates = grep
	192	{ $_->{body} =~ / into \s+ \:new\.$col /xi }
	193	@triggers
	194	;
df6e3f5c	195
6f5f880d	196	if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
6f5f880d	197	$chosen_trigger = $candidates[0];
df6e3f5c	198	}
6f5f880d	199	else {
	200	$self->throw_exception( sprintf (
	201	"Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
	202	. "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
	203	$source_name,
	204	$col,
	205	( join ', ', map { "'$_->{name}'" } @triggers ),
	206	$col,
	207	) );
	208	}
	209	}
	210
	211	if ($chosen_trigger) {
	212	my $seq_name = $chosen_trigger->{sequences}[0];
	213
	214	$seq_name = "$chosen_trigger->{schema}.$seq_name"
	215	unless $seq_name =~ /\./;
df6e3f5c	216
07cda1c5	217	return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
df6e3f5c	218	return $seq_name;
18360aed	219	}
6f5f880d	220
	221	$self->throw_exception( sprintf (
	222	"No suitable BEFORE INSERT triggers found for column %s.%s. "
	223	. "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
	224	$source_name,
	225	$col,
	226	$col,
	227	));
18360aed	228	}
18360aed	229
2e46b6eb	230	sub _sequence_fetch {
2e46b6eb	231	my ( $self, $type, $seq ) = @_;
07cda1c5	232
	233	# use the maker to leverage quoting settings
	234	my $sql_maker = $self->sql_maker;
	235	my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
2e46b6eb	236	return $id;
	237	}
	238
6dc4be0f	239	sub _ping {
c2481821	240	my $self = shift;
7ba7a57d	241
6dc4be0f	242	my $dbh = $self->_dbh or return 0;
7ba7a57d	243
6dc4be0f	244	local $dbh->{RaiseError} = 1;
ecdf1ac8	245	local $dbh->{PrintError} = 0;
c2d7baef	246
52b420dd	247	return try {
ecdf1ac8	248	$dbh->do('select 1 from dual');
52b420dd	249	1;
ed7ab0f4	250	} catch {
52b420dd	251	0;
6dc4be0f	252	};
c2481821	253	}
c2481821	254
d789fa99	255	sub _dbh_execute {
	256	my $self = shift;
	257	my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
	258
87560ef9	259	my (@res, $tried);
dd415de8	260	my $wantarray = wantarray();
4f661051	261	my $next = $self->next::can;
87560ef9	262	do {
52b420dd	263	try {
dd415de8	264	my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
	265
	266	if (!defined $wantarray) {
	267	$exec->();
	268	}
	269	elsif (! $wantarray) {
	270	$res[0] = $exec->();
	271	}
	272	else {
	273	@res = $exec->();
	274	}
87560ef9	275
87560ef9	276	$tried++;
52b420dd	277	}
52b420dd	278	catch {
87560ef9	279	if (! $tried and $_ =~ /ORA-01003/) {
0f0abc97	280	# ORA-01003: no statement parsed (someone changed the table somehow,
	281	# invalidating your cursor.)
	282	my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
	283	delete $dbh->{CachedKids}{$sql};
d789fa99	284	}
52b420dd	285	else {
	286	$self->throw_exception($_);
	287	}
	288	};
87560ef9	289	} while (! $tried++);
d789fa99	290
dd415de8	291	return $wantarray ? @res : $res[0];
d789fa99	292	}
d789fa99	293
7137528d	294	=head2 get_autoinc_seq
	295
	296	Returns the sequence name for an autoincrement column
	297
	298	=cut
	299
18360aed	300	sub get_autoinc_seq {
18360aed	301	my ($self, $source, $col) = @_;
d4daee7b	302
373940e1	303	$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
18360aed	304	}
18360aed	305
8f7e044c	306	=head2 datetime_parser_type
	307
	308	This sets the proper DateTime::Format module for use with
	309	L<DBIx::Class::InflateColumn::DateTime>.
	310
	311	=cut
	312
	313	sub datetime_parser_type { return "DateTime::Format::Oracle"; }
	314
9900b569	315	=head2 connect_call_datetime_setup
d2a3958e	316
	317	Used as:
	318
9900b569	319	on_connect_call => 'datetime_setup'
d2a3958e	320
8384a713	321	In L<connect_info\|DBIx::Class::Storage::DBI/connect_info> to set the session nls
	322	date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
	323	and the necessary environment variables for L<DateTime::Format::Oracle>, which
	324	is used by it.
d2a3958e	325
82f6f45f	326	Maximum allowable precision is used, unless the environment variables have
82f6f45f	327	already been set.
d2a3958e	328
9900b569	329	These are the defaults used:
	330
	331	$ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	332	$ENV{NLS_TIMESTAMP_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF';
	333	$ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	334
d9e53b85	335	To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
	336	for your timestamps, use something like this:
	337
	338	use Time::HiRes 'time';
	339	my $ts = DateTime->from_epoch(epoch => time);
	340
d2a3958e	341	=cut
d2a3958e	342
9900b569	343	sub connect_call_datetime_setup {
d2a3958e	344	my $self = shift;
d2a3958e	345
	346	my $date_format = $ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	347	my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} \|\|=
	348	'YYYY-MM-DD HH24:MI:SS.FF';
	349	my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|=
	350	'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	351
7a84c41b	352	$self->_do_query(
d7a58a29	353	"alter session set nls_date_format = '$date_format'"
d7a58a29	354	);
7a84c41b	355	$self->_do_query(
d7a58a29	356	"alter session set nls_timestamp_format = '$timestamp_format'"
d7a58a29	357	);
7a84c41b	358	$self->_do_query(
d7a58a29	359	"alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
d7a58a29	360	);
d2a3958e	361	}
d2a3958e	362
5db2758d	363	=head2 source_bind_attributes
	364
	365	Handle LOB types in Oracle. Under a certain size (4k?), you can get away
	366	with the driver assuming your input is the deprecated LONG type if you
	367	encode it as a hex string. That ain't gonna fly at larger values, where
	368	you'll discover you have to do what this does.
	369
	370	This method had to be overridden because we need to set ora_field to the
	371	actual column, and that isn't passed to the call (provided by Storage) to
	372	bind_attribute_by_data_type.
	373
	374	According to L<DBD::Oracle>, the ora_field isn't always necessary, but
	375	adding it doesn't hurt, and will save your bacon if you're modifying a
	376	table with more than one LOB column.
	377
	378	=cut
	379
e6dd7b42	380	sub source_bind_attributes
5db2758d	381	{
d7a58a29	382	require DBD::Oracle;
	383	my $self = shift;
	384	my($source) = @_;
5db2758d	385
d7a58a29	386	my %bind_attributes;
5db2758d	387
d7a58a29	388	foreach my $column ($source->columns) {
07cda1c5	389	my $data_type = $source->column_info($column)->{data_type}
07cda1c5	390	or next;
5db2758d	391
d7a58a29	392	my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
5db2758d	393
d7a58a29	394	if ($data_type =~ /^[BC]LOB$/i) {
931e5d43	395	if ($DBD::Oracle::VERSION eq '1.23') {
	396	$self->throw_exception(
	397	"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
555cc3f4	398	"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
931e5d43	399	);
931e5d43	400	}
5db2758d	401
d7a58a29	402	$column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
	403	? DBD::Oracle::ORA_CLOB()
	404	: DBD::Oracle::ORA_BLOB()
	405	;
	406	$column_bind_attrs{'ora_field'} = $column;
	407	}
5db2758d	408
d7a58a29	409	$bind_attributes{$column} = \%column_bind_attrs;
d7a58a29	410	}
5db2758d	411
d7a58a29	412	return \%bind_attributes;
5db2758d	413	}
5db2758d	414
1816be4f	415	sub _svp_begin {
d7a58a29	416	my ($self, $name) = @_;
d7a58a29	417	$self->_get_dbh->do("SAVEPOINT $name");
1816be4f	418	}
1816be4f	419
281719d2	420	# Oracle automatically releases a savepoint when you start another one with the
	421	# same name.
	422	sub _svp_release { 1 }
	423
	424	sub _svp_rollback {
d7a58a29	425	my ($self, $name) = @_;
d7a58a29	426	$self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
281719d2	427	}
281719d2	428
6c0230de	429	=head2 relname_to_table_alias
	430
	431	L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
	432	queries.
	433
	434	Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
af0edca1	435	the L<DBIx::Class::Relationship> name is shortened and appended with half of an
af0edca1	436	MD5 hash.
6c0230de	437
	438	See L<DBIx::Class::Storage/"relname_to_table_alias">.
	439
	440	=cut
	441
	442	sub relname_to_table_alias {
	443	my $self = shift;
	444	my ($relname, $join_count) = @_;
	445
	446	my $alias = $self->next::method(@_);
	447
63ca94e1	448	return $self->sql_maker->_shorten_identifier($alias, [$relname]);
6c0230de	449	}
6c0230de	450
6c0bb6a7	451	=head2 with_deferred_fk_checks
	452
	453	Runs a coderef between:
	454
	455	alter session set constraints = deferred
	456	...
	457	alter session set constraints = immediate
	458
b7b18f32	459	to defer foreign key checks.
	460
	461	Constraints must be declared C<DEFERRABLE> for this to work.
6c0bb6a7	462
	463	=cut
	464
	465	sub with_deferred_fk_checks {
	466	my ($self, $sub) = @_;
b7b18f32	467
	468	my $txn_scope_guard = $self->txn_scope_guard;
	469
6c0bb6a7	470	$self->_do_query('alter session set constraints = deferred');
54161a15	471
b7b18f32	472	my $sg = Scope::Guard->new(sub {
	473	$self->_do_query('alter session set constraints = immediate');
	474	});
281719d2	475
6298a324	476	return
6298a324	477	preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
281719d2	478	}
281719d2	479
c0024355	480	=head1 ATTRIBUTES
	481
	482	Following additional attributes can be used in resultsets.
	483
6b2fbbf0	484	=head2 connect_by or connect_by_nocycle
c0024355	485
	486	=over 4
	487
	488	=item Value: \%connect_by
	489
	490	=back
	491
	492	A hashref of conditions used to specify the relationship between parent rows
	493	and child rows of the hierarchy.
	494
6b2fbbf0	495
c0024355	496	connect_by => { parentid => 'prior personid' }
	497
	498	# adds a connect by statement to the query:
	499	# SELECT
	500	# me.persionid me.firstname, me.lastname, me.parentid
	501	# FROM
	502	# person me
	503	# CONNECT BY
	504	# parentid = prior persionid
6b2fbbf0	505
c0024355	506
6b2fbbf0	507	connect_by_nocycle => { parentid => 'prior personid' }
2ba03b16	508
6b2fbbf0	509	# adds a connect by statement to the query:
	510	# SELECT
	511	# me.persionid me.firstname, me.lastname, me.parentid
	512	# FROM
	513	# person me
	514	# CONNECT BY NOCYCLE
	515	# parentid = prior persionid
2ba03b16	516
2ba03b16	517
c0024355	518	=head2 start_with
	519
	520	=over 4
	521
	522	=item Value: \%condition
	523
	524	=back
	525
	526	A hashref of conditions which specify the root row(s) of the hierarchy.
	527
	528	It uses the same syntax as L<DBIx::Class::ResultSet/search>
	529
	530	start_with => { firstname => 'Foo', lastname => 'Bar' }
	531
	532	# SELECT
	533	# me.persionid me.firstname, me.lastname, me.parentid
	534	# FROM
	535	# person me
	536	# START WITH
	537	# firstname = 'foo' and lastname = 'bar'
	538	# CONNECT BY
	539	# parentid = prior persionid
	540
	541	=head2 order_siblings_by
	542
	543	=over 4
	544
	545	=item Value: ($order_siblings_by \| \@order_siblings_by)
	546
	547	=back
	548
	549	Which column(s) to order the siblings by.
	550
	551	It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
	552
	553	'order_siblings_by' => 'firstname ASC'
	554
	555	# SELECT
	556	# me.persionid me.firstname, me.lastname, me.parentid
	557	# FROM
	558	# person me
	559	# CONNECT BY
	560	# parentid = prior persionid
	561	# ORDER SIBLINGS BY
	562	# firstname ASC
	563
7a84c41b	564	=head1 AUTHOR
18360aed	565
7a84c41b	566	See L<DBIx::Class/CONTRIBUTORS>.
18360aed	567
	568	=head1 LICENSE
	569
	570	You may distribute this code under the same terms as Perl itself.
	571
	572	=cut
7137528d	573
7137528d	574	1;