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');
275 my ($self, $dbh, $sql, @args) = @_;
278 my $want = wantarray;
279 my $next = $self->next::can;
282 my $exec = sub { $self->$next($dbh, $sql, @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 delete $dbh->{CachedKids}{$sql};
303 $self->throw_exception($_);
306 } while (! $tried++);
308 return wantarray ? @res : $res[0];
311 sub _dbh_execute_array {
312 #my ($self, $sth, $tuple_status, @extra) = @_;
314 # DBD::Oracle warns loudly on partial execute_array failures
315 local $_[1]->{PrintWarn} = 0;
317 shift->next::method(@_);
320 =head2 get_autoinc_seq
322 Returns the sequence name for an autoincrement column
326 sub get_autoinc_seq {
327 my ($self, $source, $col) = @_;
329 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
332 =head2 datetime_parser_type
334 This sets the proper DateTime::Format module for use with
335 L<DBIx::Class::InflateColumn::DateTime>.
337 =head2 connect_call_datetime_setup
341 on_connect_call => 'datetime_setup'
343 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
344 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
345 and the necessary environment variables for L<DateTime::Format::Oracle>, which
348 Maximum allowable precision is used, unless the environment variables have
351 These are the defaults used:
353 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
354 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
355 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
357 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
358 for your timestamps, use something like this:
360 use Time::HiRes 'time';
361 my $ts = DateTime->from_epoch(epoch => time);
365 sub connect_call_datetime_setup {
368 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
369 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
370 'YYYY-MM-DD HH24:MI:SS.FF';
371 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
372 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
375 "alter session set nls_date_format = '$date_format'"
378 "alter session set nls_timestamp_format = '$timestamp_format'"
381 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
385 ### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
386 ### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
388 # Handle LOB types in Oracle. Under a certain size (4k?), you can get away
389 # with the driver assuming your input is the deprecated LONG type if you
390 # encode it as a hex string. That ain't gonna fly at larger values, where
391 # you'll discover you have to do what this does.
393 # This method had to be overridden because we need to set ora_field to the
394 # actual column, and that isn't passed to the call (provided by Storage) to
395 # bind_attribute_by_data_type.
397 # According to L<DBD::Oracle>, the ora_field isn't always necessary, but
398 # adding it doesn't hurt, and will save your bacon if you're modifying a
399 # table with more than one LOB column.
401 sub _dbi_attrs_for_bind {
402 my ($self, $ident, $bind) = @_;
403 my $attrs = $self->next::method($ident, $bind);
405 for my $i (0 .. $#$attrs) {
406 if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) {
407 $attrs->[$i]{ora_field} = $col;
415 sub bind_attribute_by_data_type {
416 my ($self, $dt) = @_;
420 if ($DBD::Oracle::VERSION eq '1.23') {
421 $self->throw_exception(
422 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
423 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
429 if ($self->_is_lob_type($dt)) {
431 ora_type => $self->_is_text_lob_type($dt)
432 ? DBD::Oracle::ORA_CLOB()
433 : DBD::Oracle::ORA_BLOB()
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 # we need to shorten here in addition to the shortening in SQLA itself,
472 # since the final relnames are a crucial for the join optimizer
473 return $self->sql_maker->_shorten_identifier($alias);
476 =head2 with_deferred_fk_checks
478 Runs a coderef between:
480 alter session set constraints = deferred
482 alter session set constraints = immediate
484 to defer foreign key checks.
486 Constraints must be declared C<DEFERRABLE> for this to work.
490 sub with_deferred_fk_checks {
491 my ($self, $sub) = @_;
493 my $txn_scope_guard = $self->txn_scope_guard;
495 $self->_do_query('alter session set constraints = deferred');
497 my $sg = Scope::Guard->new(sub {
498 $self->_do_query('alter session set constraints = immediate');
502 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
507 Following additional attributes can be used in resultsets.
509 =head2 connect_by or connect_by_nocycle
513 =item Value: \%connect_by
517 A hashref of conditions used to specify the relationship between parent rows
518 and child rows of the hierarchy.
521 connect_by => { parentid => 'prior personid' }
523 # adds a connect by statement to the query:
525 # me.persionid me.firstname, me.lastname, me.parentid
529 # parentid = prior persionid
532 connect_by_nocycle => { parentid => 'prior personid' }
534 # adds a connect by statement to the query:
536 # me.persionid me.firstname, me.lastname, me.parentid
540 # parentid = prior persionid
547 =item Value: \%condition
551 A hashref of conditions which specify the root row(s) of the hierarchy.
553 It uses the same syntax as L<DBIx::Class::ResultSet/search>
555 start_with => { firstname => 'Foo', lastname => 'Bar' }
558 # me.persionid me.firstname, me.lastname, me.parentid
562 # firstname = 'foo' and lastname = 'bar'
564 # parentid = prior persionid
566 =head2 order_siblings_by
570 =item Value: ($order_siblings_by | \@order_siblings_by)
574 Which column(s) to order the siblings by.
576 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
578 'order_siblings_by' => 'firstname ASC'
581 # me.persionid me.firstname, me.lastname, me.parentid
585 # parentid = prior persionid
591 See L<DBIx::Class/CONTRIBUTORS>.
595 You may distribute this code under the same terms as Perl itself.