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 deployment_statements {
85 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
88 my $quote_char = $self->schema->storage->sql_maker->quote_char;
89 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
90 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
93 ! exists $sqltargs->{producer_args}{oracle_version}
95 my $dver = $self->_server_info->{dbms_version}
97 $sqltargs->{producer_args}{oracle_version} = $dver;
100 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
103 sub _dbh_last_insert_id {
104 my ($self, $dbh, $source, @columns) = @_;
106 foreach my $col (@columns) {
107 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
108 my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
114 sub _dbh_get_autoinc_seq {
115 my ($self, $dbh, $source, $col) = @_;
117 my $sql_maker = $self->sql_maker;
118 my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
121 if ( ref $source->name eq 'SCALAR' ) {
122 $source_name = ${$source->name};
124 # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
125 # stuff unless it is already quoted
126 $source_name = uc ($source_name) if $source_name !~ /\"/;
129 $source_name = $source->name;
130 $source_name = uc($source_name) unless $ql;
133 # trigger_body is a LONG
134 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
136 # disable default bindtype
137 local $sql_maker->{bindtype} = 'normal';
140 # look up the correct sequence automatically
141 my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
142 my ($sql, @bind) = $sql_maker->select (
144 [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
146 $schema ? (OWNER => $schema) : (),
147 TABLE_NAME => $table || $source_name,
148 TRIGGERING_EVENT => { -like => '%INSERT%' }, # this will also catch insert_or_update
149 TRIGGER_TYPE => { -like => '%BEFORE%' }, # we care only about 'before' triggers
154 # to find all the triggers that mention the column in question a simple
155 # regex grep since the trigger_body above is a LONG and hence not searchable
157 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
159 { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
160 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
164 # extract all sequence names mentioned in each trigger
166 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
171 # if only one trigger matched things are easy
172 if (@triggers == 1) {
174 if ( @{$triggers[0]{sequences}} == 1 ) {
175 $chosen_trigger = $triggers[0];
178 $self->throw_exception( sprintf (
179 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
180 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
188 # got more than one matching trigger - see if we can narrow it down
189 elsif (@triggers > 1) {
191 my @candidates = grep
192 { $_->{body} =~ / into \s+ \:new\.$col /xi }
196 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
197 $chosen_trigger = $candidates[0];
200 $self->throw_exception( sprintf (
201 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
202 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
205 ( join ', ', map { "'$_->{name}'" } @triggers ),
211 if ($chosen_trigger) {
212 my $seq_name = $chosen_trigger->{sequences}[0];
214 $seq_name = "$chosen_trigger->{schema}.$seq_name"
215 unless $seq_name =~ /\./;
217 return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
221 $self->throw_exception( sprintf (
222 "No suitable BEFORE INSERT triggers found for column %s.%s. "
223 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
230 sub _sequence_fetch {
231 my ( $self, $type, $seq ) = @_;
233 # use the maker to leverage quoting settings
234 my $sql_maker = $self->sql_maker;
235 my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
242 my $dbh = $self->_dbh or return 0;
244 local $dbh->{RaiseError} = 1;
245 local $dbh->{PrintError} = 0;
248 $dbh->do('select 1 from dual');
257 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
260 my $wantarray = wantarray();
261 my $next = $self->next::can;
264 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
266 if (!defined $wantarray) {
269 elsif (! $wantarray) {
279 if (! $tried and $_ =~ /ORA-01003/) {
280 # ORA-01003: no statement parsed (someone changed the table somehow,
281 # invalidating your cursor.)
282 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
283 delete $dbh->{CachedKids}{$sql};
286 $self->throw_exception($_);
289 } while (! $tried++);
291 return $wantarray ? @res : $res[0];
294 =head2 get_autoinc_seq
296 Returns the sequence name for an autoincrement column
300 sub get_autoinc_seq {
301 my ($self, $source, $col) = @_;
303 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
306 =head2 datetime_parser_type
308 This sets the proper DateTime::Format module for use with
309 L<DBIx::Class::InflateColumn::DateTime>.
313 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
315 =head2 connect_call_datetime_setup
319 on_connect_call => 'datetime_setup'
321 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
322 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
323 and the necessary environment variables for L<DateTime::Format::Oracle>, which
326 Maximum allowable precision is used, unless the environment variables have
329 These are the defaults used:
331 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
332 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
333 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
335 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
336 for your timestamps, use something like this:
338 use Time::HiRes 'time';
339 my $ts = DateTime->from_epoch(epoch => time);
343 sub connect_call_datetime_setup {
346 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
347 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
348 'YYYY-MM-DD HH24:MI:SS.FF';
349 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
350 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
353 "alter session set nls_date_format = '$date_format'"
356 "alter session set nls_timestamp_format = '$timestamp_format'"
359 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
363 =head2 source_bind_attributes
365 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
366 with the driver assuming your input is the deprecated LONG type if you
367 encode it as a hex string. That ain't gonna fly at larger values, where
368 you'll discover you have to do what this does.
370 This method had to be overridden because we need to set ora_field to the
371 actual column, and that isn't passed to the call (provided by Storage) to
372 bind_attribute_by_data_type.
374 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
375 adding it doesn't hurt, and will save your bacon if you're modifying a
376 table with more than one LOB column.
380 sub source_bind_attributes
388 foreach my $column ($source->columns) {
389 my $data_type = $source->column_info($column)->{data_type}
392 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
394 if ($data_type =~ /^[BC]LOB$/i) {
395 if ($DBD::Oracle::VERSION eq '1.23') {
396 $self->throw_exception(
397 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
398 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
402 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
403 ? DBD::Oracle::ORA_CLOB()
404 : DBD::Oracle::ORA_BLOB()
406 $column_bind_attrs{'ora_field'} = $column;
409 $bind_attributes{$column} = \%column_bind_attrs;
412 return \%bind_attributes;
416 my ($self, $name) = @_;
417 $self->_get_dbh->do("SAVEPOINT $name");
420 # Oracle automatically releases a savepoint when you start another one with the
422 sub _svp_release { 1 }
425 my ($self, $name) = @_;
426 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
429 =head2 relname_to_table_alias
431 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
434 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
435 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
438 See L<DBIx::Class::Storage/"relname_to_table_alias">.
442 sub relname_to_table_alias {
444 my ($relname, $join_count) = @_;
446 my $alias = $self->next::method(@_);
448 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
451 =head2 with_deferred_fk_checks
453 Runs a coderef between:
455 alter session set constraints = deferred
457 alter session set constraints = immediate
459 to defer foreign key checks.
461 Constraints must be declared C<DEFERRABLE> for this to work.
465 sub with_deferred_fk_checks {
466 my ($self, $sub) = @_;
468 my $txn_scope_guard = $self->txn_scope_guard;
470 $self->_do_query('alter session set constraints = deferred');
472 my $sg = Scope::Guard->new(sub {
473 $self->_do_query('alter session set constraints = immediate');
477 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
482 Following additional attributes can be used in resultsets.
484 =head2 connect_by or connect_by_nocycle
488 =item Value: \%connect_by
492 A hashref of conditions used to specify the relationship between parent rows
493 and child rows of the hierarchy.
496 connect_by => { parentid => 'prior personid' }
498 # adds a connect by statement to the query:
500 # me.persionid me.firstname, me.lastname, me.parentid
504 # parentid = prior persionid
507 connect_by_nocycle => { parentid => 'prior personid' }
509 # adds a connect by statement to the query:
511 # me.persionid me.firstname, me.lastname, me.parentid
515 # parentid = prior persionid
522 =item Value: \%condition
526 A hashref of conditions which specify the root row(s) of the hierarchy.
528 It uses the same syntax as L<DBIx::Class::ResultSet/search>
530 start_with => { firstname => 'Foo', lastname => 'Bar' }
533 # me.persionid me.firstname, me.lastname, me.parentid
537 # firstname = 'foo' and lastname = 'bar'
539 # parentid = prior persionid
541 =head2 order_siblings_by
545 =item Value: ($order_siblings_by | \@order_siblings_by)
549 Which column(s) to order the siblings by.
551 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
553 'order_siblings_by' => 'firstname ASC'
556 # me.persionid me.firstname, me.lastname, me.parentid
560 # parentid = prior persionid
566 See L<DBIx::Class/CONTRIBUTORS>.
570 You may distribute this code under the same terms as Perl itself.