[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');
__PACKAGE__->sql_quote_char ('"');

=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');

  # 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' => { -ident => 'personid' } },
      '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 personid
  # 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');
__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');

sub _determine_supports_insert_returning {
  my $self = shift;

# TODO find out which version supports the RETURNING syntax
# 8i has it and earlier docs are a 404 on oracle.com

  return 1
    if $self->_server_info->{normalized_dbms_version} >= 8.001;

  return 0;
}

__PACKAGE__->_use_insert_returning_bound (1);

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 ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;

  my $source_name;
  if ( ref $source->name eq 'SCALAR' ) {
    $source_name = ${$source->name};

    # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
    # stuff unless it is already quoted
    $source_name = uc ($source_name) if $source_name !~ /\"/;
  }
  else {
    $source_name = $source->name;
    $source_name = uc($source_name) unless $ql;
  }

  # 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 =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;

  # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
  $schema ||= uc( ($self->_dbi_connect_info||[])->[1] || '');

  my ($sql, @bind) = $sql_maker->select (
    'ALL_TRIGGERS',
    [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
    {
      $schema ? (OWNER => $schema) : (),
      TABLE_NAME => $table || $source_name,
      TRIGGERING_EVENT => { -like => '%INSERT%' },  # this will also catch insert_or_update
      TRIGGER_TYPE => { -like => '%BEFORE%' },      # we care only about 'before' triggers
      STATUS => 'ENABLED',
     },
  );

  # to find all the triggers that mention the column in question a simple
  # regex grep since the trigger_body above is a LONG and hence not searchable
  my @triggers = ( map
    { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
    ( grep
      { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
      @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
    )
  );

  # extract all sequence names mentioned in each trigger
  for (@triggers) {
    $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
  }

  my $chosen_trigger;

  # if only one trigger matched things are easy
  if (@triggers == 1) {

    if ( @{$triggers[0]{sequences}} == 1 ) {
      $chosen_trigger = $triggers[0];
    }
    else {
      $self->throw_exception( sprintf (
        "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
      . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
        $triggers[0]{name},
        $source_name,
        $col,
        $col,
      ) );
    }
  }
  # got more than one matching trigger - see if we can narrow it down
  elsif (@triggers > 1) {

    my @candidates = grep
      { $_->{body} =~ / into \s+ \:new\.$col /xi }
      @triggers
    ;

    if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
      $chosen_trigger = $candidates[0];
    }
    else {
      $self->throw_exception( sprintf (
        "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
      . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
        $source_name,
        $col,
        ( join ', ', map { "'$_->{name}'" } @triggers ),
        $col,
      ) );
    }
  }

  if ($chosen_trigger) {
    my $seq_name = $chosen_trigger->{sequences}[0];

    $seq_name = "$chosen_trigger->{schema}.$seq_name"
      unless $seq_name =~ /\./;

    return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
    return $seq_name;
  }

  $self->throw_exception( sprintf (
    "No suitable BEFORE INSERT triggers found for column %s.%s. "
  . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
    $source_name,
    $col,
    $col,
  ));
}

sub _sequence_fetch {
  my ( $self, $type, $seq ) = @_;

  # use the maker to leverage quoting settings
  my $sql_maker = $self->sql_maker;
  my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
  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, $dbh, $sql, @args) = @_;

  my (@res, $tried);
  my $want = wantarray;
  my $next = $self->next::can;
  do {
    try {
      my $exec = sub { $self->$next($dbh, $sql, @args) };

      if (!defined $want) {
        $exec->();
      }
      elsif (! $want) {
        $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.)
        delete $dbh->{CachedKids}{$sql};
      }
      else {
        $self->throw_exception($_);
      }
    };
  } while (! $tried++);

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

sub _dbh_execute_array {
  #my ($self, $sth, $tuple_status, @extra) = @_;

  # DBD::Oracle warns loudly on partial execute_array failures
  local $_[1]->{PrintWarn} = 0;

  shift->next::method(@_);
}

=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>.

=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'"
  );
}

### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
#
# 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.
#
sub _dbi_attrs_for_bind {
  my ($self, $ident, $bind) = @_;
  my $attrs = $self->next::method($ident, $bind);

  for my $i (0 .. $#$attrs) {
    if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) {
      $attrs->[$i]{ora_field} = $col;
    }
  }

  $attrs;
}

my $dbd_loaded;
sub bind_attribute_by_data_type {
  my ($self, $dt) = @_;

  $dbd_loaded ||= do {
    require DBD::Oracle;
    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"
      );
    }
    1;
  };

  if ($self->_is_lob_type($dt)) {
    return {
      ora_type => $self->_is_text_lob_type($dt)
        ? DBD::Oracle::ORA_CLOB()
        : DBD::Oracle::ORA_BLOB()
    };
  }
}

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(@_);

  # we need to shorten here in addition to the shortening in SQLA itself,
  # since the final relnames are a crucial for the join optimizer
  return $self->sql_maker->_shorten_identifier($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
6a247f33	10	__PACKAGE__->sql_limit_dialect ('RowNum');
2b8cc2f2	11	__PACKAGE__->sql_quote_char ('"');
6a247f33	12
7137528d	13	=head1 NAME
7137528d	14
7a84c41b	15	DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
7137528d	16
	17	=head1 SYNOPSIS
	18
d88ecca6	19	# In your result (table) classes
d88ecca6	20	use base 'DBIx::Class::Core';
2e46b6eb	21	__PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
7137528d	22	__PACKAGE__->set_primary_key('id');
7137528d	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' },
e6600283	51	'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
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
e6600283	65	# parentid = prior personid
c0024355	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');
6f7a118e	83	__PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
c0024355	84
bf51641f	85	sub _determine_supports_insert_returning {
	86	my $self = shift;
	87
	88	# TODO find out which version supports the RETURNING syntax
	89	# 8i has it and earlier docs are a 404 on oracle.com
	90
	91	return 1
	92	if $self->_server_info->{normalized_dbms_version} >= 8.001;
	93
	94	return 0;
	95	}
	96
	97	__PACKAGE__->_use_insert_returning_bound (1);
	98
dd2600c6	99	sub deployment_statements {
	100	my $self = shift;;
	101	my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
	102
	103	$sqltargs \|\|= {};
032b2366	104	my $quote_char = $self->schema->storage->sql_maker->quote_char;
	105	$sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
	106	$sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
dd2600c6	107
96736321	108	if (
	109	! exists $sqltargs->{producer_args}{oracle_version}
	110	and
	111	my $dver = $self->_server_info->{dbms_version}
	112	) {
	113	$sqltargs->{producer_args}{oracle_version} = $dver;
	114	}
a4433d8e	115
38aead8e	116	$self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
dd2600c6	117	}
dd2600c6	118
18360aed	119	sub _dbh_last_insert_id {
2e46b6eb	120	my ($self, $dbh, $source, @columns) = @_;
	121	my @ids = ();
	122	foreach my $col (@columns) {
	123	my $seq = ($source->column_info($col)->{sequence} \|\|= $self->get_autoinc_seq($source,$col));
07cda1c5	124	my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
2e46b6eb	125	push @ids, $id;
	126	}
	127	return @ids;
18360aed	128	}
	129
	130	sub _dbh_get_autoinc_seq {
	131	my ($self, $dbh, $source, $col) = @_;
	132
032b2366	133	my $sql_maker = $self->sql_maker;
07cda1c5	134	my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
cb464582	135
e6dd7b42	136	my $source_name;
032b2366	137	if ( ref $source->name eq 'SCALAR' ) {
032b2366	138	$source_name = ${$source->name};
07cda1c5	139
	140	# the ALL_TRIGGERS match further on is case sensitive - thus uppercase
	141	# stuff unless it is already quoted
	142	$source_name = uc ($source_name) if $source_name !~ /\"/;
e6dd7b42	143	}
e6dd7b42	144	else {
032b2366	145	$source_name = $source->name;
07cda1c5	146	$source_name = uc($source_name) unless $ql;
e6dd7b42	147	}
38aead8e	148
032b2366	149	# trigger_body is a LONG
	150	local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
	151
	152	# disable default bindtype
	153	local $sql_maker->{bindtype} = 'normal';
	154
	155	# look up the correct sequence automatically
07cda1c5	156	my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
a6646e1b	157
	158	# if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
	159	$schema \|\|= uc( ($self->_dbi_connect_info\|\|[])->[1] \|\| '');
	160
032b2366	161	my ($sql, @bind) = $sql_maker->select (
032b2366	162	'ALL_TRIGGERS',
07cda1c5	163	[qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
032b2366	164	{
07cda1c5	165	$schema ? (OWNER => $schema) : (),
	166	TABLE_NAME => $table \|\| $source_name,
	167	TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
	168	TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
	169	STATUS => 'ENABLED',
032b2366	170	},
032b2366	171	);
e6dd7b42	172
6f5f880d	173	# to find all the triggers that mention the column in question a simple
	174	# regex grep since the trigger_body above is a LONG and hence not searchable
	175	my @triggers = ( map
	176	{ my %inf; @inf{qw/body schema name/} = @$_; \%inf }
	177	( grep
07cda1c5	178	{ $_->[0] =~ /\:new\.${ql}${col}${qr} \| \:new\.$col/xi }
6f5f880d	179	@{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
	180	)
	181	);
	182
	183	# extract all sequence names mentioned in each trigger
	184	for (@triggers) {
	185	$_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
	186	}
	187
	188	my $chosen_trigger;
	189
	190	# if only one trigger matched things are easy
	191	if (@triggers == 1) {
	192
	193	if ( @{$triggers[0]{sequences}} == 1 ) {
	194	$chosen_trigger = $triggers[0];
	195	}
	196	else {
	197	$self->throw_exception( sprintf (
	198	"Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
	199	. "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
	200	$triggers[0]{name},
	201	$source_name,
	202	$col,
	203	$col,
	204	) );
	205	}
	206	}
	207	# got more than one matching trigger - see if we can narrow it down
	208	elsif (@triggers > 1) {
df6e3f5c	209
6f5f880d	210	my @candidates = grep
	211	{ $_->{body} =~ / into \s+ \:new\.$col /xi }
	212	@triggers
	213	;
df6e3f5c	214
6f5f880d	215	if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
6f5f880d	216	$chosen_trigger = $candidates[0];
df6e3f5c	217	}
6f5f880d	218	else {
	219	$self->throw_exception( sprintf (
	220	"Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
	221	. "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
	222	$source_name,
	223	$col,
	224	( join ', ', map { "'$_->{name}'" } @triggers ),
	225	$col,
	226	) );
	227	}
	228	}
	229
	230	if ($chosen_trigger) {
	231	my $seq_name = $chosen_trigger->{sequences}[0];
	232
	233	$seq_name = "$chosen_trigger->{schema}.$seq_name"
	234	unless $seq_name =~ /\./;
df6e3f5c	235
07cda1c5	236	return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
df6e3f5c	237	return $seq_name;
18360aed	238	}
6f5f880d	239
	240	$self->throw_exception( sprintf (
	241	"No suitable BEFORE INSERT triggers found for column %s.%s. "
	242	. "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
	243	$source_name,
	244	$col,
	245	$col,
	246	));
18360aed	247	}
18360aed	248
2e46b6eb	249	sub _sequence_fetch {
2e46b6eb	250	my ( $self, $type, $seq ) = @_;
07cda1c5	251
	252	# use the maker to leverage quoting settings
	253	my $sql_maker = $self->sql_maker;
	254	my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
2e46b6eb	255	return $id;
	256	}
	257
6dc4be0f	258	sub _ping {
c2481821	259	my $self = shift;
7ba7a57d	260
6dc4be0f	261	my $dbh = $self->_dbh or return 0;
7ba7a57d	262
6dc4be0f	263	local $dbh->{RaiseError} = 1;
ecdf1ac8	264	local $dbh->{PrintError} = 0;
c2d7baef	265
52b420dd	266	return try {
ecdf1ac8	267	$dbh->do('select 1 from dual');
52b420dd	268	1;
ed7ab0f4	269	} catch {
52b420dd	270	0;
6dc4be0f	271	};
c2481821	272	}
c2481821	273
d789fa99	274	sub _dbh_execute {
0e773352	275	my ($self, $dbh, $sql, @args) = @_;
d789fa99	276
87560ef9	277	my (@res, $tried);
cca282b6	278	my $want = wantarray;
4f661051	279	my $next = $self->next::can;
87560ef9	280	do {
52b420dd	281	try {
0e773352	282	my $exec = sub { $self->$next($dbh, $sql, @args) };
dd415de8	283
cca282b6	284	if (!defined $want) {
dd415de8	285	$exec->();
dd415de8	286	}
cca282b6	287	elsif (! $want) {
dd415de8	288	$res[0] = $exec->();
	289	}
	290	else {
	291	@res = $exec->();
	292	}
87560ef9	293
87560ef9	294	$tried++;
52b420dd	295	}
52b420dd	296	catch {
87560ef9	297	if (! $tried and $_ =~ /ORA-01003/) {
0f0abc97	298	# ORA-01003: no statement parsed (someone changed the table somehow,
0f0abc97	299	# invalidating your cursor.)
0f0abc97	300	delete $dbh->{CachedKids}{$sql};
d789fa99	301	}
52b420dd	302	else {
	303	$self->throw_exception($_);
	304	}
	305	};
87560ef9	306	} while (! $tried++);
d789fa99	307
cca282b6	308	return wantarray ? @res : $res[0];
d789fa99	309	}
d789fa99	310
a5a27e7a	311	sub _dbh_execute_array {
	312	#my ($self, $sth, $tuple_status, @extra) = @_;
	313
	314	# DBD::Oracle warns loudly on partial execute_array failures
	315	local $_[1]->{PrintWarn} = 0;
	316
	317	shift->next::method(@_);
	318	}
	319
7137528d	320	=head2 get_autoinc_seq
	321
	322	Returns the sequence name for an autoincrement column
	323
	324	=cut
	325
18360aed	326	sub get_autoinc_seq {
18360aed	327	my ($self, $source, $col) = @_;
d4daee7b	328
373940e1	329	$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
18360aed	330	}
18360aed	331
8f7e044c	332	=head2 datetime_parser_type
	333
	334	This sets the proper DateTime::Format module for use with
	335	L<DBIx::Class::InflateColumn::DateTime>.
	336
9900b569	337	=head2 connect_call_datetime_setup
d2a3958e	338
	339	Used as:
	340
9900b569	341	on_connect_call => 'datetime_setup'
d2a3958e	342
8384a713	343	In L<connect_info\|DBIx::Class::Storage::DBI/connect_info> to set the session nls
	344	date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
	345	and the necessary environment variables for L<DateTime::Format::Oracle>, which
	346	is used by it.
d2a3958e	347
82f6f45f	348	Maximum allowable precision is used, unless the environment variables have
82f6f45f	349	already been set.
d2a3958e	350
9900b569	351	These are the defaults used:
	352
	353	$ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	354	$ENV{NLS_TIMESTAMP_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF';
	355	$ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	356
d9e53b85	357	To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
	358	for your timestamps, use something like this:
	359
	360	use Time::HiRes 'time';
	361	my $ts = DateTime->from_epoch(epoch => time);
	362
d2a3958e	363	=cut
d2a3958e	364
9900b569	365	sub connect_call_datetime_setup {
d2a3958e	366	my $self = shift;
d2a3958e	367
	368	my $date_format = $ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	369	my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} \|\|=
	370	'YYYY-MM-DD HH24:MI:SS.FF';
	371	my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|=
	372	'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	373
7a84c41b	374	$self->_do_query(
d7a58a29	375	"alter session set nls_date_format = '$date_format'"
d7a58a29	376	);
7a84c41b	377	$self->_do_query(
d7a58a29	378	"alter session set nls_timestamp_format = '$timestamp_format'"
d7a58a29	379	);
7a84c41b	380	$self->_do_query(
d7a58a29	381	"alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
d7a58a29	382	);
d2a3958e	383	}
d2a3958e	384
0e773352	385	### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
	386	### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
	387	#
	388	# Handle LOB types in Oracle. Under a certain size (4k?), you can get away
	389	# with the driver assuming your input is the deprecated LONG type if you
	390	# encode it as a hex string. That ain't gonna fly at larger values, where
	391	# you'll discover you have to do what this does.
	392	#
	393	# This method had to be overridden because we need to set ora_field to the
	394	# actual column, and that isn't passed to the call (provided by Storage) to
	395	# bind_attribute_by_data_type.
	396	#
	397	# According to L<DBD::Oracle>, the ora_field isn't always necessary, but
	398	# adding it doesn't hurt, and will save your bacon if you're modifying a
	399	# table with more than one LOB column.
	400	#
	401	sub _dbi_attrs_for_bind {
	402	my ($self, $ident, $bind) = @_;
	403	my $attrs = $self->next::method($ident, $bind);
	404
	405	for my $i (0 .. $#$attrs) {
	406	if (keys %{$attrs->[$i]\|\|{}} and my $col = $bind->[$i][0]{dbic_colname}) {
	407	$attrs->[$i]{ora_field} = $col;
	408	}
	409	}
5db2758d	410
0e773352	411	$attrs;
0e773352	412	}
5db2758d	413
0e773352	414	my $dbd_loaded;
	415	sub bind_attribute_by_data_type {
	416	my ($self, $dt) = @_;
	417
	418	$dbd_loaded \|\|= do {
	419	require DBD::Oracle;
	420	if ($DBD::Oracle::VERSION eq '1.23') {
	421	$self->throw_exception(
	422	"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
	423	"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
	424	);
	425	}
	426	1;
	427	};
5db2758d	428
0e773352	429	if ($self->_is_lob_type($dt)) {
	430	return {
	431	ora_type => $self->_is_text_lob_type($dt)
d7a58a29	432	? DBD::Oracle::ORA_CLOB()
d7a58a29	433	: DBD::Oracle::ORA_BLOB()
0e773352	434	};
d7a58a29	435	}
5db2758d	436	}
5db2758d	437
1816be4f	438	sub _svp_begin {
d7a58a29	439	my ($self, $name) = @_;
d7a58a29	440	$self->_get_dbh->do("SAVEPOINT $name");
1816be4f	441	}
1816be4f	442
281719d2	443	# Oracle automatically releases a savepoint when you start another one with the
	444	# same name.
	445	sub _svp_release { 1 }
	446
	447	sub _svp_rollback {
d7a58a29	448	my ($self, $name) = @_;
d7a58a29	449	$self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
281719d2	450	}
281719d2	451
6c0230de	452	=head2 relname_to_table_alias
	453
	454	L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
	455	queries.
	456
	457	Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
af0edca1	458	the L<DBIx::Class::Relationship> name is shortened and appended with half of an
af0edca1	459	MD5 hash.
6c0230de	460
	461	See L<DBIx::Class::Storage/"relname_to_table_alias">.
	462
	463	=cut
	464
	465	sub relname_to_table_alias {
	466	my $self = shift;
	467	my ($relname, $join_count) = @_;
	468
	469	my $alias = $self->next::method(@_);
	470
19c4cc62	471	# we need to shorten here in addition to the shortening in SQLA itself,
	472	# since the final relnames are a crucial for the join optimizer
	473	return $self->sql_maker->_shorten_identifier($alias);
6c0230de	474	}
6c0230de	475
6c0bb6a7	476	=head2 with_deferred_fk_checks
	477
	478	Runs a coderef between:
	479
	480	alter session set constraints = deferred
	481	...
	482	alter session set constraints = immediate
	483
b7b18f32	484	to defer foreign key checks.
	485
	486	Constraints must be declared C<DEFERRABLE> for this to work.
6c0bb6a7	487
	488	=cut
	489
	490	sub with_deferred_fk_checks {
	491	my ($self, $sub) = @_;
b7b18f32	492
	493	my $txn_scope_guard = $self->txn_scope_guard;
	494
6c0bb6a7	495	$self->_do_query('alter session set constraints = deferred');
54161a15	496
b7b18f32	497	my $sg = Scope::Guard->new(sub {
	498	$self->_do_query('alter session set constraints = immediate');
	499	});
281719d2	500
6298a324	501	return
6298a324	502	preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
281719d2	503	}
281719d2	504
c0024355	505	=head1 ATTRIBUTES
	506
	507	Following additional attributes can be used in resultsets.
	508
6b2fbbf0	509	=head2 connect_by or connect_by_nocycle
c0024355	510
	511	=over 4
	512
	513	=item Value: \%connect_by
	514
	515	=back
	516
	517	A hashref of conditions used to specify the relationship between parent rows
	518	and child rows of the hierarchy.
	519
6b2fbbf0	520
c0024355	521	connect_by => { parentid => 'prior personid' }
	522
	523	# adds a connect by statement to the query:
	524	# SELECT
	525	# me.persionid me.firstname, me.lastname, me.parentid
	526	# FROM
	527	# person me
	528	# CONNECT BY
	529	# parentid = prior persionid
6b2fbbf0	530
c0024355	531
6b2fbbf0	532	connect_by_nocycle => { parentid => 'prior personid' }
2ba03b16	533
6b2fbbf0	534	# adds a connect by statement to the query:
	535	# SELECT
	536	# me.persionid me.firstname, me.lastname, me.parentid
	537	# FROM
	538	# person me
	539	# CONNECT BY NOCYCLE
	540	# parentid = prior persionid
2ba03b16	541
2ba03b16	542
c0024355	543	=head2 start_with
	544
	545	=over 4
	546
	547	=item Value: \%condition
	548
	549	=back
	550
	551	A hashref of conditions which specify the root row(s) of the hierarchy.
	552
	553	It uses the same syntax as L<DBIx::Class::ResultSet/search>
	554
	555	start_with => { firstname => 'Foo', lastname => 'Bar' }
	556
	557	# SELECT
	558	# me.persionid me.firstname, me.lastname, me.parentid
	559	# FROM
	560	# person me
	561	# START WITH
	562	# firstname = 'foo' and lastname = 'bar'
	563	# CONNECT BY
	564	# parentid = prior persionid
	565
	566	=head2 order_siblings_by
	567
	568	=over 4
	569
	570	=item Value: ($order_siblings_by \| \@order_siblings_by)
	571
	572	=back
	573
	574	Which column(s) to order the siblings by.
	575
	576	It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
	577
	578	'order_siblings_by' => 'firstname ASC'
	579
	580	# SELECT
	581	# me.persionid me.firstname, me.lastname, me.parentid
	582	# FROM
	583	# person me
	584	# CONNECT BY
	585	# parentid = prior persionid
	586	# ORDER SIBLINGS BY
	587	# firstname ASC
	588
7a84c41b	589	=head1 AUTHOR
18360aed	590
7a84c41b	591	See L<DBIx::Class/CONTRIBUTORS>.
18360aed	592
	593	=head1 LICENSE
	594
	595	You may distribute this code under the same terms as Perl itself.
	596
	597	=cut
7137528d	598
7137528d	599	1;