[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', 'table_owner'],
    {
      $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, $schema) = $sth->fetchrow_array) {
    my ($seq_name) = $insert_trigger =~ m!("?[.\w"]+"?)\.nextval!i;

    next unless $seq_name;

    if ($seq_name !~ /\./) {
      $seq_name = join '.' => $schema, $seq_name;
    }

    return $seq_name;
  }
  $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',
df6e3f5c	137	['trigger_body', 'table_owner'],
032b2366	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
df6e3f5c	148	while (my ($insert_trigger, $schema) = $sth->fetchrow_array) {
72044892	149	my ($seq_name) = $insert_trigger =~ m!("?[.\w"]+"?)\.nextval!i;
df6e3f5c	150
	151	next unless $seq_name;
	152
	153	if ($seq_name !~ /\./) {
72044892	154	$seq_name = join '.' => $schema, $seq_name;
df6e3f5c	155	}
	156
	157	return $seq_name;
18360aed	158	}
df6e3f5c	159	$self->throw_exception("Unable to find a sequence %INSERT% trigger on table '$source_name'.");
18360aed	160	}
18360aed	161
2e46b6eb	162	sub _sequence_fetch {
2e46b6eb	163	my ( $self, $type, $seq ) = @_;
9ae966b9	164	my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
2e46b6eb	165	return $id;
	166	}
	167
6dc4be0f	168	sub _ping {
c2481821	169	my $self = shift;
7ba7a57d	170
6dc4be0f	171	my $dbh = $self->_dbh or return 0;
7ba7a57d	172
6dc4be0f	173	local $dbh->{RaiseError} = 1;
ecdf1ac8	174	local $dbh->{PrintError} = 0;
c2d7baef	175
52b420dd	176	return try {
ecdf1ac8	177	$dbh->do('select 1 from dual');
52b420dd	178	1;
ed7ab0f4	179	} catch {
52b420dd	180	0;
6dc4be0f	181	};
c2481821	182	}
c2481821	183
d789fa99	184	sub _dbh_execute {
	185	my $self = shift;
	186	my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
	187
87560ef9	188	my (@res, $tried);
dd415de8	189	my $wantarray = wantarray();
4f661051	190	my $next = $self->next::can;
87560ef9	191	do {
52b420dd	192	try {
dd415de8	193	my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
	194
	195	if (!defined $wantarray) {
	196	$exec->();
	197	}
	198	elsif (! $wantarray) {
	199	$res[0] = $exec->();
	200	}
	201	else {
	202	@res = $exec->();
	203	}
87560ef9	204
87560ef9	205	$tried++;
52b420dd	206	}
52b420dd	207	catch {
87560ef9	208	if (! $tried and $_ =~ /ORA-01003/) {
0f0abc97	209	# ORA-01003: no statement parsed (someone changed the table somehow,
	210	# invalidating your cursor.)
	211	my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
	212	delete $dbh->{CachedKids}{$sql};
d789fa99	213	}
52b420dd	214	else {
	215	$self->throw_exception($_);
	216	}
	217	};
87560ef9	218	} while (! $tried++);
d789fa99	219
dd415de8	220	return $wantarray ? @res : $res[0];
d789fa99	221	}
d789fa99	222
7137528d	223	=head2 get_autoinc_seq
	224
	225	Returns the sequence name for an autoincrement column
	226
	227	=cut
	228
18360aed	229	sub get_autoinc_seq {
18360aed	230	my ($self, $source, $col) = @_;
d4daee7b	231
373940e1	232	$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
18360aed	233	}
18360aed	234
8f7e044c	235	=head2 datetime_parser_type
	236
	237	This sets the proper DateTime::Format module for use with
	238	L<DBIx::Class::InflateColumn::DateTime>.
	239
	240	=cut
	241
	242	sub datetime_parser_type { return "DateTime::Format::Oracle"; }
	243
9900b569	244	=head2 connect_call_datetime_setup
d2a3958e	245
	246	Used as:
	247
9900b569	248	on_connect_call => 'datetime_setup'
d2a3958e	249
8384a713	250	In L<connect_info\|DBIx::Class::Storage::DBI/connect_info> to set the session nls
	251	date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
	252	and the necessary environment variables for L<DateTime::Format::Oracle>, which
	253	is used by it.
