1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve 'preserve_context';
10 __PACKAGE__->sql_limit_dialect ('RowNum');
11 __PACKAGE__->sql_quote_char ('"');
15 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
19 # In your result (table) classes
20 use base 'DBIx::Class::Core';
21 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
22 __PACKAGE__->set_primary_key('id');
24 # Somewhere in your Code
25 # add some data to a table with a hierarchical relationship
26 $schema->resultset('Person')->create ({
31 firstname => 'child1',
35 firstname => 'grandchild',
41 firstname => 'child2',
47 # select from the hierarchical relationship
48 my $rs = $schema->resultset('Person')->search({},
50 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
51 'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
52 'order_siblings_by' => { -asc => 'name' },
56 # this will select the whole tree starting from person "foo bar", creating
59 # me.persionid me.firstname, me.lastname, me.parentid
63 # firstname = 'foo' and lastname = 'bar'
65 # parentid = prior personid
71 This class implements base Oracle support. The subclass
72 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
79 use base qw/DBIx::Class::Storage::DBI/;
82 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
83 __PACKAGE__->datetime_parser_type('DateTime::Format::Oracle');
85 sub _determine_supports_insert_returning {
88 # TODO find out which version supports the RETURNING syntax
89 # 8i has it and earlier docs are a 404 on oracle.com
92 if $self->_server_info->{normalized_dbms_version} >= 8.001;
97 __PACKAGE__->_use_insert_returning_bound (1);
99 sub deployment_statements {
101 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
104 my $quote_char = $self->schema->storage->sql_maker->quote_char;
105 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
106 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
109 ! exists $sqltargs->{producer_args}{oracle_version}
111 my $dver = $self->_server_info->{dbms_version}
113 $sqltargs->{producer_args}{oracle_version} = $dver;
116 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
119 sub _dbh_last_insert_id {
120 my ($self, $dbh, $source, @columns) = @_;
122 foreach my $col (@columns) {
123 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
124 my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
130 sub _dbh_get_autoinc_seq {
131 my ($self, $dbh, $source, $col) = @_;
133 my $sql_maker = $self->sql_maker;
134 my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
137 if ( ref $source->name eq 'SCALAR' ) {
138 $source_name = ${$source->name};
140 # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
141 # stuff unless it is already quoted
142 $source_name = uc ($source_name) if $source_name !~ /\"/;
145 $source_name = $source->name;
146 $source_name = uc($source_name) unless $ql;
149 # trigger_body is a LONG
150 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
152 # disable default bindtype
153 local $sql_maker->{bindtype} = 'normal';
155 # look up the correct sequence automatically
156 my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
158 # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
159 $schema ||= uc( ($self->_dbi_connect_info||[])->[1] || '');
161 my ($sql, @bind) = $sql_maker->select (
163 [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
165 $schema ? (OWNER => $schema) : (),
166 TABLE_NAME => $table || $source_name,
167 TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
168 TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
173 # to find all the triggers that mention the column in question a simple
174 # 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
185 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
190 # if only one trigger matched things are easy
191 if (@triggers == 1) {
193 if ( @{$triggers[0]{sequences}} == 1 ) {
194 $chosen_trigger = $triggers[0];
197 $self->throw_exception( sprintf (
198 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
199 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
207 # got more than one matching trigger - see if we can narrow it down
208 elsif (@triggers > 1) {
210 my @candidates = grep
211 { $_->{body} =~ / into \s+ \:new\.$col /xi }
215 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
216 $chosen_trigger = $candidates[0];
219 $self->throw_exception( sprintf (
220 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
221 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
224 ( join ', ', map { "'$_->{name}'" } @triggers ),
230 if ($chosen_trigger) {
231 my $seq_name = $chosen_trigger->{sequences}[0];
233 $seq_name = "$chosen_trigger->{schema}.$seq_name"
234 unless $seq_name =~ /\./;
236 return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
240 $self->throw_exception( sprintf (
241 "No suitable BEFORE INSERT triggers found for column %s.%s. "
242 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
249 sub _sequence_fetch {
250 my ( $self, $type, $seq ) = @_;
252 # use the maker to leverage quoting settings
253 my $sql_maker = $self->sql_maker;
254 my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
261 my $dbh = $self->_dbh or return 0;
263 local $dbh->{RaiseError} = 1;
264 local $dbh->{PrintError} = 0;
267 $dbh->do('select 1 from dual');
276 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
279 my $want = wantarray;
280 my $next = $self->next::can;
283 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
285 if (!defined $want) {
298 if (! $tried and $_ =~ /ORA-01003/) {
299 # ORA-01003: no statement parsed (someone changed the table somehow,
300 # invalidating your cursor.)
301 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
302 delete $dbh->{CachedKids}{$sql};
305 $self->throw_exception($_);
308 } while (! $tried++);
310 return wantarray ? @res : $res[0];
313 sub _dbh_execute_array {
314 #my ($self, $sth, $tuple_status, @extra) = @_;
316 # DBD::Oracle warns loudly on partial execute_array failures
317 local $_[1]->{PrintWarn} = 0;
319 shift->next::method(@_);
322 =head2 get_autoinc_seq
324 Returns the sequence name for an autoincrement column
328 sub get_autoinc_seq {
329 my ($self, $source, $col) = @_;
331 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
334 =head2 datetime_parser_type
336 This sets the proper DateTime::Format module for use with
337 L<DBIx::Class::InflateColumn::DateTime>.
339 =head2 connect_call_datetime_setup
343 on_connect_call => 'datetime_setup'
345 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
346 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
347 and the necessary environment variables for L<DateTime::Format::Oracle>, which
350 Maximum allowable precision is used, unless the environment variables have
353 These are the defaults used:
355 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
356 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
357 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
359 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
360 for your timestamps, use something like this:
362 use Time::HiRes 'time';
363 my $ts = DateTime->from_epoch(epoch => time);
367 sub connect_call_datetime_setup {
370 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
371 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
372 'YYYY-MM-DD HH24:MI:SS.FF';
373 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
374 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
377 "alter session set nls_date_format = '$date_format'"
380 "alter session set nls_timestamp_format = '$timestamp_format'"
383 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
387 =head2 source_bind_attributes
389 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
390 with the driver assuming your input is the deprecated LONG type if you
391 encode it as a hex string. That ain't gonna fly at larger values, where
392 you'll discover you have to do what this does.
394 This method had to be overridden because we need to set ora_field to the
395 actual column, and that isn't passed to the call (provided by Storage) to
396 bind_attribute_by_data_type.
398 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
399 adding it doesn't hurt, and will save your bacon if you're modifying a
400 table with more than one LOB column.
404 sub source_bind_attributes
410 my %bind_attributes = %{ $self->next::method(@_) };
412 foreach my $column ($source->columns) {
413 my %column_bind_attrs = %{ $bind_attributes{$column} || {} };
415 my $data_type = $source->column_info($column)->{data_type};
417 if ($self->_is_lob_type($data_type)) {
418 if ($DBD::Oracle::VERSION eq '1.23') {
419 $self->throw_exception(
420 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
421 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
425 $column_bind_attrs{'ora_type'} = $self->_is_text_lob_type($data_type)
426 ? DBD::Oracle::ORA_CLOB()
427 : DBD::Oracle::ORA_BLOB()
429 $column_bind_attrs{'ora_field'} = $column;
432 $bind_attributes{$column} = \%column_bind_attrs;
435 return \%bind_attributes;
439 my ($self, $name) = @_;
440 $self->_get_dbh->do("SAVEPOINT $name");
443 # Oracle automatically releases a savepoint when you start another one with the
445 sub _svp_release { 1 }
448 my ($self, $name) = @_;
449 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
452 =head2 relname_to_table_alias
454 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
457 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
458 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
461 See L<DBIx::Class::Storage/"relname_to_table_alias">.
465 sub relname_to_table_alias {
467 my ($relname, $join_count) = @_;
469 my $alias = $self->next::method(@_);
471 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
474 =head2 with_deferred_fk_checks
476 Runs a coderef between:
478 alter session set constraints = deferred
480 alter session set constraints = immediate
482 to defer foreign key checks.
484 Constraints must be declared C<DEFERRABLE> for this to work.
488 sub with_deferred_fk_checks {
489 my ($self, $sub) = @_;
491 my $txn_scope_guard = $self->txn_scope_guard;
493 $self->_do_query('alter session set constraints = deferred');
495 my $sg = Scope::Guard->new(sub {
496 $self->_do_query('alter session set constraints = immediate');
500 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
505 Following additional attributes can be used in resultsets.
507 =head2 connect_by or connect_by_nocycle
511 =item Value: \%connect_by
515 A hashref of conditions used to specify the relationship between parent rows
516 and child rows of the hierarchy.
519 connect_by => { parentid => 'prior personid' }
521 # adds a connect by statement to the query:
523 # me.persionid me.firstname, me.lastname, me.parentid
527 # parentid = prior persionid
530 connect_by_nocycle => { parentid => 'prior personid' }
532 # adds a connect by statement to the query:
534 # me.persionid me.firstname, me.lastname, me.parentid
538 # parentid = prior persionid
545 =item Value: \%condition
549 A hashref of conditions which specify the root row(s) of the hierarchy.
551 It uses the same syntax as L<DBIx::Class::ResultSet/search>
553 start_with => { firstname => 'Foo', lastname => 'Bar' }
556 # me.persionid me.firstname, me.lastname, me.parentid
560 # firstname = 'foo' and lastname = 'bar'
562 # parentid = prior persionid
564 =head2 order_siblings_by
568 =item Value: ($order_siblings_by | \@order_siblings_by)
572 Which column(s) to order the siblings by.
574 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
576 'order_siblings_by' => 'firstname ASC'
579 # me.persionid me.firstname, me.lastname, me.parentid
583 # parentid = prior persionid
589 See L<DBIx::Class/CONTRIBUTORS>.
593 You may distribute this code under the same terms as Perl itself.