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) = @_;
129 my $wantarray = wantarray();
130 my $next = $self->next::can;
133 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
135 if (!defined $wantarray) {
138 elsif (! $wantarray) {
148 if (! $tried and $_ =~ /ORA-01003/) {
149 # ORA-01003: no statement parsed (someone changed the table somehow,
150 # invalidating your cursor.)
151 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
152 delete $dbh->{CachedKids}{$sql};
155 $self->throw_exception($_);
158 } while (! $tried++);
160 return $wantarray ? @res : $res[0];
163 =head2 get_autoinc_seq
165 Returns the sequence name for an autoincrement column
169 sub get_autoinc_seq {
170 my ($self, $source, $col) = @_;
172 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
175 =head2 datetime_parser_type
177 This sets the proper DateTime::Format module for use with
178 L<DBIx::Class::InflateColumn::DateTime>.
182 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
184 =head2 connect_call_datetime_setup
188 on_connect_call => 'datetime_setup'
190 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
191 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
192 and the necessary environment variables for L<DateTime::Format::Oracle>, which
195 Maximum allowable precision is used, unless the environment variables have
198 These are the defaults used:
200 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
201 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
202 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
204 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
205 for your timestamps, use something like this:
207 use Time::HiRes 'time';
208 my $ts = DateTime->from_epoch(epoch => time);
212 sub connect_call_datetime_setup {
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';
222 "alter session set nls_date_format = '$date_format'"
225 "alter session set nls_timestamp_format = '$timestamp_format'"
228 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
232 =head2 source_bind_attributes
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.
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.
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.
249 sub source_bind_attributes
257 foreach my $column ($source->columns) {
258 my $data_type = $source->column_info($column)->{data_type} || '';
259 next unless $data_type;
261 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
263 if ($data_type =~ /^[BC]LOB$/i) {
264 if ($DBD::Oracle::VERSION eq '1.23') {
265 $self->throw_exception(
266 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
267 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
271 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
272 ? DBD::Oracle::ORA_CLOB()
273 : DBD::Oracle::ORA_BLOB()
275 $column_bind_attrs{'ora_field'} = $column;
278 $bind_attributes{$column} = \%column_bind_attrs;
281 return \%bind_attributes;
285 my ($self, $name) = @_;
286 $self->_get_dbh->do("SAVEPOINT $name");
289 # Oracle automatically releases a savepoint when you start another one with the
291 sub _svp_release { 1 }
294 my ($self, $name) = @_;
295 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
298 =head2 relname_to_table_alias
300 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
303 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
304 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
307 See L<DBIx::Class::Storage/"relname_to_table_alias">.
311 sub relname_to_table_alias {
313 my ($relname, $join_count) = @_;
315 my $alias = $self->next::method(@_);
317 return $alias if length($alias) <= 30;
319 # get a base64 md5 of the alias with join_count
321 my $ctx = Digest::MD5->new;
323 my $md5 = $ctx->b64digest;
325 # remove alignment mark just in case
328 # truncate and prepend to truncated relname without vowels
329 (my $devoweled = $relname) =~ s/[aeiou]//g;
330 my $shortened = substr($devoweled, 0, 18);
333 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
338 =head2 with_deferred_fk_checks
340 Runs a coderef between:
342 alter session set constraints = deferred
344 alter session set constraints = immediate
346 to defer foreign key checks.
348 Constraints must be declared C<DEFERRABLE> for this to work.
352 sub with_deferred_fk_checks {
353 my ($self, $sub) = @_;
355 my $txn_scope_guard = $self->txn_scope_guard;
357 $self->_do_query('alter session set constraints = deferred');
359 my $sg = Scope::Guard->new(sub {
360 $self->_do_query('alter session set constraints = immediate');
363 return Context::Preserve::preserve_context(sub { $sub->() },
364 after => sub { $txn_scope_guard->commit });
369 See L<DBIx::Class/CONTRIBUTORS>.
373 You may distribute this code under the same terms as Perl itself.