d2a3958e	254
82f6f45f	255	Maximum allowable precision is used, unless the environment variables have
82f6f45f	256	already been set.
d2a3958e	257
9900b569	258	These are the defaults used:
	259
	260	$ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	261	$ENV{NLS_TIMESTAMP_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF';
	262	$ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	263
d9e53b85	264	To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
	265	for your timestamps, use something like this:
	266
	267	use Time::HiRes 'time';
	268	my $ts = DateTime->from_epoch(epoch => time);
	269
d2a3958e	270	=cut
d2a3958e	271
9900b569	272	sub connect_call_datetime_setup {
d2a3958e	273	my $self = shift;
d2a3958e	274
	275	my $date_format = $ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	276	my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} \|\|=
	277	'YYYY-MM-DD HH24:MI:SS.FF';
	278	my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|=
	279	'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	280
7a84c41b	281	$self->_do_query(
d7a58a29	282	"alter session set nls_date_format = '$date_format'"
d7a58a29	283	);
7a84c41b	284	$self->_do_query(
d7a58a29	285	"alter session set nls_timestamp_format = '$timestamp_format'"
d7a58a29	286	);
7a84c41b	287	$self->_do_query(
d7a58a29	288	"alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
d7a58a29	289	);
d2a3958e	290	}
d2a3958e	291
5db2758d	292	=head2 source_bind_attributes
	293
	294	Handle LOB types in Oracle. Under a certain size (4k?), you can get away
	295	with the driver assuming your input is the deprecated LONG type if you
	296	encode it as a hex string. That ain't gonna fly at larger values, where
	297	you'll discover you have to do what this does.
	298
	299	This method had to be overridden because we need to set ora_field to the
	300	actual column, and that isn't passed to the call (provided by Storage) to
	301	bind_attribute_by_data_type.
	302
	303	According to L<DBD::Oracle>, the ora_field isn't always necessary, but
	304	adding it doesn't hurt, and will save your bacon if you're modifying a
	305	table with more than one LOB column.
	306
	307	=cut
	308
e6dd7b42	309	sub source_bind_attributes
5db2758d	310	{
d7a58a29	311	require DBD::Oracle;
	312	my $self = shift;
	313	my($source) = @_;
5db2758d	314
d7a58a29	315	my %bind_attributes;
5db2758d	316
d7a58a29	317	foreach my $column ($source->columns) {
	318	my $data_type = $source->column_info($column)->{data_type} \|\| '';
	319	next unless $data_type;
5db2758d	320
d7a58a29	321	my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
5db2758d	322
d7a58a29	323	if ($data_type =~ /^[BC]LOB$/i) {
931e5d43	324	if ($DBD::Oracle::VERSION eq '1.23') {
	325	$self->throw_exception(
	326	"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
555cc3f4	327	"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
931e5d43	328	);
931e5d43	329	}
5db2758d	330
d7a58a29	331	$column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
	332	? DBD::Oracle::ORA_CLOB()
	333	: DBD::Oracle::ORA_BLOB()
	334	;
	335	$column_bind_attrs{'ora_field'} = $column;
	336	}
5db2758d	337
d7a58a29	338	$bind_attributes{$column} = \%column_bind_attrs;
d7a58a29	339	}
5db2758d	340
d7a58a29	341	return \%bind_attributes;
5db2758d	342	}
5db2758d	343
1816be4f	344	sub _svp_begin {
d7a58a29	345	my ($self, $name) = @_;
d7a58a29	346	$self->_get_dbh->do("SAVEPOINT $name");
1816be4f	347	}
1816be4f	348
281719d2	349	# Oracle automatically releases a savepoint when you start another one with the
	350	# same name.
	351	sub _svp_release { 1 }
	352
	353	sub _svp_rollback {
d7a58a29	354	my ($self, $name) = @_;
d7a58a29	355	$self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
281719d2	356	}
281719d2	357
6c0230de	358	=head2 relname_to_table_alias
	359
	360	L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
	361	queries.
	362
	363	Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
