[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 $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
    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
	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
6298a324	415	return
6298a324	416	preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
281719d2	417	}
281719d2	418
c0024355	419	=head1 ATTRIBUTES
	420
	421	Following additional attributes can be used in resultsets.
	422
6b2fbbf0	423	=head2 connect_by or connect_by_nocycle
c0024355	424
	425	=over 4
	426
	427	=item Value: \%connect_by
	428
	429	=back
	430
	431	A hashref of conditions used to specify the relationship between parent rows
	432	and child rows of the hierarchy.
	433
6b2fbbf0	434
c0024355	435	connect_by => { parentid => 'prior personid' }
	436
	437	# adds a connect by statement to the query:
	438	# SELECT
	439	# me.persionid me.firstname, me.lastname, me.parentid
	440	# FROM
	441	# person me
	442	# CONNECT BY
	443	# parentid = prior persionid
6b2fbbf0	444
c0024355	445
6b2fbbf0	446	connect_by_nocycle => { parentid => 'prior personid' }
2ba03b16	447
6b2fbbf0	448	# adds a connect by statement to the query:
	449	# SELECT
	450	# me.persionid me.firstname, me.lastname, me.parentid
	451	# FROM
	452	# person me
	453	# CONNECT BY NOCYCLE
	454	# parentid = prior persionid
2ba03b16	455
2ba03b16	456
c0024355	457	=head2 start_with
	458
	459	=over 4
	460
	461	=item Value: \%condition
	462
	463	=back
	464
	465	A hashref of conditions which specify the root row(s) of the hierarchy.
	466
	467	It uses the same syntax as L<DBIx::Class::ResultSet/search>
	468
	469	start_with => { firstname => 'Foo', lastname => 'Bar' }
	470
	471	# SELECT
	472	# me.persionid me.firstname, me.lastname, me.parentid
	473	# FROM
	474	# person me
	475	# START WITH
	476	# firstname = 'foo' and lastname = 'bar'
	477	# CONNECT BY
	478	# parentid = prior persionid
	479
	480	=head2 order_siblings_by
	481
	482	=over 4
	483
	484	=item Value: ($order_siblings_by \| \@order_siblings_by)
	485
	486	=back
	487
	488	Which column(s) to order the siblings by.
	489
	490	It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
	491
	492	'order_siblings_by' => 'firstname ASC'
	493
	494	# SELECT
	495	# me.persionid me.firstname, me.lastname, me.parentid
	496	# FROM
	497	# person me
	498	# CONNECT BY
	499	# parentid = prior persionid
	500	# ORDER SIBLINGS BY
	501	# firstname ASC
	502
7a84c41b	503	=head1 AUTHOR
18360aed	504
7a84c41b	505	See L<DBIx::Class/CONTRIBUTORS>.
18360aed	506
	507	=head1 LICENSE
	508
	509	You may distribute this code under the same terms as Perl itself.
	510
	511	=cut
7137528d	512
7137528d	513	1;