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 deployment_statements {
35 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
38 my $quote_char = $self->schema->storage->sql_maker->quote_char;
39 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
40 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
42 my $oracle_version = eval { $self->_get_dbh->get_info(18) };
44 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
46 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
49 sub _dbh_last_insert_id {
50 my ($self, $dbh, $source, @columns) = @_;
52 foreach my $col (@columns) {
53 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
54 my $id = $self->_sequence_fetch( 'currval', $seq );
60 sub _dbh_get_autoinc_seq {
61 my ($self, $dbh, $source, $col) = @_;
63 my $sql_maker = $self->sql_maker;
66 if ( ref $source->name eq 'SCALAR' ) {
67 $source_name = ${$source->name};
70 $source_name = $source->name;
72 $source_name = uc($source_name) unless $sql_maker->quote_char;
74 # trigger_body is a LONG
75 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
77 # disable default bindtype
78 local $sql_maker->{bindtype} = 'normal';
80 # look up the correct sequence automatically
81 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
82 my ($sql, @bind) = $sql_maker->select (
86 $schema ? (owner => $schema) : (),
87 table_name => $table || $source_name,
88 triggering_event => 'INSERT',
92 my $sth = $dbh->prepare($sql);
93 $sth->execute (@bind);
95 while (my ($insert_trigger) = $sth->fetchrow_array) {
96 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
98 $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
101 sub _sequence_fetch {
102 my ( $self, $type, $seq ) = @_;
103 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
110 my $dbh = $self->_dbh or return 0;
112 local $dbh->{RaiseError} = 1;
113 local $dbh->{PrintError} = 0;
116 $dbh->do('select 1 from dual');
124 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
126 my $wantarray = wantarray;
128 my (@res, $exception, $retried);
134 @res = $self->next::method(@_);
136 $res[0] = $self->next::method(@_);
140 if ($exception =~ /ORA-01003/) {
141 # ORA-01003: no statement parsed (someone changed the table somehow,
142 # invalidating your cursor.)
143 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
144 delete $dbh->{CachedKids}{$sql};
148 } while (not $retried++);
151 $self->throw_exception($exception) if $exception;
153 $wantarray ? @res : $res[0]
156 =head2 get_autoinc_seq
158 Returns the sequence name for an autoincrement column
162 sub get_autoinc_seq {
163 my ($self, $source, $col) = @_;
165 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
168 =head2 columns_info_for
170 This wraps the superclass version of this method to force table
175 sub columns_info_for {
176 my ($self, $table) = @_;
178 $self->next::method($table);
181 =head2 datetime_parser_type
183 This sets the proper DateTime::Format module for use with
184 L<DBIx::Class::InflateColumn::DateTime>.
188 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
190 =head2 connect_call_datetime_setup
194 on_connect_call => 'datetime_setup'
196 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
197 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
198 and the necessary environment variables for L<DateTime::Format::Oracle>, which
201 Maximum allowable precision is used, unless the environment variables have
204 These are the defaults used:
206 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
207 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
208 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
210 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
211 for your timestamps, use something like this:
213 use Time::HiRes 'time';
214 my $ts = DateTime->from_epoch(epoch => time);
218 sub connect_call_datetime_setup {
221 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
222 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
223 'YYYY-MM-DD HH24:MI:SS.FF';
224 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
225 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
228 "alter session set nls_date_format = '$date_format'"
231 "alter session set nls_timestamp_format = '$timestamp_format'"
234 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
238 =head2 source_bind_attributes
240 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
241 with the driver assuming your input is the deprecated LONG type if you
242 encode it as a hex string. That ain't gonna fly at larger values, where
243 you'll discover you have to do what this does.
245 This method had to be overridden because we need to set ora_field to the
246 actual column, and that isn't passed to the call (provided by Storage) to
247 bind_attribute_by_data_type.
249 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
250 adding it doesn't hurt, and will save your bacon if you're modifying a
251 table with more than one LOB column.
255 sub source_bind_attributes
263 foreach my $column ($source->columns) {
264 my $data_type = $source->column_info($column)->{data_type} || '';
265 next unless $data_type;
267 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
269 if ($data_type =~ /^[BC]LOB$/i) {
270 if ($DBD::Oracle::VERSION eq '1.23') {
271 $self->throw_exception(
272 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
273 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
277 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
278 ? DBD::Oracle::ORA_CLOB()
279 : DBD::Oracle::ORA_BLOB()
281 $column_bind_attrs{'ora_field'} = $column;
284 $bind_attributes{$column} = \%column_bind_attrs;
287 return \%bind_attributes;
291 my ($self, $name) = @_;
292 $self->_get_dbh->do("SAVEPOINT $name");
295 # Oracle automatically releases a savepoint when you start another one with the
297 sub _svp_release { 1 }
300 my ($self, $name) = @_;
301 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
304 =head2 relname_to_table_alias
306 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
309 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
310 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
313 See L<DBIx::Class::Storage/"relname_to_table_alias">.
317 sub relname_to_table_alias {
319 my ($relname, $join_count) = @_;
321 my $alias = $self->next::method(@_);
323 return $alias if length($alias) <= 30;
325 # get a base64 md5 of the alias with join_count
327 my $ctx = Digest::MD5->new;
329 my $md5 = $ctx->b64digest;
331 # remove alignment mark just in case
334 # truncate and prepend to truncated relname without vowels
335 (my $devoweled = $relname) =~ s/[aeiou]//g;
336 my $shortened = substr($devoweled, 0, 18);
339 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
344 =head2 with_deferred_fk_checks
346 Runs a coderef between:
348 alter session set constraints = deferred
350 alter session set constraints = immediate
352 to defer foreign key checks.
354 Constraints must be declared C<DEFERRABLE> for this to work.
358 sub with_deferred_fk_checks {
359 my ($self, $sub) = @_;
361 my $txn_scope_guard = $self->txn_scope_guard;
363 $self->_do_query('alter session set constraints = deferred');
365 my $sg = Scope::Guard->new(sub {
366 $self->_do_query('alter session set constraints = immediate');
369 return Context::Preserve::preserve_context(sub { $sub->() },
370 after => sub { $txn_scope_guard->commit });
375 See L<DBIx::Class/CONTRIBUTORS>.
379 You may distribute this code under the same terms as Perl itself.