[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Oracle / Generic.pm

package DBIx::Class::Storage::DBI::Oracle::Generic;

use strict;
use warnings;
use Scope::Guard ();
use Context::Preserve ();

=head1 NAME

DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class

=head1 SYNOPSIS

  # In your result (table) classes
  use base 'DBIx::Class::Core';
  __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  __PACKAGE__->set_primary_key('id');
  __PACKAGE__->sequence('mysequence');

  # Somewhere in your Code
  # add some data to a table with a hierarchical relationship
  $schema->resultset('Person')->create ({
        firstname => 'foo',
        lastname => 'bar',
        children => [
            {
                firstname => 'child1',
                lastname => 'bar',
                children => [
                    {
                        firstname => 'grandchild',
                        lastname => 'bar',
                    }
                ],
            },
            {
                firstname => 'child2',
                lastname => 'bar',
            },
        ],
    });

  # select from the hierarchical relationship
  my $rs = $schema->resultset('Person')->search({},
    {
      'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
      'connect_by' => { 'parentid' => { '-prior' => \'persionid' },
      'order_siblings_by' => { -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 = eval { $self->_get_dbh->get_info(18) };

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

  $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
}

sub _dbh_last_insert_id {
  my ($self, $dbh, $source, @columns) = @_;
  my @ids = ();
  foreach my $col (@columns) {
    my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
    my $id = $self->_sequence_fetch( 'currval', $seq );
    push @ids, $id;
  }
  return @ids;
}

sub _dbh_get_autoinc_seq {
  my ($self, $dbh, $source, $col) = @_;

  my $sql_maker = $self->sql_maker;

  my $source_name;
  if ( ref $source->name eq 'SCALAR' ) {
    $source_name = ${$source->name};
  }
  else {
    $source_name = $source->name;
  }
  $source_name = uc($source_name) unless $sql_maker->quote_char;

  # trigger_body is a LONG
  local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);

  # disable default bindtype
  local $sql_maker->{bindtype} = 'normal';

  # look up the correct sequence automatically
  my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
  my ($sql, @bind) = $sql_maker->select (
    'ALL_TRIGGERS',
    ['trigger_body'],
    {
      $schema ? (owner => $schema) : (),
      table_name => $table || $source_name,
      triggering_event => 'INSERT',
      status => 'ENABLED',
     },
  );
  my $sth = $dbh->prepare($sql);
  $sth->execute (@bind);

  while (my ($insert_trigger) = $sth->fetchrow_array) {
    return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
  }
  $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
}

sub _sequence_fetch {
  my ( $self, $type, $seq ) = @_;
  my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
  return $id;
}

sub _ping {
  my $self = shift;

  my $dbh = $self->_dbh or return 0;

  local $dbh->{RaiseError} = 1;
  local $dbh->{PrintError} = 0;

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

  return $@ ? 0 : 1;
}

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

  my $wantarray = wantarray;

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

  RETRY: {
    do {
      eval {
        if ($wantarray) {
          @res    = $self->next::method(@_);
        } else {
          $res[0] = $self->next::method(@_);
        }
      };
      $exception = $@;
      if ($exception =~ /ORA-01003/) {
        # ORA-01003: no statement parsed (someone changed the table somehow,
        # invalidating your cursor.)
        my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
        delete $dbh->{CachedKids}{$sql};
      } else {
        last RETRY;
      }
    } while (not $retried++);
  }

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

  $wantarray ? @res : $res[0]
}

=head2 get_autoinc_seq

Returns the sequence name for an autoincrement column

=cut

sub get_autoinc_seq {
  my ($self, $source, $col) = @_;

  $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
}

=head2 columns_info_for

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

=cut

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

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

=head2 datetime_parser_type

This sets the proper DateTime::Format module for use with
L<DBIx::Class::InflateColumn::DateTime>.

=cut

sub datetime_parser_type { return "DateTime::Format::Oracle"; }

=head2 connect_call_datetime_setup

Used as:

    on_connect_call => 'datetime_setup'

In L<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

=over 4

=item Value: \%connect_by

=back

A hashref of conditions used to specify the relationship between parent rows
and child rows of the hierarchy.

  connect_by => { parentid => 'prior personid' }

  # adds a connect by statement to the query:
  # SELECT
  #     me.persionid me.firstname, me.lastname, me.parentid
  # FROM
  #     person me
  # CONNECT BY
  #     parentid = prior persionid

=head2 connect_by_nocycle

=over 4

=item Value: [1|0]

=back

If you want to use NOCYCLE set to 1.

    connect_by => { parentid => 'prior personid' },
    connect_by_nocycle => 1

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