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;
120 if ( ref $source->name eq 'SCALAR' ) {
121 $source_name = ${$source->name};
124 $source_name = $source->name;
126 $source_name = uc($source_name) unless $sql_maker->quote_char;
128 # trigger_body is a LONG
129 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
131 # disable default bindtype
132 local $sql_maker->{bindtype} = 'normal';
134 # look up the correct sequence automatically
135 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
136 my ($sql, @bind) = $sql_maker->select (
138 [qw/ trigger_body table_owner trigger_name /],
140 $schema ? (owner => $schema) : (),
141 table_name => $table || $source_name,
142 triggering_event => { -like => '%INSERT%' }, # this will also catch insert_or_update
143 trigger_type => { -like => '%BEFORE%' }, # we care only about 'before' triggers
148 # to find all the triggers that mention the column in question a simple
149 # regex grep since the trigger_body above is a LONG and hence not searchable
151 { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
153 { $_->[0] =~ /\:new\.$col/i }
154 @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
158 # extract all sequence names mentioned in each trigger
160 $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
165 # if only one trigger matched things are easy
166 if (@triggers == 1) {
168 if ( @{$triggers[0]{sequences}} == 1 ) {
169 $chosen_trigger = $triggers[0];
172 $self->throw_exception( sprintf (
173 "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
174 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
182 # got more than one matching trigger - see if we can narrow it down
183 elsif (@triggers > 1) {
185 my @candidates = grep
186 { $_->{body} =~ / into \s+ \:new\.$col /xi }
190 if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
191 $chosen_trigger = $candidates[0];
194 $self->throw_exception( sprintf (
195 "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
196 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
199 ( join ', ', map { "'$_->{name}'" } @triggers ),
205 if ($chosen_trigger) {
206 my $seq_name = $chosen_trigger->{sequences}[0];
208 $seq_name = "$chosen_trigger->{schema}.$seq_name"
209 unless $seq_name =~ /\./;
214 $self->throw_exception( sprintf (
215 "No suitable BEFORE INSERT triggers found for column %s.%s. "
216 . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
223 sub _sequence_fetch {
224 my ( $self, $type, $seq ) = @_;
225 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
232 my $dbh = $self->_dbh or return 0;
234 local $dbh->{RaiseError} = 1;
235 local $dbh->{PrintError} = 0;
238 $dbh->do('select 1 from dual');
247 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
250 my $wantarray = wantarray();
251 my $next = $self->next::can;
254 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
256 if (!defined $wantarray) {
259 elsif (! $wantarray) {
269 if (! $tried and $_ =~ /ORA-01003/) {
270 # ORA-01003: no statement parsed (someone changed the table somehow,
271 # invalidating your cursor.)
272 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
273 delete $dbh->{CachedKids}{$sql};
276 $self->throw_exception($_);
279 } while (! $tried++);
281 return $wantarray ? @res : $res[0];
284 =head2 get_autoinc_seq
286 Returns the sequence name for an autoincrement column
290 sub get_autoinc_seq {
291 my ($self, $source, $col) = @_;
293 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
296 =head2 datetime_parser_type
298 This sets the proper DateTime::Format module for use with
299 L<DBIx::Class::InflateColumn::DateTime>.
303 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
305 =head2 connect_call_datetime_setup
309 on_connect_call => 'datetime_setup'
311 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
312 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
313 and the necessary environment variables for L<DateTime::Format::Oracle>, which
316 Maximum allowable precision is used, unless the environment variables have
319 These are the defaults used:
321 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
322 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
323 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
325 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
326 for your timestamps, use something like this:
328 use Time::HiRes 'time';
329 my $ts = DateTime->from_epoch(epoch => time);
333 sub connect_call_datetime_setup {
336 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
337 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
338 'YYYY-MM-DD HH24:MI:SS.FF';
339 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
340 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
343 "alter session set nls_date_format = '$date_format'"
346 "alter session set nls_timestamp_format = '$timestamp_format'"
349 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
353 =head2 source_bind_attributes
355 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
356 with the driver assuming your input is the deprecated LONG type if you
357 encode it as a hex string. That ain't gonna fly at larger values, where
358 you'll discover you have to do what this does.
360 This method had to be overridden because we need to set ora_field to the
361 actual column, and that isn't passed to the call (provided by Storage) to
362 bind_attribute_by_data_type.
364 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
365 adding it doesn't hurt, and will save your bacon if you're modifying a
366 table with more than one LOB column.
370 sub source_bind_attributes
378 foreach my $column ($source->columns) {
379 my $data_type = $source->column_info($column)->{data_type} || '';
380 next unless $data_type;
382 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
384 if ($data_type =~ /^[BC]LOB$/i) {
385 if ($DBD::Oracle::VERSION eq '1.23') {
386 $self->throw_exception(
387 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
388 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
392 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
393 ? DBD::Oracle::ORA_CLOB()
394 : DBD::Oracle::ORA_BLOB()
396 $column_bind_attrs{'ora_field'} = $column;
399 $bind_attributes{$column} = \%column_bind_attrs;
402 return \%bind_attributes;
406 my ($self, $name) = @_;
407 $self->_get_dbh->do("SAVEPOINT $name");
410 # Oracle automatically releases a savepoint when you start another one with the
412 sub _svp_release { 1 }
415 my ($self, $name) = @_;
416 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
419 =head2 relname_to_table_alias
421 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
424 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
425 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
428 See L<DBIx::Class::Storage/"relname_to_table_alias">.
432 sub relname_to_table_alias {
434 my ($relname, $join_count) = @_;
436 my $alias = $self->next::method(@_);
438 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
441 =head2 with_deferred_fk_checks
443 Runs a coderef between:
445 alter session set constraints = deferred
447 alter session set constraints = immediate
449 to defer foreign key checks.
451 Constraints must be declared C<DEFERRABLE> for this to work.
455 sub with_deferred_fk_checks {
456 my ($self, $sub) = @_;
458 my $txn_scope_guard = $self->txn_scope_guard;
460 $self->_do_query('alter session set constraints = deferred');
462 my $sg = Scope::Guard->new(sub {
463 $self->_do_query('alter session set constraints = immediate');
467 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
472 Following additional attributes can be used in resultsets.
474 =head2 connect_by or connect_by_nocycle
478 =item Value: \%connect_by
482 A hashref of conditions used to specify the relationship between parent rows
483 and child rows of the hierarchy.
486 connect_by => { parentid => 'prior personid' }
488 # adds a connect by statement to the query:
490 # me.persionid me.firstname, me.lastname, me.parentid
494 # parentid = prior persionid
497 connect_by_nocycle => { parentid => 'prior personid' }
499 # adds a connect by statement to the query:
501 # me.persionid me.firstname, me.lastname, me.parentid
505 # parentid = prior persionid
512 =item Value: \%condition
516 A hashref of conditions which specify the root row(s) of the hierarchy.
518 It uses the same syntax as L<DBIx::Class::ResultSet/search>
520 start_with => { firstname => 'Foo', lastname => 'Bar' }
523 # me.persionid me.firstname, me.lastname, me.parentid
527 # firstname = 'foo' and lastname = 'bar'
529 # parentid = prior persionid
531 =head2 order_siblings_by
535 =item Value: ($order_siblings_by | \@order_siblings_by)
539 Which column(s) to order the siblings by.
541 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
543 'order_siblings_by' => 'firstname ASC'
546 # me.persionid me.firstname, me.lastname, me.parentid
550 # parentid = prior persionid
556 See L<DBIx::Class/CONTRIBUTORS>.
560 You may distribute this code under the same terms as Perl itself.