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

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