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

=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' => 'firstname ASC',
    };
  );

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

  my $oracle_version = eval { $self->_get_dbh->get_info(18) };

  $sqltargs->{producer_args}{oracle_version} = $oracle_version;

  $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 => '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;

  eval {
    $dbh->do("select 1 from dual");
  };

  return $@ ? 0 : 1;
}

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

  my $wantarray = wantarray;

  my (@res, $exception, $retried);

  RETRY: {
    do {
      eval {
        if ($wantarray) {
          @res    = $self->next::method(@_);
        } else {
          $res[0] = $self->next::method(@_);
        }
      };
      $exception = $@;
      if ($exception =~ /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 {
        last RETRY;
      }
    } while (not $retried++);
  }

  $self->throw_exception($exception) if $exception;

  $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 columns_info_for

This wraps the superclass version of this method to force table
names to uppercase

=cut

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

  $self->next::method($table);
}

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

=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 Context::Preserve::preserve_context(sub { $sub->() },
    after => sub { $txn_scope_guard->commit });
}

sub _select_args {
    my ($self, $ident, $select, $where, $attrs) = @_;

    my $connect_by_args = {};
    if ( $attrs->{connect_by} || $attrs->{start_with} || $attrs->{order_siblings_by} ) {
        $connect_by_args = {
            connect_by => $attrs->{connect_by},
            start_with => $attrs->{start_with},
            order_siblings_by => $attrs->{order_siblings_by},
        }
    }

    my @rv = $self->next::method($ident, $select, $where, $attrs);

    return (@rv, $connect_by_args);
}

=head1 ATTRIBUTES

Following additional attributes can be used in resultsets.

=head2 connect_by

=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

=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 ();
b7b18f32	6	use Context::Preserve ();
18360aed	7
7137528d	8	=head1 NAME
7137528d	9
7a84c41b	10	DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
7137528d	11
	12	=head1 SYNOPSIS
	13
d88ecca6	14	# In your result (table) classes
d88ecca6	15	use base 'DBIx::Class::Core';
2e46b6eb	16	__PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
7137528d	17	__PACKAGE__->set_primary_key('id');
	18	__PACKAGE__->sequence('mysequence');
	19
c0024355	20	# Somewhere in your Code
	21	# add some data to a table with a hierarchical relationship
	22	$schema->resultset('Person')->create ({
	23	firstname => 'foo',
	24	lastname => 'bar',
	25	children => [
	26	{
	27	firstname => 'child1',
	28	lastname => 'bar',
	29	children => [
	30	{
	31	firstname => 'grandchild',
	32	lastname => 'bar',
	33	}
	34	],
	35	},
	36	{
	37	firstname => 'child2',
	38	lastname => 'bar',
	39	},
	40	],
	41	});
	42
	43	# select from the hierarchical relationship
	44	my $rs = $schema->resultset('Person')->search({},
	45	{
	46	'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
	47	'connect_by' => { 'parentid' => 'prior persionid'},
	48	'order_siblings_by' => 'firstname ASC',
	49	};
	50	);
	51
	52	# this will select the whole tree starting from person "foo bar", creating
	53	# following query:
	54	# SELECT
	55	# me.persionid me.firstname, me.lastname, me.parentid
	56	# FROM
	57	# person me
	58	# START WITH
	59	# firstname = 'foo' and lastname = 'bar'
	60	# CONNECT BY
	61	# parentid = prior persionid
	62	# ORDER SIBLINGS BY
	63	# firstname ASC
	64
7137528d	65	=head1 DESCRIPTION
7137528d	66
6c0230de	67	This class implements base Oracle support. The subclass
	68	L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
	69	versions before 9.
7137528d	70
	71	=head1 METHODS
	72
	73	=cut
	74
