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' => \'persionid' },
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 persionid
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::SQLAHacks::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 ['trigger_body', 'table_owner'],
141 $schema ? (owner => $schema) : (),
142 table_name => $table || $source_name,
143 triggering_event => { -like => '%INSERT%' },
147 my $sth = $dbh->prepare($sql);
148 $sth->execute (@bind);
150 while (my ($insert_trigger, $schema) = $sth->fetchrow_array) {
151 my ($seq_name) = $insert_trigger =~ m!("?[.\w"]+"?)\.nextval!i;
153 next unless $seq_name;
155 if ($seq_name !~ /\./) {
156 $seq_name = join '.' => $schema, $seq_name;
161 $self->throw_exception("Unable to find a sequence %INSERT% trigger on table '$source_name'.");
164 sub _sequence_fetch {
165 my ( $self, $type, $seq ) = @_;
166 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
173 my $dbh = $self->_dbh or return 0;
175 local $dbh->{RaiseError} = 1;
176 local $dbh->{PrintError} = 0;
179 $dbh->do('select 1 from dual');
188 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
191 my $wantarray = wantarray();
192 my $next = $self->next::can;
195 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
197 if (!defined $wantarray) {
200 elsif (! $wantarray) {
210 if (! $tried and $_ =~ /ORA-01003/) {
211 # ORA-01003: no statement parsed (someone changed the table somehow,
212 # invalidating your cursor.)
213 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
214 delete $dbh->{CachedKids}{$sql};
217 $self->throw_exception($_);
220 } while (! $tried++);
222 return $wantarray ? @res : $res[0];
225 =head2 get_autoinc_seq
227 Returns the sequence name for an autoincrement column
231 sub get_autoinc_seq {
232 my ($self, $source, $col) = @_;
234 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
237 =head2 datetime_parser_type
239 This sets the proper DateTime::Format module for use with
240 L<DBIx::Class::InflateColumn::DateTime>.
244 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
246 =head2 connect_call_datetime_setup
250 on_connect_call => 'datetime_setup'
252 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
253 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
254 and the necessary environment variables for L<DateTime::Format::Oracle>, which
257 Maximum allowable precision is used, unless the environment variables have
260 These are the defaults used:
262 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
263 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
264 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
266 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
267 for your timestamps, use something like this:
269 use Time::HiRes 'time';
270 my $ts = DateTime->from_epoch(epoch => time);
274 sub connect_call_datetime_setup {
277 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
278 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
279 'YYYY-MM-DD HH24:MI:SS.FF';
280 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
281 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
284 "alter session set nls_date_format = '$date_format'"
287 "alter session set nls_timestamp_format = '$timestamp_format'"
290 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
294 =head2 source_bind_attributes
296 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
297 with the driver assuming your input is the deprecated LONG type if you
298 encode it as a hex string. That ain't gonna fly at larger values, where
299 you'll discover you have to do what this does.
301 This method had to be overridden because we need to set ora_field to the
302 actual column, and that isn't passed to the call (provided by Storage) to
303 bind_attribute_by_data_type.
305 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
306 adding it doesn't hurt, and will save your bacon if you're modifying a
307 table with more than one LOB column.
311 sub source_bind_attributes
319 foreach my $column ($source->columns) {
320 my $data_type = $source->column_info($column)->{data_type} || '';
321 next unless $data_type;
323 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
325 if ($data_type =~ /^[BC]LOB$/i) {
326 if ($DBD::Oracle::VERSION eq '1.23') {
327 $self->throw_exception(
328 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
329 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
333 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
334 ? DBD::Oracle::ORA_CLOB()
335 : DBD::Oracle::ORA_BLOB()
337 $column_bind_attrs{'ora_field'} = $column;
340 $bind_attributes{$column} = \%column_bind_attrs;
343 return \%bind_attributes;
347 my ($self, $name) = @_;
348 $self->_get_dbh->do("SAVEPOINT $name");
351 # Oracle automatically releases a savepoint when you start another one with the
353 sub _svp_release { 1 }
356 my ($self, $name) = @_;
357 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
360 =head2 relname_to_table_alias
362 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
365 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
366 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
369 See L<DBIx::Class::Storage/"relname_to_table_alias">.
373 sub relname_to_table_alias {
375 my ($relname, $join_count) = @_;
377 my $alias = $self->next::method(@_);
379 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
382 =head2 with_deferred_fk_checks
384 Runs a coderef between:
386 alter session set constraints = deferred
388 alter session set constraints = immediate
390 to defer foreign key checks.
392 Constraints must be declared C<DEFERRABLE> for this to work.
396 sub with_deferred_fk_checks {
397 my ($self, $sub) = @_;
399 my $txn_scope_guard = $self->txn_scope_guard;
401 $self->_do_query('alter session set constraints = deferred');
403 my $sg = Scope::Guard->new(sub {
404 $self->_do_query('alter session set constraints = immediate');
408 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
413 Following additional attributes can be used in resultsets.
415 =head2 connect_by or connect_by_nocycle
419 =item Value: \%connect_by
423 A hashref of conditions used to specify the relationship between parent rows
424 and child rows of the hierarchy.
427 connect_by => { parentid => 'prior personid' }
429 # adds a connect by statement to the query:
431 # me.persionid me.firstname, me.lastname, me.parentid
435 # parentid = prior persionid
438 connect_by_nocycle => { parentid => 'prior personid' }
440 # adds a connect by statement to the query:
442 # me.persionid me.firstname, me.lastname, me.parentid
446 # parentid = prior persionid
453 =item Value: \%condition
457 A hashref of conditions which specify the root row(s) of the hierarchy.
459 It uses the same syntax as L<DBIx::Class::ResultSet/search>
461 start_with => { firstname => 'Foo', lastname => 'Bar' }
464 # me.persionid me.firstname, me.lastname, me.parentid
468 # firstname = 'foo' and lastname = 'bar'
470 # parentid = prior persionid
472 =head2 order_siblings_by
476 =item Value: ($order_siblings_by | \@order_siblings_by)
480 Which column(s) to order the siblings by.
482 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
484 'order_siblings_by' => 'firstname ASC'
487 # me.persionid me.firstname, me.lastname, me.parentid
491 # parentid = prior persionid
497 See L<DBIx::Class/CONTRIBUTORS>.
501 You may distribute this code under the same terms as Perl itself.