af0edca1	364	the L<DBIx::Class::Relationship> name is shortened and appended with half of an
af0edca1	365	MD5 hash.
6c0230de	366
	367	See L<DBIx::Class::Storage/"relname_to_table_alias">.
	368
	369	=cut
	370
	371	sub relname_to_table_alias {
	372	my $self = shift;
	373	my ($relname, $join_count) = @_;
	374
	375	my $alias = $self->next::method(@_);
	376
63ca94e1	377	return $self->sql_maker->_shorten_identifier($alias, [$relname]);
6c0230de	378	}
6c0230de	379
6c0bb6a7	380	=head2 with_deferred_fk_checks
	381
	382	Runs a coderef between:
	383
	384	alter session set constraints = deferred
	385	...
	386	alter session set constraints = immediate
	387
b7b18f32	388	to defer foreign key checks.
	389
	390	Constraints must be declared C<DEFERRABLE> for this to work.
6c0bb6a7	391
	392	=cut
	393
	394	sub with_deferred_fk_checks {
	395	my ($self, $sub) = @_;
b7b18f32	396
	397	my $txn_scope_guard = $self->txn_scope_guard;
	398
6c0bb6a7	399	$self->_do_query('alter session set constraints = deferred');
54161a15	400
b7b18f32	401	my $sg = Scope::Guard->new(sub {
	402	$self->_do_query('alter session set constraints = immediate');
	403	});
281719d2	404
6298a324	405	return
6298a324	406	preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
281719d2	407	}
281719d2	408
c0024355	409	=head1 ATTRIBUTES
	410
	411	Following additional attributes can be used in resultsets.
	412
6b2fbbf0	413	=head2 connect_by or connect_by_nocycle
c0024355	414
	415	=over 4
	416
	417	=item Value: \%connect_by
	418
	419	=back
	420
	421	A hashref of conditions used to specify the relationship between parent rows
	422	and child rows of the hierarchy.
	423
6b2fbbf0	424
c0024355	425	connect_by => { parentid => 'prior personid' }
	426
	427	# adds a connect by statement to the query:
	428	# SELECT
	429	# me.persionid me.firstname, me.lastname, me.parentid
	430	# FROM
	431	# person me
	432	# CONNECT BY
	433	# parentid = prior persionid
6b2fbbf0	434
c0024355	435
6b2fbbf0	436	connect_by_nocycle => { parentid => 'prior personid' }
2ba03b16	437
6b2fbbf0	438	# adds a connect by statement to the query:
	439	# SELECT
	440	# me.persionid me.firstname, me.lastname, me.parentid
	441	# FROM
	442	# person me
	443	# CONNECT BY NOCYCLE
	444	# parentid = prior persionid
2ba03b16	445
2ba03b16	446
c0024355	447	=head2 start_with
	448
	449	=over 4
	450
	451	=item Value: \%condition
	452
	453	=back
	454
	455	A hashref of conditions which specify the root row(s) of the hierarchy.
	456
	457	It uses the same syntax as L<DBIx::Class::ResultSet/search>
	458
	459	start_with => { firstname => 'Foo', lastname => 'Bar' }
	460
	461	# SELECT
	462	# me.persionid me.firstname, me.lastname, me.parentid
	463	# FROM
	464	# person me
	465	# START WITH
	466	# firstname = 'foo' and lastname = 'bar'
	467	# CONNECT BY
	468	# parentid = prior persionid
	469
	470	=head2 order_siblings_by
	471
	472	=over 4
	473
	474	=item Value: ($order_siblings_by \| \@order_siblings_by)
	475
	476	=back
	477
	478	Which column(s) to order the siblings by.
	479
	480	It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
	481
	482	'order_siblings_by' => 'firstname ASC'
	483
	484	# SELECT
	485	# me.persionid me.firstname, me.lastname, me.parentid
	486	# FROM
	487	# person me
	488	# CONNECT BY
	489	# parentid = prior persionid
	490	# ORDER SIBLINGS BY
	491	# firstname ASC
	492
7a84c41b	493	=head1 AUTHOR
18360aed	494
7a84c41b	495	See L<DBIx::Class/CONTRIBUTORS>.
18360aed	496
	497	=head1 LICENSE
	498
	499	You may distribute this code under the same terms as Perl itself.
	500
	501	=cut
7137528d	502
7137528d	503	1;