db56cf3d	75	use base qw/DBIx::Class::Storage::DBI/;
2ad62d97	76	use mro 'c3';
18360aed	77
c0024355	78	__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
c0024355	79
dd2600c6	80	sub deployment_statements {
	81	my $self = shift;;
	82	my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
	83
	84	$sqltargs \|\|= {};
032b2366	85	my $quote_char = $self->schema->storage->sql_maker->quote_char;
	86	$sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
	87	$sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
dd2600c6	88
38aead8e	89	my $oracle_version = eval { $self->_get_dbh->get_info(18) };
a4433d8e	90
	91	$sqltargs->{producer_args}{oracle_version} = $oracle_version;
	92
38aead8e	93	$self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
dd2600c6	94	}
dd2600c6	95
18360aed	96	sub _dbh_last_insert_id {
2e46b6eb	97	my ($self, $dbh, $source, @columns) = @_;
	98	my @ids = ();
	99	foreach my $col (@columns) {
	100	my $seq = ($source->column_info($col)->{sequence} \|\|= $self->get_autoinc_seq($source,$col));
	101	my $id = $self->_sequence_fetch( 'currval', $seq );
	102	push @ids, $id;
	103	}
	104	return @ids;
18360aed	105	}
	106
	107	sub _dbh_get_autoinc_seq {
	108	my ($self, $dbh, $source, $col) = @_;
	109
032b2366	110	my $sql_maker = $self->sql_maker;
cb464582	111
e6dd7b42	112	my $source_name;
032b2366	113	if ( ref $source->name eq 'SCALAR' ) {
032b2366	114	$source_name = ${$source->name};
e6dd7b42	115	}
e6dd7b42	116	else {
032b2366	117	$source_name = $source->name;
e6dd7b42	118	}
3963bf4c	119	$source_name = uc($source_name) unless $sql_maker->quote_char;
38aead8e	120
032b2366	121	# trigger_body is a LONG
	122	local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
	123
	124	# disable default bindtype
	125	local $sql_maker->{bindtype} = 'normal';
	126
	127	# look up the correct sequence automatically
	128	my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
	129	my ($sql, @bind) = $sql_maker->select (
	130	'ALL_TRIGGERS',
	131	['trigger_body'],
	132	{
	133	$schema ? (owner => $schema) : (),
	134	table_name => $table \|\| $source_name,
	135	triggering_event => 'INSERT',
	136	status => 'ENABLED',
	137	},
	138	);
	139	my $sth = $dbh->prepare($sql);
	140	$sth->execute (@bind);
e6dd7b42	141
18360aed	142	while (my ($insert_trigger) = $sth->fetchrow_array) {
852a66f6	143	return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
18360aed	144	}
4f2b3017	145	$self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
18360aed	146	}
18360aed	147
2e46b6eb	148	sub _sequence_fetch {
2e46b6eb	149	my ( $self, $type, $seq ) = @_;
9ae966b9	150	my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
2e46b6eb	151	return $id;
	152	}
	153
6dc4be0f	154	sub _ping {
c2481821	155	my $self = shift;
7ba7a57d	156
6dc4be0f	157	my $dbh = $self->_dbh or return 0;
7ba7a57d	158
6dc4be0f	159	local $dbh->{RaiseError} = 1;
c2d7baef	160
6dc4be0f	161	eval {
	162	$dbh->do("select 1 from dual");
	163	};
7ba7a57d	164
6dc4be0f	165	return $@ ? 0 : 1;
c2481821	166	}
c2481821	167
d789fa99	168	sub _dbh_execute {
	169	my $self = shift;
	170	my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
	171
	172	my $wantarray = wantarray;
d789fa99	173
c2d7baef	174	my (@res, $exception, $retried);
c2d7baef	175
0f0abc97	176	RETRY: {
	177	do {
	178	eval {
	179	if ($wantarray) {
c3515436	180	@res = $self->next::method(@_);
0f0abc97	181	} else {
c3515436	182	$res[0] = $self->next::method(@_);
0f0abc97	183	}
	184	};
	185	$exception = $@;
	186	if ($exception =~ /ORA-01003/) {
	187	# ORA-01003: no statement parsed (someone changed the table somehow,
	188	# invalidating your cursor.)
	189	my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
	190	delete $dbh->{CachedKids}{$sql};
d789fa99	191	} else {
0f0abc97	192	last RETRY;
d789fa99	193	}
0f0abc97	194	} while (not $retried++);
0f0abc97	195	}
d789fa99	196
	197	$self->throw_exception($exception) if $exception;
	198
e1958268	199	$wantarray ? @res : $res[0]
d789fa99	200	}
d789fa99	201
7137528d	202	=head2 get_autoinc_seq
	203
	204	Returns the sequence name for an autoincrement column
	205
	206	=cut
	207
18360aed	208	sub get_autoinc_seq {
18360aed	209	my ($self, $source, $col) = @_;
d4daee7b	210
373940e1	211	$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
18360aed	212	}
18360aed	213
7137528d	214	=head2 columns_info_for
	215
	216	This wraps the superclass version of this method to force table
	217	names to uppercase
	218
	219	=cut
	220
