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');
84 sub _determine_supports_insert_returning {
87 # TODO find out which version supports the RETURNING syntax
88 # 8i has it and earlier docs are a 404 on oracle.com
91 if $self->_server_info->{normalized_dbms_version} >= 8.001;
96 __PACKAGE__->_use_insert_returning_bound (1);
98 sub deployment_statements {
100 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
103 my $quote_char = $self->schema->storage->sql_maker->quote_char;
104 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
105 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
108 ! exists $sqltargs->{producer_args}{oracle_version}
110 my $dver = $self->_server_info->{dbms_version}
112 $sqltargs->{producer_args}{oracle_version} = $dver;
115 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
118 sub _dbh_last_insert_id {
119 my ($self, $dbh, $source, @columns) = @_;
121 foreach my $col (@columns) {
122 my $seq = ($source->column_info($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 ||= uc( ($self->_dbi_connect_info||[])->[1] || '');
160 my ($sql, @bind) = $sql_maker->select (
162 [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
164 $schema ? (OWNER => $schema) : (),
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
175 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
177 { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
178 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
182 # extract all sequence names mentioned in each trigger
184 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
189 # if only one trigger matched things are easy
190 if (@triggers == 1) {
192 if ( @{$triggers[0]{sequences}} == 1 ) {
193 $chosen_trigger = $triggers[0];
196 $self->throw_exception( sprintf (
197 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
198 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
206 # got more than one matching trigger - see if we can narrow it down
207 elsif (@triggers > 1) {
209 my @candidates = grep
210 { $_->{body} =~ / into \s+ \:new\.$col /xi }
214 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
215 $chosen_trigger = $candidates[0];
218 $self->throw_exception( sprintf (
219 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
220 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
223 ( join ', ', map { "'$_->{name}'" } @triggers ),
229 if ($chosen_trigger) {
230 my $seq_name = $chosen_trigger->{sequences}[0];
232 $seq_name = "$chosen_trigger->{schema}.$seq_name"
233 unless $seq_name =~ /\./;
235 return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
239 $self->throw_exception( sprintf (
240 "No suitable BEFORE INSERT triggers found for column %s.%s. "
241 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
248 sub _sequence_fetch {
249 my ( $self, $type, $seq ) = @_;
251 # use the maker to leverage quoting settings
252 my $sql_maker = $self->sql_maker;
253 my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
260 my $dbh = $self->_dbh or return 0;
262 local $dbh->{RaiseError} = 1;
263 local $dbh->{PrintError} = 0;
266 $dbh->do('select 1 from dual');
275 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
278 my $want = wantarray;
279 my $next = $self->next::can;
282 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
284 if (!defined $want) {
297 if (! $tried and $_ =~ /ORA-01003/) {
298 # ORA-01003: no statement parsed (someone changed the table somehow,
299 # invalidating your cursor.)
300 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
301 delete $dbh->{CachedKids}{$sql};
304 $self->throw_exception($_);
307 } while (! $tried++);
309 return wantarray ? @res : $res[0];
312 sub _dbh_execute_array {
313 #my ($self, $sth, $tuple_status, @extra) = @_;
315 # DBD::Oracle warns loudly on partial execute_array failures
316 local $_[1]->{PrintWarn} = 0;
318 shift->next::method(@_);
321 =head2 get_autoinc_seq
323 Returns the sequence name for an autoincrement column
327 sub get_autoinc_seq {
328 my ($self, $source, $col) = @_;
330 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
333 =head2 datetime_parser_type
335 This sets the proper DateTime::Format module for use with
336 L<DBIx::Class::InflateColumn::DateTime>.
340 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
342 =head2 connect_call_datetime_setup
346 on_connect_call => 'datetime_setup'
348 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
349 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
350 and the necessary environment variables for L<DateTime::Format::Oracle>, which
353 Maximum allowable precision is used, unless the environment variables have
356 These are the defaults used:
358 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
359 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
360 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
362 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
363 for your timestamps, use something like this:
365 use Time::HiRes 'time';
366 my $ts = DateTime->from_epoch(epoch => time);
370 sub connect_call_datetime_setup {
373 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
374 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
375 'YYYY-MM-DD HH24:MI:SS.FF';
376 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
377 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
380 "alter session set nls_date_format = '$date_format'"
383 "alter session set nls_timestamp_format = '$timestamp_format'"
386 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
390 =head2 source_bind_attributes
392 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
393 with the driver assuming your input is the deprecated LONG type if you
394 encode it as a hex string. That ain't gonna fly at larger values, where
395 you'll discover you have to do what this does.
397 This method had to be overridden because we need to set ora_field to the
398 actual column, and that isn't passed to the call (provided by Storage) to
399 bind_attribute_by_data_type.
401 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
402 adding it doesn't hurt, and will save your bacon if you're modifying a
403 table with more than one LOB column.
407 sub source_bind_attributes
413 my %bind_attributes = %{ $self->next::method(@_) };
415 foreach my $column ($source->columns) {
416 my %column_bind_attrs = %{ $bind_attributes{$column} || {} };
418 my $data_type = $source->column_info($column)->{data_type};
420 if ($self->_is_lob_type($data_type)) {
421 if ($DBD::Oracle::VERSION eq '1.23') {
422 $self->throw_exception(
423 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
424 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
428 $column_bind_attrs{'ora_type'} = $self->_is_text_lob_type($data_type)
429 ? DBD::Oracle::ORA_CLOB()
430 : DBD::Oracle::ORA_BLOB()
432 $column_bind_attrs{'ora_field'} = $column;
435 $bind_attributes{$column} = \%column_bind_attrs;
438 return \%bind_attributes;
442 my ($self, $name) = @_;
443 $self->_get_dbh->do("SAVEPOINT $name");
446 # Oracle automatically releases a savepoint when you start another one with the
448 sub _svp_release { 1 }
451 my ($self, $name) = @_;
452 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
455 =head2 relname_to_table_alias
457 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
460 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
461 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
464 See L<DBIx::Class::Storage/"relname_to_table_alias">.
468 sub relname_to_table_alias {
470 my ($relname, $join_count) = @_;
472 my $alias = $self->next::method(@_);
474 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
477 =head2 with_deferred_fk_checks
479 Runs a coderef between:
481 alter session set constraints = deferred
483 alter session set constraints = immediate
485 to defer foreign key checks.
487 Constraints must be declared C<DEFERRABLE> for this to work.
491 sub with_deferred_fk_checks {
492 my ($self, $sub) = @_;
494 my $txn_scope_guard = $self->txn_scope_guard;
496 $self->_do_query('alter session set constraints = deferred');
498 my $sg = Scope::Guard->new(sub {
499 $self->_do_query('alter session set constraints = immediate');
503 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
508 Following additional attributes can be used in resultsets.
510 =head2 connect_by or connect_by_nocycle
514 =item Value: \%connect_by
518 A hashref of conditions used to specify the relationship between parent rows
519 and child rows of the hierarchy.
522 connect_by => { parentid => 'prior personid' }
524 # adds a connect by statement to the query:
526 # me.persionid me.firstname, me.lastname, me.parentid
530 # parentid = prior persionid
533 connect_by_nocycle => { parentid => 'prior personid' }
535 # adds a connect by statement to the query:
537 # me.persionid me.firstname, me.lastname, me.parentid
541 # parentid = prior persionid
548 =item Value: \%condition
552 A hashref of conditions which specify the root row(s) of the hierarchy.
554 It uses the same syntax as L<DBIx::Class::ResultSet/search>
556 start_with => { firstname => 'Foo', lastname => 'Bar' }
559 # me.persionid me.firstname, me.lastname, me.parentid
563 # firstname = 'foo' and lastname = 'bar'
565 # parentid = prior persionid
567 =head2 order_siblings_by
571 =item Value: ($order_siblings_by | \@order_siblings_by)
575 Which column(s) to order the siblings by.
577 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
579 'order_siblings_by' => 'firstname ASC'
582 # me.persionid me.firstname, me.lastname, me.parentid
586 # parentid = prior persionid
592 See L<DBIx::Class/CONTRIBUTORS>.
596 You may distribute this code under the same terms as Perl itself.