1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve ();
10 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
14 # In your result (table) classes
15 use base 'DBIx::Class::Core';
16 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
17 __PACKAGE__->set_primary_key('id');
18 __PACKAGE__->sequence('mysequence');
22 This class implements base Oracle support. The subclass
23 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
30 use base qw/DBIx::Class::Storage::DBI/;
33 sub _dbh_last_insert_id {
34 my ($self, $dbh, $source, @columns) = @_;
36 foreach my $col (@columns) {
37 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
38 my $id = $self->_sequence_fetch( 'currval', $seq );
44 sub _dbh_get_autoinc_seq {
45 my ($self, $dbh, $source, $col) = @_;
47 # look up the correct sequence automatically
49 SELECT trigger_body FROM ALL_TRIGGERS t
50 WHERE t.table_name = ?
51 AND t.triggering_event = 'INSERT'
52 AND t.status = 'ENABLED'
55 # trigger_body is a LONG
56 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
61 if ( ref $source->name ne 'SCALAR' ) {
62 $source_name = $source->name;
65 $source_name = ${$source->name};
68 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
69 if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
71 SELECT trigger_body FROM ALL_TRIGGERS t
72 WHERE t.owner = ? AND t.table_name = ?
73 AND t.triggering_event = 'INSERT'
74 AND t.status = 'ENABLED'
76 $sth = $dbh->prepare($sql);
77 $sth->execute( uc($schema), uc($table) );
80 $sth = $dbh->prepare($sql);
81 $sth->execute( uc( $source_name ) );
83 while (my ($insert_trigger) = $sth->fetchrow_array) {
84 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
86 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
90 my ( $self, $type, $seq ) = @_;
91 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
98 my $dbh = $self->_dbh or return 0;
100 local $dbh->{RaiseError} = 1;
103 $dbh->do("select 1 from dual");
111 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
113 my $wantarray = wantarray;
115 my (@res, $exception, $retried);
121 @res = $self->next::method(@_);
123 $res[0] = $self->next::method(@_);
127 if ($exception =~ /ORA-01003/) {
128 # ORA-01003: no statement parsed (someone changed the table somehow,
129 # invalidating your cursor.)
130 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
131 delete $dbh->{CachedKids}{$sql};
135 } while (not $retried++);
138 $self->throw_exception($exception) if $exception;
140 wantarray ? @res : $res[0]
143 =head2 get_autoinc_seq
145 Returns the sequence name for an autoincrement column
149 sub get_autoinc_seq {
150 my ($self, $source, $col) = @_;
152 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
155 =head2 columns_info_for
157 This wraps the superclass version of this method to force table
162 sub columns_info_for {
163 my ($self, $table) = @_;
165 $self->next::method(uc($table));
168 =head2 datetime_parser_type
170 This sets the proper DateTime::Format module for use with
171 L<DBIx::Class::InflateColumn::DateTime>.
175 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
177 =head2 connect_call_datetime_setup
181 on_connect_call => 'datetime_setup'
183 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
184 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
185 necessary environment variables for L<DateTime::Format::Oracle>, which is used
188 Maximum allowable precision is used, unless the environment variables have
191 These are the defaults used:
193 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
194 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
195 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
197 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
198 for your timestamps, use something like this:
200 use Time::HiRes 'time';
201 my $ts = DateTime->from_epoch(epoch => time);
205 sub connect_call_datetime_setup {
208 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
209 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
210 'YYYY-MM-DD HH24:MI:SS.FF';
211 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
212 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
215 "alter session set nls_date_format = '$date_format'"
218 "alter session set nls_timestamp_format = '$timestamp_format'"
221 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
225 =head2 source_bind_attributes
227 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
228 with the driver assuming your input is the deprecated LONG type if you
229 encode it as a hex string. That ain't gonna fly at larger values, where
230 you'll discover you have to do what this does.
232 This method had to be overridden because we need to set ora_field to the
233 actual column, and that isn't passed to the call (provided by Storage) to
234 bind_attribute_by_data_type.
236 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
237 adding it doesn't hurt, and will save your bacon if you're modifying a
238 table with more than one LOB column.
242 sub source_bind_attributes
250 foreach my $column ($source->columns) {
251 my $data_type = $source->column_info($column)->{data_type} || '';
252 next unless $data_type;
254 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
256 if ($data_type =~ /^[BC]LOB$/i) {
257 if ($DBD::Oracle::VERSION eq '1.23') {
258 $self->throw_exception(
259 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
260 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
264 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
265 ? DBD::Oracle::ORA_CLOB()
266 : DBD::Oracle::ORA_BLOB()
268 $column_bind_attrs{'ora_field'} = $column;
271 $bind_attributes{$column} = \%column_bind_attrs;
274 return \%bind_attributes;
278 my ($self, $name) = @_;
279 $self->_get_dbh->do("SAVEPOINT $name");
282 # Oracle automatically releases a savepoint when you start another one with the
284 sub _svp_release { 1 }
287 my ($self, $name) = @_;
288 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
291 =head2 relname_to_table_alias
293 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
296 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
297 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
300 See L<DBIx::Class::Storage/"relname_to_table_alias">.
304 sub relname_to_table_alias {
306 my ($relname, $join_count) = @_;
308 my $alias = $self->next::method(@_);
310 return $alias if length($alias) <= 30;
312 # get a base64 md5 of the alias with join_count
314 my $ctx = Digest::MD5->new;
316 my $md5 = $ctx->b64digest;
318 # remove alignment mark just in case
321 # truncate and prepend to truncated relname without vowels
322 (my $devoweled = $relname) =~ s/[aeiou]//g;
323 my $shortened = substr($devoweled, 0, 18);
326 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
331 =head2 with_deferred_fk_checks
333 Runs a coderef between:
335 alter session set constraints = deferred
337 alter session set constraints = immediate
339 to defer foreign key checks.
341 Constraints must be declared C<DEFERRABLE> for this to work.
345 sub with_deferred_fk_checks {
346 my ($self, $sub) = @_;
348 my $txn_scope_guard = $self->txn_scope_guard;
350 $self->_do_query('alter session set constraints = deferred');
352 my $sg = Scope::Guard->new(sub {
353 $self->_do_query('alter session set constraints = immediate');
356 return Context::Preserve::preserve_context(sub { $sub->() },
357 after => sub { $txn_scope_guard->commit });
362 See L<DBIx::Class/CONTRIBUTORS>.
366 You may distribute this code under the same terms as Perl itself.