18360aed	221	sub columns_info_for {
	222	my ($self, $table) = @_;
	223
dd2600c6	224	$self->next::method($table);
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
82f6f45f	242	In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
	243	timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
	244	necessary environment variables for L<DateTime::Format::Oracle>, which is used
	245	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
	369	return $alias if length($alias) <= 30;
	370
af0edca1	371	# get a base64 md5 of the alias with join_count
	372	require Digest::MD5;
	373	my $ctx = Digest::MD5->new;
	374	$ctx->add($alias);
	375	my $md5 = $ctx->b64digest;
6c0230de	376
f098ade6	377	# remove alignment mark just in case
	378	$md5 =~ s/=*\z//;
	379
af0edca1	380	# truncate and prepend to truncated relname without vowels
af0edca1	381	(my $devoweled = $relname) =~ s/[aeiou]//g;
909668fe	382	my $shortened = substr($devoweled, 0, 18);
6c0230de	383
909668fe	384	my $new_alias =
	385	$shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
	386
	387	return $new_alias;
6c0230de	388	}
6c0230de	389
6c0bb6a7	390	=head2 with_deferred_fk_checks
	391
	392	Runs a coderef between:
	393
	394	alter session set constraints = deferred
	395	...
	396	alter session set constraints = immediate
	397
b7b18f32	398	to defer foreign key checks.
	399
	400	Constraints must be declared C<DEFERRABLE> for this to work.
6c0bb6a7	401
	402	=cut
	403
	404	sub with_deferred_fk_checks {
	405	my ($self, $sub) = @_;
b7b18f32	406
	407	my $txn_scope_guard = $self->txn_scope_guard;
	408
6c0bb6a7	409	$self->_do_query('alter session set constraints = deferred');
54161a15	410
b7b18f32	411	my $sg = Scope::Guard->new(sub {
	412	$self->_do_query('alter session set constraints = immediate');
	413	});
281719d2	414
b7b18f32	415	return Context::Preserve::preserve_context(sub { $sub->() },
b7b18f32	416	after => sub { $txn_scope_guard->commit });
281719d2	417	}
281719d2	418
c0024355	419	sub _select_args {
	420	my ($self, $ident, $select, $where, $attrs) = @_;
	421
	422	my $connect_by_args = {};
	423	if ( $attrs->{connect_by} \|\| $attrs->{start_with} \|\| $attrs->{order_siblings_by} ) {
	424	$connect_by_args = {
	425	connect_by => $attrs->{connect_by},
	426	start_with => $attrs->{start_with},
	427	order_siblings_by => $attrs->{order_siblings_by},
	428	}
	429	}
	430
	431	my @rv = $self->next::method($ident, $select, $where, $attrs);
	432
	433	return (@rv, $connect_by_args);
	434	}
	435
	436	=head1 ATTRIBUTES
	437
	438	Following additional attributes can be used in resultsets.
	439
	440	=head2 connect_by
	441
	442	=over 4
	443
	444	=item Value: \%connect_by
	445
	446	=back
	447
	448	A hashref of conditions used to specify the relationship between parent rows
	449	and child rows of the hierarchy.
	450
	451	connect_by => { parentid => 'prior personid' }
	452
	453	# adds a connect by statement to the query:
	454	# SELECT
	455	# me.persionid me.firstname, me.lastname, me.parentid
	456	# FROM
	457	# person me
	458	# CONNECT BY
	459	# parentid = prior persionid
	460
	461	=head2 start_with
	462
	463	=over 4
	464
	465	=item Value: \%condition
	466
	467	=back
	468
	469	A hashref of conditions which specify the root row(s) of the hierarchy.
	470
	471	It uses the same syntax as L<DBIx::Class::ResultSet/search>
	472
	473	start_with => { firstname => 'Foo', lastname => 'Bar' }
	474
	475	# SELECT
	476	# me.persionid me.firstname, me.lastname, me.parentid
	477	# FROM
	478	# person me
	479	# START WITH
	480	# firstname = 'foo' and lastname = 'bar'
	481	# CONNECT BY
	482	# parentid = prior persionid
483
484	=head2 order_siblings_by
485
486	=over 4
487
488	=item Value: ($order_siblings_by \| \@order_siblings_by)
489
490	=back
491
492	Which column(s) to order the siblings by.
493
494	It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
495
496	'order_siblings_by' => 'firstname ASC'
497
498	# SELECT
499	# me.persionid me.firstname, me.lastname, me.parentid
500	# FROM
501	# person me
502	# CONNECT BY
503	# parentid = prior persionid
504	# ORDER SIBLINGS BY
505	# firstname ASC
506
7a84c41b	507	=head1 AUTHOR
18360aed	508
7a84c41b	509	See L<DBIx::Class/CONTRIBUTORS>.
18360aed	510
	511	=head1 LICENSE
	512
	513	You may distribute this code under the same terms as Perl itself.
	514
	515	=cut
7137528d	516
7137528d	517	1;