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

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

use strict;
use warnings;

=head1 NAME

DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle

=head1 SYNOPSIS

  # In your table classes
  __PACKAGE__->load_components(qw/PK::Auto Core/);
  __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  __PACKAGE__->set_primary_key('id');
  __PACKAGE__->sequence('mysequence');

=head1 DESCRIPTION

This class implements autoincrements for Oracle.

=head1 METHODS

=cut

use base qw/DBIx::Class::Storage::DBI/;
use Carp::Clan qw/^DBIx::Class/;

# For ORA_BLOB => 113, ORA_CLOB => 112
use DBD::Oracle qw( :ora_types );

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

  # look up the correct sequence automatically
  my $sql = q{
    SELECT trigger_body FROM ALL_TRIGGERS t
    WHERE t.table_name = ?
    AND t.triggering_event = 'INSERT'
    AND t.status = 'ENABLED'
  };

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

  my $sth;

  # check for fully-qualified name (eg. SCHEMA.TABLENAME)
  if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
    $sql = q{
      SELECT trigger_body FROM ALL_TRIGGERS t
      WHERE t.owner = ? AND t.table_name = ?
      AND t.triggering_event = 'INSERT'
      AND t.status = 'ENABLED'
    };
    $sth = $dbh->prepare($sql);
    $sth->execute( uc($schema), uc($table) );
  }
  else {
    $sth = $dbh->prepare($sql);
    $sth->execute( uc( $source->name ) );
  }
  while (my ($insert_trigger) = $sth->fetchrow_array) {
    return uc($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->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
  return $id;
}

=head2 connected

Returns true if we have an open (and working) database connection, false if it is not (yet)
open (or does not work). (Executes a simple SELECT to make sure it works.)

The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
OCIPing but just gets the server version, which doesn't help if someone killed
your session.

=cut

sub connected {
  my $self = shift;

  if (not $self->next::method(@_)) {
    return 0;
  } else {
    my $dbh = $self->_dbh;

    local $dbh->{RaiseError} = 1;

    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(uc($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<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 $dbh  = $self->dbh;

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

  $dbh->do("alter session set nls_date_format = '$date_format'");
  $dbh->do("alter session set nls_timestamp_format = '$timestamp_format'");
  $dbh->do("alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
}

sub _svp_begin {
    my ($self, $name) = @_;
 
    $self->dbh->do("SAVEPOINT $name");
}

=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 
{
	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) {
			$column_bind_attrs{'ora_type'}
				= uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
			$column_bind_attrs{'ora_field'} = $column;
		}

		$bind_attributes{$column} = \%column_bind_attrs;
	}

	return \%bind_attributes;
}

# 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->dbh->do("ROLLBACK TO SAVEPOINT $name")
}

=head1 AUTHORS

Andy Grundman <andy@hybridized.org>

Scott Connelly <scottsweep@yahoo.com>

=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;
	5
7137528d	6	=head1 NAME
7137528d	7
92bc2a19	8	DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle
7137528d	9
	10	=head1 SYNOPSIS
	11
	12	# In your table classes
	13	__PACKAGE__->load_components(qw/PK::Auto Core/);
2e46b6eb	14	__PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
7137528d	15	__PACKAGE__->set_primary_key('id');
	16	__PACKAGE__->sequence('mysequence');
	17
	18	=head1 DESCRIPTION
	19
	20	This class implements autoincrements for Oracle.
	21
	22	=head1 METHODS
	23
	24	=cut
	25
db56cf3d	26	use base qw/DBIx::Class::Storage::DBI/;
18360aed	27	use Carp::Clan qw/^DBIx::Class/;
18360aed	28
66cf3a84	29	# For ORA_BLOB => 113, ORA_CLOB => 112
5db2758d	30	use DBD::Oracle qw( :ora_types );
5db2758d	31
18360aed	32	sub _dbh_last_insert_id {
2e46b6eb	33	my ($self, $dbh, $source, @columns) = @_;
	34	my @ids = ();
	35	foreach my $col (@columns) {
	36	my $seq = ($source->column_info($col)->{sequence} \|\|= $self->get_autoinc_seq($source,$col));
	37	my $id = $self->_sequence_fetch( 'currval', $seq );
	38	push @ids, $id;
	39	}
	40	return @ids;
18360aed	41	}
	42
	43	sub _dbh_get_autoinc_seq {
	44	my ($self, $dbh, $source, $col) = @_;
	45
	46	# look up the correct sequence automatically
	47	my $sql = q{
	48	SELECT trigger_body FROM ALL_TRIGGERS t
	49	WHERE t.table_name = ?
	50	AND t.triggering_event = 'INSERT'
	51	AND t.status = 'ENABLED'
	52	};
	53
	54	# trigger_body is a LONG
	55	$dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
	56
cb464582	57	my $sth;
	58
	59	# check for fully-qualified name (eg. SCHEMA.TABLENAME)
	60	if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
	61	$sql = q{
	62	SELECT trigger_body FROM ALL_TRIGGERS t
	63	WHERE t.owner = ? AND t.table_name = ?
	64	AND t.triggering_event = 'INSERT'
	65	AND t.status = 'ENABLED'
	66	};
	67	$sth = $dbh->prepare($sql);
	68	$sth->execute( uc($schema), uc($table) );
	69	}
	70	else {
	71	$sth = $dbh->prepare($sql);
	72	$sth->execute( uc( $source->name ) );
	73	}
18360aed	74	while (my ($insert_trigger) = $sth->fetchrow_array) {
	75	return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
	76	}
66cab05c	77	$self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
18360aed	78	}
18360aed	79
2e46b6eb	80	sub _sequence_fetch {
	81	my ( $self, $type, $seq ) = @_;
	82	my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
	83	return $id;
	84	}
	85
20f27051	86	=head2 connected
	87
	88	Returns true if we have an open (and working) database connection, false if it is not (yet)
	89	open (or does not work). (Executes a simple SELECT to make sure it works.)
	90
0f0abc97	91	The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
	92	OCIPing but just gets the server version, which doesn't help if someone killed
	93	your session.
	94
20f27051	95	=cut
20f27051	96
c2481821	97	sub connected {
c2481821	98	my $self = shift;
7ba7a57d	99
c3515436	100	if (not $self->next::method(@_)) {
c2d7baef	101	return 0;
2932b9a6	102	} else {
7ba7a57d	103	my $dbh = $self->_dbh;
7ba7a57d	104
7ba7a57d	105	local $dbh->{RaiseError} = 1;
c2d7baef	106
7ba7a57d	107	eval {
2932b9a6	108	$dbh->do("select 1 from dual");
7ba7a57d	109	};
7ba7a57d	110
c2d7baef	111	return $@ ? 0 : 1;
c2481821	112	}
c2481821	113	}
c2481821	114
d789fa99	115	sub _dbh_execute {
	116	my $self = shift;
	117	my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
	118
	119	my $wantarray = wantarray;
d789fa99	120
c2d7baef	121	my (@res, $exception, $retried);
c2d7baef	122
0f0abc97	123	RETRY: {
	124	do {
	125	eval {
	126	if ($wantarray) {
c3515436	127	@res = $self->next::method(@_);
0f0abc97	128	} else {
c3515436	129	$res[0] = $self->next::method(@_);
0f0abc97	130	}
	131	};
	132	$exception = $@;
	133	if ($exception =~ /ORA-01003/) {
	134	# ORA-01003: no statement parsed (someone changed the table somehow,
	135	# invalidating your cursor.)
	136	my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
	137	delete $dbh->{CachedKids}{$sql};
d789fa99	138	} else {
0f0abc97	139	last RETRY;
d789fa99	140	}
0f0abc97	141	} while (not $retried++);
0f0abc97	142	}
d789fa99	143
	144	$self->throw_exception($exception) if $exception;
	145
	146	wantarray ? @res : $res[0]
	147	}
	148
7137528d	149	=head2 get_autoinc_seq
	150
	151	Returns the sequence name for an autoincrement column
	152
	153	=cut
	154
18360aed	155	sub get_autoinc_seq {
	156	my ($self, $source, $col) = @_;
	157
373940e1	158	$self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
18360aed	159	}
18360aed	160
7137528d	161	=head2 columns_info_for
	162
	163	This wraps the superclass version of this method to force table
	164	names to uppercase
	165
	166	=cut
	167
18360aed	168	sub columns_info_for {
	169	my ($self, $table) = @_;
	170
	171	$self->next::method(uc($table));
	172	}
	173
8f7e044c	174	=head2 datetime_parser_type
	175
	176	This sets the proper DateTime::Format module for use with
	177	L<DBIx::Class::InflateColumn::DateTime>.
	178
	179	=cut
	180
	181	sub datetime_parser_type { return "DateTime::Format::Oracle"; }
	182
9900b569	183	=head2 connect_call_datetime_setup
d2a3958e	184
	185	Used as:
	186
9900b569	187	on_connect_call => 'datetime_setup'
d2a3958e	188
82f6f45f	189	In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
	190	timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
	191	necessary environment variables for L<DateTime::Format::Oracle>, which is used
	192	by it.
d2a3958e	193
82f6f45f	194	Maximum allowable precision is used, unless the environment variables have
82f6f45f	195	already been set.
d2a3958e	196
9900b569	197	These are the defaults used:
	198
	199	$ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	200	$ENV{NLS_TIMESTAMP_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF';
	201	$ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	202
d9e53b85	203	To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
	204	for your timestamps, use something like this:
	205
	206	use Time::HiRes 'time';
	207	my $ts = DateTime->from_epoch(epoch => time);
	208
d2a3958e	209	=cut
d2a3958e	210
9900b569	211	sub connect_call_datetime_setup {
d2a3958e	212	my $self = shift;
	213	my $dbh = $self->dbh;
	214
	215	my $date_format = $ENV{NLS_DATE_FORMAT} \|\|= 'YYYY-MM-DD HH24:MI:SS';
	216	my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} \|\|=
	217	'YYYY-MM-DD HH24:MI:SS.FF';
	218	my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} \|\|=
	219	'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
	220
	221	$dbh->do("alter session set nls_date_format = '$date_format'");
	222	$dbh->do("alter session set nls_timestamp_format = '$timestamp_format'");
d9e53b85	223	$dbh->do("alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
d2a3958e	224	}
d2a3958e	225
281719d2	226	sub _svp_begin {
	227	my ($self, $name) = @_;
	228
	229	$self->dbh->do("SAVEPOINT $name");
	230	}
	231
5db2758d	232	=head2 source_bind_attributes
	233
	234	Handle LOB types in Oracle. Under a certain size (4k?), you can get away
	235	with the driver assuming your input is the deprecated LONG type if you
	236	encode it as a hex string. That ain't gonna fly at larger values, where
	237	you'll discover you have to do what this does.
	238
	239	This method had to be overridden because we need to set ora_field to the
	240	actual column, and that isn't passed to the call (provided by Storage) to
	241	bind_attribute_by_data_type.
	242
	243	According to L<DBD::Oracle>, the ora_field isn't always necessary, but
	244	adding it doesn't hurt, and will save your bacon if you're modifying a
	245	table with more than one LOB column.
	246
	247	=cut
	248
	249	sub source_bind_attributes
	250	{
	251	my $self = shift;
	252	my($source) = @_;
	253
	254	my %bind_attributes;
	255
	256	foreach my $column ($source->columns) {
	257	my $data_type = $source->column_info($column)->{data_type} \|\| '';
	258	next unless $data_type;
	259
	260	my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
	261
	262	if ($data_type =~ /^[BC]LOB$/i) {
	263	$column_bind_attrs{'ora_type'}
	264	= uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
	265	$column_bind_attrs{'ora_field'} = $column;
	266	}
	267
	268	$bind_attributes{$column} = \%column_bind_attrs;
	269	}
	270
	271	return \%bind_attributes;
	272	}
	273
281719d2	274	# Oracle automatically releases a savepoint when you start another one with the
	275	# same name.
	276	sub _svp_release { 1 }
	277
	278	sub _svp_rollback {
	279	my ($self, $name) = @_;
	280
	281	$self->dbh->do("ROLLBACK TO SAVEPOINT $name")
	282	}
	283
18360aed	284	=head1 AUTHORS
	285
	286	Andy Grundman <andy@hybridized.org>
	287
	288	Scott Connelly <scottsweep@yahoo.com>
	289
	290	=head1 LICENSE
	291
	292	You may distribute this code under the same terms as Perl itself.
	293
	294	=cut
7137528d	295
7137528d	296	1;