1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve ();
11 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
15 # In your result (table) classes
16 use base 'DBIx::Class::Core';
17 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
18 __PACKAGE__->set_primary_key('id');
19 __PACKAGE__->sequence('mysequence');
23 This class implements base Oracle support. The subclass
24 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
31 use base qw/DBIx::Class::Storage::DBI/;
34 sub deployment_statements {
36 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
39 my $quote_char = $self->schema->storage->sql_maker->quote_char;
40 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
41 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
43 my $oracle_version = try { $self->_get_dbh->get_info(18) };
45 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
47 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
50 sub _dbh_last_insert_id {
51 my ($self, $dbh, $source, @columns) = @_;
53 foreach my $col (@columns) {
54 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
55 my $id = $self->_sequence_fetch( 'currval', $seq );
61 sub _dbh_get_autoinc_seq {
62 my ($self, $dbh, $source, $col) = @_;
64 my $sql_maker = $self->sql_maker;
67 if ( ref $source->name eq 'SCALAR' ) {
68 $source_name = ${$source->name};
71 $source_name = $source->name;
73 $source_name = uc($source_name) unless $sql_maker->quote_char;
75 # trigger_body is a LONG
76 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
78 # disable default bindtype
79 local $sql_maker->{bindtype} = 'normal';
81 # look up the correct sequence automatically
82 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
83 my ($sql, @bind) = $sql_maker->select (
87 $schema ? (owner => $schema) : (),
88 table_name => $table || $source_name,
89 triggering_event => { -like => '%INSERT%' },
93 my $sth = $dbh->prepare($sql);
94 $sth->execute (@bind);
96 while (my ($insert_trigger) = $sth->fetchrow_array) {
97 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
99 $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
102 sub _sequence_fetch {
103 my ( $self, $type, $seq ) = @_;
104 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
111 my $dbh = $self->_dbh or return 0;
113 local $dbh->{RaiseError} = 1;
114 local $dbh->{PrintError} = 0;
117 $dbh->do('select 1 from dual');
126 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
131 return $self->next::method($dbh, $op, $extra_bind, $ident, $bind_attributes, @args);
134 if (!$retried and $_ =~ /ORA-01003/) {
135 # ORA-01003: no statement parsed (someone changed the table somehow,
136 # invalidating your cursor.)
137 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
138 delete $dbh->{CachedKids}{$sql};
141 $self->throw_exception($_);
144 } while (not $retried++);
147 =head2 get_autoinc_seq
149 Returns the sequence name for an autoincrement column
153 sub get_autoinc_seq {
154 my ($self, $source, $col) = @_;
156 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
159 =head2 columns_info_for
161 This wraps the superclass version of this method to force table
166 sub columns_info_for {
167 my ($self, $table) = @_;
169 $self->next::method($table);
172 =head2 datetime_parser_type
174 This sets the proper DateTime::Format module for use with
175 L<DBIx::Class::InflateColumn::DateTime>.
179 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
181 =head2 connect_call_datetime_setup
185 on_connect_call => 'datetime_setup'
187 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
188 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
189 and the necessary environment variables for L<DateTime::Format::Oracle>, which
192 Maximum allowable precision is used, unless the environment variables have
195 These are the defaults used:
197 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
198 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
199 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
201 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
202 for your timestamps, use something like this:
204 use Time::HiRes 'time';
205 my $ts = DateTime->from_epoch(epoch => time);
209 sub connect_call_datetime_setup {
212 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
213 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
214 'YYYY-MM-DD HH24:MI:SS.FF';
215 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
216 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
219 "alter session set nls_date_format = '$date_format'"
222 "alter session set nls_timestamp_format = '$timestamp_format'"
225 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
229 =head2 source_bind_attributes
231 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
232 with the driver assuming your input is the deprecated LONG type if you
233 encode it as a hex string. That ain't gonna fly at larger values, where
234 you'll discover you have to do what this does.
236 This method had to be overridden because we need to set ora_field to the
237 actual column, and that isn't passed to the call (provided by Storage) to
238 bind_attribute_by_data_type.
240 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
241 adding it doesn't hurt, and will save your bacon if you're modifying a
242 table with more than one LOB column.
246 sub source_bind_attributes
254 foreach my $column ($source->columns) {
255 my $data_type = $source->column_info($column)->{data_type} || '';
256 next unless $data_type;
258 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
260 if ($data_type =~ /^[BC]LOB$/i) {
261 if ($DBD::Oracle::VERSION eq '1.23') {
262 $self->throw_exception(
263 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
264 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
268 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
269 ? DBD::Oracle::ORA_CLOB()
270 : DBD::Oracle::ORA_BLOB()
272 $column_bind_attrs{'ora_field'} = $column;
275 $bind_attributes{$column} = \%column_bind_attrs;
278 return \%bind_attributes;
282 my ($self, $name) = @_;
283 $self->_get_dbh->do("SAVEPOINT $name");
286 # Oracle automatically releases a savepoint when you start another one with the
288 sub _svp_release { 1 }
291 my ($self, $name) = @_;
292 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
295 =head2 relname_to_table_alias
297 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
300 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
301 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
304 See L<DBIx::Class::Storage/"relname_to_table_alias">.
308 sub relname_to_table_alias {
310 my ($relname, $join_count) = @_;
312 my $alias = $self->next::method(@_);
314 return $alias if length($alias) <= 30;
316 # get a base64 md5 of the alias with join_count
318 my $ctx = Digest::MD5->new;
320 my $md5 = $ctx->b64digest;
322 # remove alignment mark just in case
325 # truncate and prepend to truncated relname without vowels
326 (my $devoweled = $relname) =~ s/[aeiou]//g;
327 my $shortened = substr($devoweled, 0, 18);
330 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
335 =head2 with_deferred_fk_checks
337 Runs a coderef between:
339 alter session set constraints = deferred
341 alter session set constraints = immediate
343 to defer foreign key checks.
345 Constraints must be declared C<DEFERRABLE> for this to work.
349 sub with_deferred_fk_checks {
350 my ($self, $sub) = @_;
352 my $txn_scope_guard = $self->txn_scope_guard;
354 $self->_do_query('alter session set constraints = deferred');
356 my $sg = Scope::Guard->new(sub {
357 $self->_do_query('alter session set constraints = immediate');
360 return Context::Preserve::preserve_context(sub { $sub->() },
361 after => sub { $txn_scope_guard->commit });
366 See L<DBIx::Class/CONTRIBUTORS>.
370 You may distribute this code under the same terms as Perl itself.