1 package DBIx::Class::Storage::DBI::Oracle::Generic;
5 use base qw/DBIx::Class::Storage::DBI/;
9 use Context::Preserve 'preserve_context';
10 use DBIx::Class::_Util qw( modver_gt_or_eq modver_gt_or_eq_and_lt dbic_internal_try );
13 __PACKAGE__->sql_limit_dialect ('RowNum');
14 __PACKAGE__->sql_quote_char ('"');
15 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
16 __PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
18 sub __cache_queries_with_max_lob_parts { 2 }
22 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
26 # In your result (table) classes
27 use base 'DBIx::Class::Core';
28 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
29 __PACKAGE__->set_primary_key('id');
31 # Somewhere in your Code
32 # add some data to a table with a hierarchical relationship
33 $schema->resultset('Person')->create ({
38 firstname => 'child1',
42 firstname => 'grandchild',
48 firstname => 'child2',
54 # select from the hierarchical relationship
55 my $rs = $schema->resultset('Person')->search({},
57 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
58 'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
59 'order_siblings_by' => { -asc => 'name' },
63 # this will select the whole tree starting from person "foo bar", creating
66 # me.persionid me.firstname, me.lastname, me.parentid
70 # firstname = 'foo' and lastname = 'bar'
72 # parentid = prior personid
78 This class implements base Oracle support. The subclass
79 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
86 sub _determine_supports_insert_returning {
89 # TODO find out which version supports the RETURNING syntax
90 # 8i has it and earlier docs are a 404 on oracle.com
93 if $self->_server_info->{normalized_dbms_version} >= 8.001;
98 __PACKAGE__->_use_insert_returning_bound (1);
100 sub deployment_statements {
102 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
107 ! exists $sqltargs->{producer_args}{oracle_version}
109 my $dver = $self->_server_info->{dbms_version}
111 $sqltargs->{producer_args}{oracle_version} = $dver;
114 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
117 sub _dbh_last_insert_id {
118 my ($self, $dbh, $source, @columns) = @_;
120 my $ci = $source->columns_info(\@columns);
121 foreach my $col (@columns) {
122 my $seq = ( $ci->{$col}{sequence} ||= $self->get_autoinc_seq($source,$col));
123 my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
129 sub _dbh_get_autoinc_seq {
130 my ($self, $dbh, $source, $col) = @_;
132 my $sql_maker = $self->sql_maker;
133 my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
136 if ( ref $source->name eq 'SCALAR' ) {
137 $source_name = ${$source->name};
139 # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
140 # stuff unless it is already quoted
141 $source_name = uc ($source_name) if $source_name !~ /\"/;
144 $source_name = $source->name;
145 $source_name = uc($source_name) unless $ql;
148 # trigger_body is a LONG
149 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
151 # disable default bindtype
152 local $sql_maker->{bindtype} = 'normal';
154 # look up the correct sequence automatically
155 my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
157 # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
158 $schema ||= \'= USER';
160 my ($sql, @bind) = $sql_maker->select (
162 [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
165 TABLE_NAME => $table || $source_name,
166 TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
167 TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
172 # to find all the triggers that mention the column in question a simple
173 # regex grep since the trigger_body above is a LONG and hence not searchable
176 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
178 { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
179 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
183 # extract all sequence names mentioned in each trigger, throw away
184 # triggers without apparent sequences
186 my @seqs = $_->{body} =~ / ( [\.\w\"\-]+ ) \. nextval /xig;
188 ? { %$_, sequences => \@seqs }
195 # if only one trigger matched things are easy
196 if (@triggers == 1) {
198 if ( @{$triggers[0]{sequences}} == 1 ) {
199 $chosen_trigger = $triggers[0];
202 $self->throw_exception( sprintf (
203 "Unable to introspect trigger '%s' for column '%s.%s' (references multiple sequences). "
204 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
212 # got more than one matching trigger - see if we can narrow it down
213 elsif (@triggers > 1) {
215 my @candidates = grep
216 { $_->{body} =~ / into \s+ \:new\.$col /xi }
220 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
221 $chosen_trigger = $candidates[0];
224 $self->throw_exception( sprintf (
225 "Unable to reliably select a BEFORE INSERT trigger for column '%s.%s' (possibilities: %s). "
226 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
229 ( join ', ', map { "'$_->{name}'" } @triggers ),
235 if ($chosen_trigger) {
236 my $seq_name = $chosen_trigger->{sequences}[0];
238 $seq_name = "$chosen_trigger->{schema}.$seq_name"
239 unless $seq_name =~ /\./;
241 return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
245 $self->throw_exception( sprintf (
246 "No suitable BEFORE INSERT triggers found for column '%s.%s'. "
247 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
254 sub _sequence_fetch {
255 my ( $self, $type, $seq ) = @_;
257 # use the maker to leverage quoting settings
258 my $sth = $self->_dbh->prepare_cached(
259 $self->sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] )
262 my ($id) = $sth->fetchrow_array;
270 my $dbh = $self->_dbh or return 0;
272 local $dbh->{RaiseError} = 1;
273 local $dbh->{PrintError} = 0;
275 ( dbic_internal_try {
276 $dbh->do('select 1 from dual');
285 #my ($self, $dbh, $sql, $bind, $bind_attrs) = @_;
286 my ($self, $sql, $bind) = @_[0,2,3];
288 # Turn off sth caching for multi-part LOBs. See _prep_for_execute below
289 local $self->{disable_sth_caching} = 1 if grep {
290 ($_->[0]{_ora_lob_autosplit_part}||0)
292 (__cache_queries_with_max_lob_parts - 1)
295 my $next = $self->next::can;
297 # if we are already in a txn we can't retry anything
298 return shift->$next(@_)
299 if $self->transaction_depth;
301 # Cheat the blockrunner we are just about to create:
302 # We *do* want to rerun things regardless of outer state
303 local $self->{_in_do_block}
304 if $self->{_in_do_block};
306 DBIx::Class::Storage::BlockRunner->new(
309 retry_handler => sub {
310 # ORA-01003: no statement parsed (someone changed the table somehow,
311 # invalidating your cursor.)
313 $_[0]->failed_attempt_count == 1
315 $_[0]->last_exception =~ /ORA-01003/
317 my $dbh = $_[0]->storage->_dbh
319 delete $dbh->{CachedKids}{$sql};
329 sub _dbh_execute_for_fetch {
330 #my ($self, $source, $sth, $proto_bind, $cols, $data) = @_;
332 # Older DBD::Oracle warns loudly on partial execute_for_fetch failures
333 # before https://metacpan.org/source/PYTHIAN/DBD-Oracle-1.28/Changes#L7-9
334 local $_[2]->{PrintWarn} = 0
335 unless modver_gt_or_eq( 'DBD::Oracle', '1.28' );
337 shift->next::method(@_);
340 =head2 get_autoinc_seq
342 Returns the sequence name for an autoincrement column
346 sub get_autoinc_seq {
347 my ($self, $source, $col) = @_;
349 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
352 =head2 datetime_parser_type
354 This sets the proper DateTime::Format module for use with
355 L<DBIx::Class::InflateColumn::DateTime>.
357 =head2 connect_call_datetime_setup
361 on_connect_call => 'datetime_setup'
363 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
364 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
365 and the necessary environment variables for L<DateTime::Format::Oracle>, which
368 Maximum allowable precision is used, unless the environment variables have
371 These are the defaults used:
373 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
374 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
375 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
377 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
378 for your timestamps, use something like this:
380 use Time::HiRes 'time';
381 my $ts = DateTime->from_epoch(epoch => time);
385 sub connect_call_datetime_setup {
388 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
389 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
390 'YYYY-MM-DD HH24:MI:SS.FF';
391 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
392 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
395 "alter session set nls_date_format = '$date_format'"
398 "alter session set nls_timestamp_format = '$timestamp_format'"
401 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
405 ### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
406 ### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
408 # Handle LOB types in Oracle. Under a certain size (4k?), you can get away
409 # with the driver assuming your input is the deprecated LONG type if you
410 # encode it as a hex string. That ain't gonna fly at larger values, where
411 # you'll discover you have to do what this does.
413 # This method had to be overridden because we need to set ora_field to the
414 # actual column, and that isn't passed to the call (provided by Storage) to
415 # bind_attribute_by_data_type.
417 # According to L<DBD::Oracle>, the ora_field isn't always necessary, but
418 # adding it doesn't hurt, and will save your bacon if you're modifying a
419 # table with more than one LOB column.
421 sub _dbi_attrs_for_bind {
422 my ($self, $ident, $bind) = @_;
424 my $attrs = $self->next::method($ident, $bind);
426 # Push the column name into all bind attrs, make sure to *NOT* write into
427 # the existing $attrs->[$idx]{..} hashref, as it is cached by the call to
428 # next::method above.
429 # FIXME - this code will go away when the LobWriter refactor lands
432 keys %{ $attrs->[$_] }
434 $bind->[$_][0]{dbic_colname}
436 $attrs->[$_] = { %{$attrs->[$_]}, ora_field => $bind->[$_][0]{dbic_colname} }
442 sub bind_attribute_by_data_type {
443 my ($self, $dt) = @_;
445 if ($self->_is_lob_type($dt)) {
447 # no earlier - no later
448 $self->throw_exception(
449 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later "
450 . "version (https://rt.cpan.org/Public/Bug/Display.html?id=46016)"
451 ) if modver_gt_or_eq_and_lt( 'DBD::Oracle', '1.23', '1.24' );
454 ora_type => $self->_is_text_lob_type($dt)
455 ? DBD::Oracle::ORA_CLOB()
456 : DBD::Oracle::ORA_BLOB()
464 # Handle blob columns in WHERE.
466 # For equality comparisons:
468 # We split data intended for comparing to a LOB into 2000 character chunks and
469 # compare them using dbms_lob.substr on the LOB column.
471 # We turn off DBD::Oracle LOB binds for these partial LOB comparisons by passing
472 # dbd_attrs => undef, because these are regular varchar2 comparisons and
473 # otherwise the query will fail.
475 # Since the most common comparison size is likely to be under 4000 characters
476 # (TEXT comparisons previously deployed to other RDBMSes) we disable
477 # prepare_cached for queries with more than two part comparisons to a LOB
478 # column. This is done in _dbh_execute (above) which was previously overridden
479 # to gracefully recover from an Oracle error. This is to be careful to not
480 # exhaust your application's open cursor limit.
483 # http://itcareershift.com/blog1/2011/02/21/oracle-max-number-of-open-cursors-complete-reference-for-the-new-oracle-dba/
484 # on the open_cursor limit.
486 # For everything else:
488 # We assume that everything that is not a LOB comparison, will most likely be a
489 # LIKE query or some sort of function invocation. This may prove to be a naive
490 # assumption in the future, but for now it should cover the two most likely
491 # things users would want to do with a BLOB or CLOB, an equality test or a LIKE
494 # For these expressions, the bind must NOT have the attributes of a LOB bind for
495 # DBD::Oracle, otherwise the query will fail. This is done by passing
496 # dbd_attrs => undef.
498 sub _prep_for_execute {
502 return $self->next::method(@_)
505 my ($sql, $bind) = $self->next::method(@_);
507 my $lob_bind_indices = { map {
509 $bind->[$_][0]{sqlt_datatype}
511 $self->_is_lob_type($bind->[$_][0]{sqlt_datatype})
513 } ( 0 .. $#$bind ) };
515 return ($sql, $bind) unless %$lob_bind_indices;
517 my ($final_sql, @final_binds);
518 if ($op eq 'update') {
519 $self->throw_exception('Update with complex WHERE clauses involving BLOB columns currently not supported')
520 if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs;
523 ($final_sql, $where_sql) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
525 if (my $set_bind_count = $final_sql =~ y/?//) {
527 delete $lob_bind_indices->{$_} for (0 .. ($set_bind_count - 1));
529 # bail if only the update part contains blobs
530 return ($sql, $bind) unless %$lob_bind_indices;
532 @final_binds = splice @$bind, 0, $set_bind_count;
533 $lob_bind_indices = { map
534 { $_ - $set_bind_count => $lob_bind_indices->{$_} }
535 keys %$lob_bind_indices
539 # if we got that far - assume the where SQL is all we got
540 # (the first part is already shoved into $final_sql)
543 elsif ($op ne 'select' and $op ne 'delete') {
544 $self->throw_exception("Unsupported \$op: $op");
547 my @sql_parts = split /\?/, $sql;
549 my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x;
551 for my $b_idx (0 .. $#$bind) {
552 my $bound = $bind->[$b_idx];
555 $lob_bind_indices->{$b_idx}
557 my ($col, $eq) = $sql_parts[0] =~ $col_equality_re
559 my $data = $bound->[1];
561 $data = "$data" if ref $data;
563 my @parts = unpack '(a2000)*', $data;
567 for my $idx (0..$#parts) {
568 push @sql_frag, sprintf (
569 'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
570 $col, ($idx*2000 + 1),
574 my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
576 $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
578 $final_sql .= shift @sql_parts;
580 for my $idx (0..$#parts) {
584 _ora_lob_autosplit_part => $idx,
592 $final_sql .= shift(@sql_parts) . '?';
593 push @final_binds, $lob_bind_indices->{$b_idx}
605 if (@sql_parts > 1) {
606 carp "There are more placeholders than binds, this should not happen!";
607 @sql_parts = join ('?', @sql_parts);
610 $final_sql .= $sql_parts[0];
612 return ($final_sql, \@final_binds);
617 sub _exec_svp_begin {
618 my ($self, $name) = @_;
619 $self->_dbh->do("SAVEPOINT $name");
622 # Oracle automatically releases a savepoint when you start another one with the
624 sub _exec_svp_release { 1 }
626 sub _exec_svp_rollback {
627 my ($self, $name) = @_;
628 $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
631 =head2 relname_to_table_alias
633 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
636 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
637 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
640 See L<DBIx::Class::Storage::DBI/relname_to_table_alias>.
644 sub relname_to_table_alias {
646 my ($relname, $join_count) = @_;
648 my $alias = $self->next::method(@_);
650 # we need to shorten here in addition to the shortening in SQLA itself,
651 # since the final relnames are crucial for the join optimizer
652 return $self->sql_maker->_shorten_identifier($alias);
655 =head2 with_deferred_fk_checks
657 Runs a coderef between:
659 alter session set constraints = deferred
661 alter session set constraints = immediate
663 to defer foreign key checks.
665 Constraints must be declared C<DEFERRABLE> for this to work.
669 sub with_deferred_fk_checks {
670 my ($self, $sub) = @_;
672 my $txn_scope_guard = $self->txn_scope_guard;
674 $self->_do_query('alter session set constraints = deferred');
676 my $sg = Scope::Guard->new(sub {
677 $self->_do_query('alter session set constraints = immediate');
681 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
686 Following additional attributes can be used in resultsets.
688 =head2 connect_by or connect_by_nocycle
692 =item Value: \%connect_by
696 A hashref of conditions used to specify the relationship between parent rows
697 and child rows of the hierarchy.
700 connect_by => { parentid => 'prior personid' }
702 # adds a connect by statement to the query:
704 # me.persionid me.firstname, me.lastname, me.parentid
708 # parentid = prior persionid
711 connect_by_nocycle => { parentid => 'prior personid' }
713 # adds a connect by statement to the query:
715 # me.persionid me.firstname, me.lastname, me.parentid
719 # parentid = prior persionid
726 =item Value: \%condition
730 A hashref of conditions which specify the root row(s) of the hierarchy.
732 It uses the same syntax as L<DBIx::Class::ResultSet/search>
734 start_with => { firstname => 'Foo', lastname => 'Bar' }
737 # me.persionid me.firstname, me.lastname, me.parentid
741 # firstname = 'foo' and lastname = 'bar'
743 # parentid = prior persionid
745 =head2 order_siblings_by
749 =item Value: ($order_siblings_by | \@order_siblings_by)
753 Which column(s) to order the siblings by.
755 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
757 'order_siblings_by' => 'firstname ASC'
760 # me.persionid me.firstname, me.lastname, me.parentid
764 # parentid = prior persionid
768 =head1 FURTHER QUESTIONS?
770 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
772 =head1 COPYRIGHT AND LICENSE
774 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
775 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
776 redistribute it and/or modify it under the same terms as the
777 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.