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

__PACKAGE__->sql_limit_dialect ('RowNum');

=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::SQLMaker::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 .+ into \s+ :new\.$col/xmsi;

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