1 package DBIx::Class::Storage::DBI::Oracle::Generic;
5 use base qw/DBIx::Class::Storage::DBI/;
9 use Context::Preserve 'preserve_context';
11 use List::Util 'first';
14 __PACKAGE__->sql_limit_dialect ('RowNum');
15 __PACKAGE__->sql_quote_char ('"');
16 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
17 __PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
19 sub __cache_queries_with_max_lob_parts { 2 }
23 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
27 # In your result (table) classes
28 use base 'DBIx::Class::Core';
29 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
30 __PACKAGE__->set_primary_key('id');
32 # Somewhere in your Code
33 # add some data to a table with a hierarchical relationship
34 $schema->resultset('Person')->create ({
39 firstname => 'child1',
43 firstname => 'grandchild',
49 firstname => 'child2',
55 # select from the hierarchical relationship
56 my $rs = $schema->resultset('Person')->search({},
58 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
59 'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
60 'order_siblings_by' => { -asc => 'name' },
64 # this will select the whole tree starting from person "foo bar", creating
67 # me.persionid me.firstname, me.lastname, me.parentid
71 # firstname = 'foo' and lastname = 'bar'
73 # parentid = prior personid
79 This class implements base Oracle support. The subclass
80 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
87 sub _determine_supports_insert_returning {
90 # TODO find out which version supports the RETURNING syntax
91 # 8i has it and earlier docs are a 404 on oracle.com
94 if $self->_server_info->{normalized_dbms_version} >= 8.001;
99 __PACKAGE__->_use_insert_returning_bound (1);
101 sub deployment_statements {
103 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
106 my $quote_char = $self->schema->storage->sql_maker->quote_char;
107 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
108 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
111 ! exists $sqltargs->{producer_args}{oracle_version}
113 my $dver = $self->_server_info->{dbms_version}
115 $sqltargs->{producer_args}{oracle_version} = $dver;
118 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
121 sub _dbh_last_insert_id {
122 my ($self, $dbh, $source, @columns) = @_;
124 foreach my $col (@columns) {
125 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
126 my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
132 sub _dbh_get_autoinc_seq {
133 my ($self, $dbh, $source, $col) = @_;
135 my $sql_maker = $self->sql_maker;
136 my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
139 if ( ref $source->name eq 'SCALAR' ) {
140 $source_name = ${$source->name};
142 # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
143 # stuff unless it is already quoted
144 $source_name = uc ($source_name) if $source_name !~ /\"/;
147 $source_name = $source->name;
148 $source_name = uc($source_name) unless $ql;
151 # trigger_body is a LONG
152 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
154 # disable default bindtype
155 local $sql_maker->{bindtype} = 'normal';
157 # look up the correct sequence automatically
158 my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
160 # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
161 $schema ||= \'= USER';
163 my ($sql, @bind) = $sql_maker->select (
165 [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
167 $schema ? (OWNER => $schema) : (),
168 TABLE_NAME => $table || $source_name,
169 TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
170 TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
175 # to find all the triggers that mention the column in question a simple
176 # regex grep since the trigger_body above is a LONG and hence not searchable
178 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
180 { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
181 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
185 # extract all sequence names mentioned in each trigger
187 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
192 # if only one trigger matched things are easy
193 if (@triggers == 1) {
195 if ( @{$triggers[0]{sequences}} == 1 ) {
196 $chosen_trigger = $triggers[0];
199 $self->throw_exception( sprintf (
200 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
201 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
209 # got more than one matching trigger - see if we can narrow it down
210 elsif (@triggers > 1) {
212 my @candidates = grep
213 { $_->{body} =~ / into \s+ \:new\.$col /xi }
217 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
218 $chosen_trigger = $candidates[0];
221 $self->throw_exception( sprintf (
222 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
223 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
226 ( join ', ', map { "'$_->{name}'" } @triggers ),
232 if ($chosen_trigger) {
233 my $seq_name = $chosen_trigger->{sequences}[0];
235 $seq_name = "$chosen_trigger->{schema}.$seq_name"
236 unless $seq_name =~ /\./;
238 return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
242 $self->throw_exception( sprintf (
243 "No suitable BEFORE INSERT triggers found for column %s.%s. "
244 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
251 sub _sequence_fetch {
252 my ( $self, $type, $seq ) = @_;
254 # use the maker to leverage quoting settings
255 my $sql_maker = $self->sql_maker;
256 my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
263 my $dbh = $self->_dbh or return 0;
265 local $dbh->{RaiseError} = 1;
266 local $dbh->{PrintError} = 0;
269 $dbh->do('select 1 from dual');
277 my ($self, $dbh, $sql, @args) = @_;
280 my $want = wantarray;
281 my $next = $self->next::can;
285 # Turn off sth caching for multi-part LOBs. See _prep_for_execute above.
286 local $self->{disable_sth_caching} = 1
288 ($_->[0]{_ora_lob_autosplit_part}||0)
289 > (__cache_queries_with_max_lob_parts-1)
292 $self->$next($dbh, $sql, @args)
295 if (!defined $want) {
308 if (! $tried and $_ =~ /ORA-01003/) {
309 # ORA-01003: no statement parsed (someone changed the table somehow,
310 # invalidating your cursor.)
311 delete $dbh->{CachedKids}{$sql};
314 $self->throw_exception($_);
317 } while (! $tried++);
319 return wantarray ? @res : $res[0];
322 sub _dbh_execute_array {
323 #my ($self, $sth, $tuple_status, @extra) = @_;
325 # DBD::Oracle warns loudly on partial execute_array failures
326 local $_[1]->{PrintWarn} = 0;
328 shift->next::method(@_);
331 =head2 get_autoinc_seq
333 Returns the sequence name for an autoincrement column
337 sub get_autoinc_seq {
338 my ($self, $source, $col) = @_;
340 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
343 =head2 datetime_parser_type
345 This sets the proper DateTime::Format module for use with
346 L<DBIx::Class::InflateColumn::DateTime>.
348 =head2 connect_call_datetime_setup
352 on_connect_call => 'datetime_setup'
354 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
355 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
356 and the necessary environment variables for L<DateTime::Format::Oracle>, which
359 Maximum allowable precision is used, unless the environment variables have
362 These are the defaults used:
364 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
365 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
366 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
368 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
369 for your timestamps, use something like this:
371 use Time::HiRes 'time';
372 my $ts = DateTime->from_epoch(epoch => time);
376 sub connect_call_datetime_setup {
379 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
380 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
381 'YYYY-MM-DD HH24:MI:SS.FF';
382 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
383 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
386 "alter session set nls_date_format = '$date_format'"
389 "alter session set nls_timestamp_format = '$timestamp_format'"
392 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
396 ### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
397 ### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
399 # Handle LOB types in Oracle. Under a certain size (4k?), you can get away
400 # with the driver assuming your input is the deprecated LONG type if you
401 # encode it as a hex string. That ain't gonna fly at larger values, where
402 # you'll discover you have to do what this does.
404 # This method had to be overridden because we need to set ora_field to the
405 # actual column, and that isn't passed to the call (provided by Storage) to
406 # bind_attribute_by_data_type.
408 # According to L<DBD::Oracle>, the ora_field isn't always necessary, but
409 # adding it doesn't hurt, and will save your bacon if you're modifying a
410 # table with more than one LOB column.
412 sub _dbi_attrs_for_bind {
413 my ($self, $ident, $bind) = @_;
415 my $attrs = $self->next::method($ident, $bind);
417 for my $i (0 .. $#$attrs) {
418 if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) {
419 $attrs->[$i]{ora_field} = $col;
427 sub bind_attribute_by_data_type {
428 my ($self, $dt) = @_;
432 if ($DBD::Oracle::VERSION eq '1.23') {
433 $self->throw_exception(
434 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
435 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
441 if ($self->_is_lob_type($dt)) {
443 ora_type => $self->_is_text_lob_type($dt)
444 ? DBD::Oracle::ORA_CLOB()
445 : DBD::Oracle::ORA_BLOB()
450 # Handle blob columns in WHERE.
452 # For equality comparisons:
454 # We split data intended for comparing to a LOB into 2000 character chunks and
455 # compare them using dbms_lob.substr on the LOB column.
457 # We turn off DBD::Oracle LOB binds for these partial LOB comparisons by passing
458 # dbd_attrs => undef, because these are regular varchar2 comparisons and
459 # otherwise the query will fail.
461 # Since the most common comparison size is likely to be under 4000 characters
462 # (TEXT comparisons previously deployed to other RDBMSes) we disable
463 # prepare_cached for queries with more than two part comparisons to a LOB
464 # column. This is done in _dbh_execute (above) which was previously overridden
465 # to gracefully recover from an Oracle error. This is to be careful to not
466 # exhaust your application's open cursor limit.
469 # http://itcareershift.com/blog1/2011/02/21/oracle-max-number-of-open-cursors-complete-reference-for-the-new-oracle-dba/
470 # on the open_cursor limit.
472 # For everything else:
474 # We assume that everything that is not a LOB comparison, will most likely be a
475 # LIKE query or some sort of function invocation. This may prove to be a naive
476 # assumption in the future, but for now it should cover the two most likely
477 # things users would want to do with a BLOB or CLOB, an equality test or a LIKE
480 # For these expressions, the bind must NOT have the attributes of a LOB bind for
481 # DBD::Oracle, otherwise the query will fail. This is done by passing
482 # dbd_attrs => undef.
484 sub _prep_for_execute {
488 my ($sql, $bind) = $self->next::method(@_);
490 return ($sql, $bind) if $op eq 'insert';
494 $blob_bind_index->{$_} = 1 if $self->_is_lob_type(
495 $bind->[$_][0]{sqlt_datatype}
499 return ($sql, $bind) unless $blob_bind_index;
501 my (@sql_parts, $new_sql, @new_binds);
503 if ($op eq 'select' || $op eq 'delete') {
504 @sql_parts = split /\?/, $sql;
506 elsif ($op eq 'update') {
507 $self->throw_exception('Update with complex WHERE clauses currently not supported')
508 if $sql =~ /\bWHERE\b .+ \bWHERE\b/xs;
510 my ($set_part, $where_part) = $sql =~ /^ (.+?) ( \bWHERE\b .+) /xs;
512 my $set_bind_count = $set_part =~ y/?//;
513 @new_binds = splice @$bind, 0, $set_bind_count;
515 @sql_parts = split /\?/, $where_part;
516 $new_sql = $set_part;
519 $self->throw_exception("Unsupported \$op: $op");
522 my $col_equality_re = qr/ (?<=\s) ([\w."]+) (\s*=\s*) $/x;
524 for my $b_idx (0 .. $#$bind) {
525 my $bound = $bind->[$b_idx];
527 if ($blob_bind_index->{$b_idx}) {
528 if (my ($col, $eq) = $sql_parts[0] =~ $col_equality_re) {
529 my $data = $bound->[1];
531 $data = "$data" if ref $data;
533 my @parts = unpack '(a2000)*', $data;
537 for my $idx (0..$#parts) {
538 push @sql_frag, sprintf (
539 'UTL_RAW.CAST_TO_VARCHAR2(RAWTOHEX(DBMS_LOB.SUBSTR(%s, 2000, %d))) = ?',
540 $col, ($idx*2000 + 1),
544 my $sql_frag = '( ' . (join ' AND ', @sql_frag) . ' )';
546 $sql_parts[0] =~ s/$col_equality_re/$sql_frag/;
548 $new_sql .= shift @sql_parts;
550 for my $idx (0..$#parts) {
554 _ora_lob_autosplit_part => $idx,
562 $new_sql .= shift(@sql_parts) . '?';
574 $new_sql .= shift(@sql_parts) . '?';
575 push @new_binds, $bound;
579 if (@sql_parts > 1) {
580 carp "There are more placeholders than binds, this should not happen!";
581 @sql_parts = join ('?', @sql_parts);
584 $new_sql .= $sql_parts[0];
586 return ($new_sql, \@new_binds);
591 sub _exec_svp_begin {
592 my ($self, $name) = @_;
593 $self->_dbh->do("SAVEPOINT $name");
596 # Oracle automatically releases a savepoint when you start another one with the
598 sub _exec_svp_release { 1 }
600 sub _exec_svp_rollback {
601 my ($self, $name) = @_;
602 $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
605 =head2 relname_to_table_alias
607 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
610 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
611 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
614 See L<DBIx::Class::Storage/"relname_to_table_alias">.
618 sub relname_to_table_alias {
620 my ($relname, $join_count) = @_;
622 my $alias = $self->next::method(@_);
624 # we need to shorten here in addition to the shortening in SQLA itself,
625 # since the final relnames are a crucial for the join optimizer
626 return $self->sql_maker->_shorten_identifier($alias);
629 =head2 with_deferred_fk_checks
631 Runs a coderef between:
633 alter session set constraints = deferred
635 alter session set constraints = immediate
637 to defer foreign key checks.
639 Constraints must be declared C<DEFERRABLE> for this to work.
643 sub with_deferred_fk_checks {
644 my ($self, $sub) = @_;
646 my $txn_scope_guard = $self->txn_scope_guard;
648 $self->_do_query('alter session set constraints = deferred');
650 my $sg = Scope::Guard->new(sub {
651 $self->_do_query('alter session set constraints = immediate');
655 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
660 Following additional attributes can be used in resultsets.
662 =head2 connect_by or connect_by_nocycle
666 =item Value: \%connect_by
670 A hashref of conditions used to specify the relationship between parent rows
671 and child rows of the hierarchy.
674 connect_by => { parentid => 'prior personid' }
676 # adds a connect by statement to the query:
678 # me.persionid me.firstname, me.lastname, me.parentid
682 # parentid = prior persionid
685 connect_by_nocycle => { parentid => 'prior personid' }
687 # adds a connect by statement to the query:
689 # me.persionid me.firstname, me.lastname, me.parentid
693 # parentid = prior persionid
700 =item Value: \%condition
704 A hashref of conditions which specify the root row(s) of the hierarchy.
706 It uses the same syntax as L<DBIx::Class::ResultSet/search>
708 start_with => { firstname => 'Foo', lastname => 'Bar' }
711 # me.persionid me.firstname, me.lastname, me.parentid
715 # firstname = 'foo' and lastname = 'bar'
717 # parentid = prior persionid
719 =head2 order_siblings_by
723 =item Value: ($order_siblings_by | \@order_siblings_by)
727 Which column(s) to order the siblings by.
729 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
731 'order_siblings_by' => 'firstname ASC'
734 # me.persionid me.firstname, me.lastname, me.parentid
738 # parentid = prior persionid
744 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
748 You may distribute this code under the same terms as Perl itself.