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

=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');
  __PACKAGE__->sequence('mysequence');

  # 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' => \'persionid' },
      '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 persionid
  # 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::SQLAHacks::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 $source_name;
  if ( ref $source->name eq 'SCALAR' ) {
    $source_name = ${$source->name};
  }
  else {
    $source_name = $source->name;
  }
  $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);

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

  # look up the correct sequence automatically
  my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
  my ($sql, @bind) = $sql_maker->select (
    'ALL_TRIGGERS',
    ['trigger_body'],
    {
      $schema ? (owner => $schema) : (),
      table_name => $table || $source_name,
      triggering_event => { -like => '%INSERT%' },
      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???
  }
  $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
}

sub _sequence_fetch {
  my ( $self, $type, $seq ) = @_;
  my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
  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} || '';
    next unless $data_type;

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