1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve 'preserve_context';
10 __PACKAGE__->sql_limit_dialect ('RowNum');
14 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
18 # In your result (table) classes
19 use base 'DBIx::Class::Core';
20 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
21 __PACKAGE__->set_primary_key('id');
23 # Somewhere in your Code
24 # add some data to a table with a hierarchical relationship
25 $schema->resultset('Person')->create ({
30 firstname => 'child1',
34 firstname => 'grandchild',
40 firstname => 'child2',
46 # select from the hierarchical relationship
47 my $rs = $schema->resultset('Person')->search({},
49 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
50 'connect_by' => { 'parentid' => { '-prior' => { -ident => 'personid' } },
51 'order_siblings_by' => { -asc => 'name' },
55 # this will select the whole tree starting from person "foo bar", creating
58 # me.persionid me.firstname, me.lastname, me.parentid
62 # firstname = 'foo' and lastname = 'bar'
64 # parentid = prior personid
70 This class implements base Oracle support. The subclass
71 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
78 use base qw/DBIx::Class::Storage::DBI/;
81 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
83 sub _determine_supports_insert_returning {
86 # TODO find out which version supports the RETURNING syntax
87 # 8i has it and earlier docs are a 404 on oracle.com
90 if $self->_server_info->{normalized_dbms_version} >= 8.001;
95 __PACKAGE__->_use_insert_returning_bound (1);
97 sub deployment_statements {
99 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
102 my $quote_char = $self->schema->storage->sql_maker->quote_char;
103 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
104 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
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 foreach my $col (@columns) {
121 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
122 my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
128 sub _dbh_get_autoinc_seq {
129 my ($self, $dbh, $source, $col) = @_;
131 my $sql_maker = $self->sql_maker;
132 my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
135 if ( ref $source->name eq 'SCALAR' ) {
136 $source_name = ${$source->name};
138 # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
139 # stuff unless it is already quoted
140 $source_name = uc ($source_name) if $source_name !~ /\"/;
143 $source_name = $source->name;
144 $source_name = uc($source_name) unless $ql;
147 # trigger_body is a LONG
148 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
150 # disable default bindtype
151 local $sql_maker->{bindtype} = 'normal';
153 # look up the correct sequence automatically
154 my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
156 # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
157 $schema ||= uc( ($self->_dbi_connect_info||[])->[1] || '');
159 my ($sql, @bind) = $sql_maker->select (
161 [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
163 $schema ? (OWNER => $schema) : (),
164 TABLE_NAME => $table || $source_name,
165 TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
166 TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
171 # to find all the triggers that mention the column in question a simple
172 # regex grep since the trigger_body above is a LONG and hence not searchable
174 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
176 { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
177 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
181 # extract all sequence names mentioned in each trigger
183 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
188 # if only one trigger matched things are easy
189 if (@triggers == 1) {
191 if ( @{$triggers[0]{sequences}} == 1 ) {
192 $chosen_trigger = $triggers[0];
195 $self->throw_exception( sprintf (
196 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
197 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
205 # got more than one matching trigger - see if we can narrow it down
206 elsif (@triggers > 1) {
208 my @candidates = grep
209 { $_->{body} =~ / into \s+ \:new\.$col /xi }
213 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
214 $chosen_trigger = $candidates[0];
217 $self->throw_exception( sprintf (
218 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
219 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
222 ( join ', ', map { "'$_->{name}'" } @triggers ),
228 if ($chosen_trigger) {
229 my $seq_name = $chosen_trigger->{sequences}[0];
231 $seq_name = "$chosen_trigger->{schema}.$seq_name"
232 unless $seq_name =~ /\./;
234 return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
238 $self->throw_exception( sprintf (
239 "No suitable BEFORE INSERT triggers found for column %s.%s. "
240 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
247 sub _sequence_fetch {
248 my ( $self, $type, $seq ) = @_;
250 # use the maker to leverage quoting settings
251 my $sql_maker = $self->sql_maker;
252 my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
259 my $dbh = $self->_dbh or return 0;
261 local $dbh->{RaiseError} = 1;
262 local $dbh->{PrintError} = 0;
265 $dbh->do('select 1 from dual');
274 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
277 my $want = wantarray;
278 my $next = $self->next::can;
281 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
283 if (!defined $want) {
296 if (! $tried and $_ =~ /ORA-01003/) {
297 # ORA-01003: no statement parsed (someone changed the table somehow,
298 # invalidating your cursor.)
299 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
300 delete $dbh->{CachedKids}{$sql};
303 $self->throw_exception($_);
306 } while (! $tried++);
308 return wantarray ? @res : $res[0];
311 =head2 get_autoinc_seq
313 Returns the sequence name for an autoincrement column
317 sub get_autoinc_seq {
318 my ($self, $source, $col) = @_;
320 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
323 =head2 datetime_parser_type
325 This sets the proper DateTime::Format module for use with
326 L<DBIx::Class::InflateColumn::DateTime>.
330 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
332 =head2 connect_call_datetime_setup
336 on_connect_call => 'datetime_setup'
338 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
339 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
340 and the necessary environment variables for L<DateTime::Format::Oracle>, which
343 Maximum allowable precision is used, unless the environment variables have
346 These are the defaults used:
348 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
349 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
350 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
352 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
353 for your timestamps, use something like this:
355 use Time::HiRes 'time';
356 my $ts = DateTime->from_epoch(epoch => time);
360 sub connect_call_datetime_setup {
363 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
364 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
365 'YYYY-MM-DD HH24:MI:SS.FF';
366 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
367 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
370 "alter session set nls_date_format = '$date_format'"
373 "alter session set nls_timestamp_format = '$timestamp_format'"
376 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
380 =head2 source_bind_attributes
382 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
383 with the driver assuming your input is the deprecated LONG type if you
384 encode it as a hex string. That ain't gonna fly at larger values, where
385 you'll discover you have to do what this does.
387 This method had to be overridden because we need to set ora_field to the
388 actual column, and that isn't passed to the call (provided by Storage) to
389 bind_attribute_by_data_type.
391 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
392 adding it doesn't hurt, and will save your bacon if you're modifying a
393 table with more than one LOB column.
397 sub source_bind_attributes
405 foreach my $column ($source->columns) {
406 my $data_type = $source->column_info($column)->{data_type}
409 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
411 if ($data_type =~ /^[BC]LOB$/i) {
412 if ($DBD::Oracle::VERSION eq '1.23') {
413 $self->throw_exception(
414 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
415 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
419 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
420 ? DBD::Oracle::ORA_CLOB()
421 : DBD::Oracle::ORA_BLOB()
423 $column_bind_attrs{'ora_field'} = $column;
426 $bind_attributes{$column} = \%column_bind_attrs;
429 return \%bind_attributes;
433 my ($self, $name) = @_;
434 $self->_get_dbh->do("SAVEPOINT $name");
437 # Oracle automatically releases a savepoint when you start another one with the
439 sub _svp_release { 1 }
442 my ($self, $name) = @_;
443 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
446 =head2 relname_to_table_alias
448 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
451 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
452 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
455 See L<DBIx::Class::Storage/"relname_to_table_alias">.
459 sub relname_to_table_alias {
461 my ($relname, $join_count) = @_;
463 my $alias = $self->next::method(@_);
465 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
468 =head2 with_deferred_fk_checks
470 Runs a coderef between:
472 alter session set constraints = deferred
474 alter session set constraints = immediate
476 to defer foreign key checks.
478 Constraints must be declared C<DEFERRABLE> for this to work.
482 sub with_deferred_fk_checks {
483 my ($self, $sub) = @_;
485 my $txn_scope_guard = $self->txn_scope_guard;
487 $self->_do_query('alter session set constraints = deferred');
489 my $sg = Scope::Guard->new(sub {
490 $self->_do_query('alter session set constraints = immediate');
494 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
499 Following additional attributes can be used in resultsets.
501 =head2 connect_by or connect_by_nocycle
505 =item Value: \%connect_by
509 A hashref of conditions used to specify the relationship between parent rows
510 and child rows of the hierarchy.
513 connect_by => { parentid => 'prior personid' }
515 # adds a connect by statement to the query:
517 # me.persionid me.firstname, me.lastname, me.parentid
521 # parentid = prior persionid
524 connect_by_nocycle => { parentid => 'prior personid' }
526 # adds a connect by statement to the query:
528 # me.persionid me.firstname, me.lastname, me.parentid
532 # parentid = prior persionid
539 =item Value: \%condition
543 A hashref of conditions which specify the root row(s) of the hierarchy.
545 It uses the same syntax as L<DBIx::Class::ResultSet/search>
547 start_with => { firstname => 'Foo', lastname => 'Bar' }
550 # me.persionid me.firstname, me.lastname, me.parentid
554 # firstname = 'foo' and lastname = 'bar'
556 # parentid = prior persionid
558 =head2 order_siblings_by
562 =item Value: ($order_siblings_by | \@order_siblings_by)
566 Which column(s) to order the siblings by.
568 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
570 'order_siblings_by' => 'firstname ASC'
573 # me.persionid me.firstname, me.lastname, me.parentid
577 # parentid = prior persionid
583 See L<DBIx::Class/CONTRIBUTORS>.
587 You may distribute this code under the same terms as Perl itself.