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');
22 __PACKAGE__->sequence('mysequence');
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 deployment_statements {
86 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
89 my $quote_char = $self->schema->storage->sql_maker->quote_char;
90 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
91 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
94 ! exists $sqltargs->{producer_args}{oracle_version}
96 my $dver = $self->_server_info->{dbms_version}
98 $sqltargs->{producer_args}{oracle_version} = $dver;
101 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
104 sub _dbh_last_insert_id {
105 my ($self, $dbh, $source, @columns) = @_;
107 foreach my $col (@columns) {
108 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
109 my $id = $self->_sequence_fetch( 'currval', $seq );
115 sub _dbh_get_autoinc_seq {
116 my ($self, $dbh, $source, $col) = @_;
118 my $sql_maker = $self->sql_maker;
121 if ( ref $source->name eq 'SCALAR' ) {
122 $source_name = ${$source->name};
125 $source_name = $source->name;
127 $source_name = uc($source_name) unless $sql_maker->quote_char;
129 # trigger_body is a LONG
130 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
132 # disable default bindtype
133 local $sql_maker->{bindtype} = 'normal';
135 # look up the correct sequence automatically
136 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
137 my ($sql, @bind) = $sql_maker->select (
139 [qw/ trigger_body table_owner trigger_name /],
141 $schema ? (owner => $schema) : (),
142 table_name => $table || $source_name,
143 triggering_event => { -like => '%INSERT%' }, # this will also catch insert_or_update
144 trigger_type => { -like => '%BEFORE%' }, # we care only about 'before' triggers
149 # to find all the triggers that mention the column in question a simple
150 # regex grep since the trigger_body above is a LONG and hence not searchable
152 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
154 { $_->[0] =~ /\:new\.$col/i }
155 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
159 # extract all sequence names mentioned in each trigger
161 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
166 # if only one trigger matched things are easy
167 if (@triggers == 1) {
169 if ( @{$triggers[0]{sequences}} == 1 ) {
170 $chosen_trigger = $triggers[0];
173 $self->throw_exception( sprintf (
174 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
175 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
183 # got more than one matching trigger - see if we can narrow it down
184 elsif (@triggers > 1) {
186 my @candidates = grep
187 { $_->{body} =~ / into \s+ \:new\.$col /xi }
191 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
192 $chosen_trigger = $candidates[0];
195 $self->throw_exception( sprintf (
196 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
197 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
200 ( join ', ', map { "'$_->{name}'" } @triggers ),
206 if ($chosen_trigger) {
207 my $seq_name = $chosen_trigger->{sequences}[0];
209 $seq_name = "$chosen_trigger->{schema}.$seq_name"
210 unless $seq_name =~ /\./;
215 $self->throw_exception( sprintf (
216 "No suitable BEFORE INSERT triggers found for column %s.%s. "
217 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
224 sub _sequence_fetch {
225 my ( $self, $type, $seq ) = @_;
226 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
233 my $dbh = $self->_dbh or return 0;
235 local $dbh->{RaiseError} = 1;
236 local $dbh->{PrintError} = 0;
239 $dbh->do('select 1 from dual');
248 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
251 my $wantarray = wantarray();
252 my $next = $self->next::can;
255 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
257 if (!defined $wantarray) {
260 elsif (! $wantarray) {
270 if (! $tried and $_ =~ /ORA-01003/) {
271 # ORA-01003: no statement parsed (someone changed the table somehow,
272 # invalidating your cursor.)
273 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
274 delete $dbh->{CachedKids}{$sql};
277 $self->throw_exception($_);
280 } while (! $tried++);
282 return $wantarray ? @res : $res[0];
285 =head2 get_autoinc_seq
287 Returns the sequence name for an autoincrement column
291 sub get_autoinc_seq {
292 my ($self, $source, $col) = @_;
294 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
297 =head2 datetime_parser_type
299 This sets the proper DateTime::Format module for use with
300 L<DBIx::Class::InflateColumn::DateTime>.
304 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
306 =head2 connect_call_datetime_setup
310 on_connect_call => 'datetime_setup'
312 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
313 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
314 and the necessary environment variables for L<DateTime::Format::Oracle>, which
317 Maximum allowable precision is used, unless the environment variables have
320 These are the defaults used:
322 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
323 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
324 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
326 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
327 for your timestamps, use something like this:
329 use Time::HiRes 'time';
330 my $ts = DateTime->from_epoch(epoch => time);
334 sub connect_call_datetime_setup {
337 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
338 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
339 'YYYY-MM-DD HH24:MI:SS.FF';
340 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
341 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
344 "alter session set nls_date_format = '$date_format'"
347 "alter session set nls_timestamp_format = '$timestamp_format'"
350 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
354 =head2 source_bind_attributes
356 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
357 with the driver assuming your input is the deprecated LONG type if you
358 encode it as a hex string. That ain't gonna fly at larger values, where
359 you'll discover you have to do what this does.
361 This method had to be overridden because we need to set ora_field to the
362 actual column, and that isn't passed to the call (provided by Storage) to
363 bind_attribute_by_data_type.
365 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
366 adding it doesn't hurt, and will save your bacon if you're modifying a
367 table with more than one LOB column.
371 sub source_bind_attributes
379 foreach my $column ($source->columns) {
380 my $data_type = $source->column_info($column)->{data_type} || '';
381 next unless $data_type;
383 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
385 if ($data_type =~ /^[BC]LOB$/i) {
386 if ($DBD::Oracle::VERSION eq '1.23') {
387 $self->throw_exception(
388 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
389 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
393 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
394 ? DBD::Oracle::ORA_CLOB()
395 : DBD::Oracle::ORA_BLOB()
397 $column_bind_attrs{'ora_field'} = $column;
400 $bind_attributes{$column} = \%column_bind_attrs;
403 return \%bind_attributes;
407 my ($self, $name) = @_;
408 $self->_get_dbh->do("SAVEPOINT $name");
411 # Oracle automatically releases a savepoint when you start another one with the
413 sub _svp_release { 1 }
416 my ($self, $name) = @_;
417 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
420 =head2 relname_to_table_alias
422 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
425 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
426 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
429 See L<DBIx::Class::Storage/"relname_to_table_alias">.
433 sub relname_to_table_alias {
435 my ($relname, $join_count) = @_;
437 my $alias = $self->next::method(@_);
439 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
442 =head2 with_deferred_fk_checks
444 Runs a coderef between:
446 alter session set constraints = deferred
448 alter session set constraints = immediate
450 to defer foreign key checks.
452 Constraints must be declared C<DEFERRABLE> for this to work.
456 sub with_deferred_fk_checks {
457 my ($self, $sub) = @_;
459 my $txn_scope_guard = $self->txn_scope_guard;
461 $self->_do_query('alter session set constraints = deferred');
463 my $sg = Scope::Guard->new(sub {
464 $self->_do_query('alter session set constraints = immediate');
468 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
473 Following additional attributes can be used in resultsets.
475 =head2 connect_by or connect_by_nocycle
479 =item Value: \%connect_by
483 A hashref of conditions used to specify the relationship between parent rows
484 and child rows of the hierarchy.
487 connect_by => { parentid => 'prior personid' }
489 # adds a connect by statement to the query:
491 # me.persionid me.firstname, me.lastname, me.parentid
495 # parentid = prior persionid
498 connect_by_nocycle => { parentid => 'prior personid' }
500 # adds a connect by statement to the query:
502 # me.persionid me.firstname, me.lastname, me.parentid
506 # parentid = prior persionid
513 =item Value: \%condition
517 A hashref of conditions which specify the root row(s) of the hierarchy.
519 It uses the same syntax as L<DBIx::Class::ResultSet/search>
521 start_with => { firstname => 'Foo', lastname => 'Bar' }
524 # me.persionid me.firstname, me.lastname, me.parentid
528 # firstname = 'foo' and lastname = 'bar'
530 # parentid = prior persionid
532 =head2 order_siblings_by
536 =item Value: ($order_siblings_by | \@order_siblings_by)
540 Which column(s) to order the siblings by.
542 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
544 'order_siblings_by' => 'firstname ASC'
547 # me.persionid me.firstname, me.lastname, me.parentid
551 # parentid = prior persionid
557 See L<DBIx::Class/CONTRIBUTORS>.
561 You may distribute this code under the same terms as Perl itself.