1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve 'preserve_context';
12 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
16 # In your result (table) classes
17 use base 'DBIx::Class::Core';
18 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
19 __PACKAGE__->set_primary_key('id');
20 __PACKAGE__->sequence('mysequence');
22 # Somewhere in your Code
23 # add some data to a table with a hierarchical relationship
24 $schema->resultset('Person')->create ({
29 firstname => 'child1',
33 firstname => 'grandchild',
39 firstname => 'child2',
45 # select from the hierarchical relationship
46 my $rs = $schema->resultset('Person')->search({},
48 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
49 'connect_by' => { 'parentid' => { '-prior' => \'persionid' },
50 'order_siblings_by' => { -asc => 'name' },
54 # this will select the whole tree starting from person "foo bar", creating
57 # me.persionid me.firstname, me.lastname, me.parentid
61 # firstname = 'foo' and lastname = 'bar'
63 # parentid = prior persionid
69 This class implements base Oracle support. The subclass
70 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
77 use base qw/DBIx::Class::Storage::DBI/;
80 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
82 sub deployment_statements {
84 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
87 my $quote_char = $self->schema->storage->sql_maker->quote_char;
88 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
89 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
92 ! exists $sqltargs->{producer_args}{oracle_version}
94 my $dver = $self->_server_info->{dbms_version}
96 $sqltargs->{producer_args}{oracle_version} = $dver;
99 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
102 sub _dbh_last_insert_id {
103 my ($self, $dbh, $source, @columns) = @_;
105 foreach my $col (@columns) {
106 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
107 my $id = $self->_sequence_fetch( 'currval', $seq );
113 sub _dbh_get_autoinc_seq {
114 my ($self, $dbh, $source, $col) = @_;
116 my $sql_maker = $self->sql_maker;
119 if ( ref $source->name eq 'SCALAR' ) {
120 $source_name = ${$source->name};
123 $source_name = $source->name;
125 $source_name = uc($source_name) unless $sql_maker->quote_char;
127 # trigger_body is a LONG
128 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
130 # disable default bindtype
131 local $sql_maker->{bindtype} = 'normal';
133 # look up the correct sequence automatically
134 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
135 my ($sql, @bind) = $sql_maker->select (
137 ['trigger_body', 'table_owner'],
139 $schema ? (owner => $schema) : (),
140 table_name => $table || $source_name,
141 triggering_event => { -like => '%INSERT%' },
145 my $sth = $dbh->prepare($sql);
146 $sth->execute (@bind);
148 while (my ($insert_trigger, $schema) = $sth->fetchrow_array) {
149 my ($seq_name) = $insert_trigger =~ m!("?[.\w]+"?)\.nextval!i;
151 next unless $seq_name;
153 if ($seq_name !~ /\./) {
154 $seq_name = "${schema}.${seq_name}";
159 $self->throw_exception("Unable to find a sequence %INSERT% trigger on table '$source_name'.");
162 sub _sequence_fetch {
163 my ( $self, $type, $seq ) = @_;
164 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
171 my $dbh = $self->_dbh or return 0;
173 local $dbh->{RaiseError} = 1;
174 local $dbh->{PrintError} = 0;
177 $dbh->do('select 1 from dual');
186 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
189 my $wantarray = wantarray();
190 my $next = $self->next::can;
193 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
195 if (!defined $wantarray) {
198 elsif (! $wantarray) {
208 if (! $tried and $_ =~ /ORA-01003/) {
209 # ORA-01003: no statement parsed (someone changed the table somehow,
210 # invalidating your cursor.)
211 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
212 delete $dbh->{CachedKids}{$sql};
215 $self->throw_exception($_);
218 } while (! $tried++);
220 return $wantarray ? @res : $res[0];
223 =head2 get_autoinc_seq
225 Returns the sequence name for an autoincrement column
229 sub get_autoinc_seq {
230 my ($self, $source, $col) = @_;
232 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
235 =head2 datetime_parser_type
237 This sets the proper DateTime::Format module for use with
238 L<DBIx::Class::InflateColumn::DateTime>.
242 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
244 =head2 connect_call_datetime_setup
248 on_connect_call => 'datetime_setup'
250 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
251 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
252 and the necessary environment variables for L<DateTime::Format::Oracle>, which
255 Maximum allowable precision is used, unless the environment variables have
258 These are the defaults used:
260 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
261 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
262 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
264 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
265 for your timestamps, use something like this:
267 use Time::HiRes 'time';
268 my $ts = DateTime->from_epoch(epoch => time);
272 sub connect_call_datetime_setup {
275 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
276 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
277 'YYYY-MM-DD HH24:MI:SS.FF';
278 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
279 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
282 "alter session set nls_date_format = '$date_format'"
285 "alter session set nls_timestamp_format = '$timestamp_format'"
288 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
292 =head2 source_bind_attributes
294 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
295 with the driver assuming your input is the deprecated LONG type if you
296 encode it as a hex string. That ain't gonna fly at larger values, where
297 you'll discover you have to do what this does.
299 This method had to be overridden because we need to set ora_field to the
300 actual column, and that isn't passed to the call (provided by Storage) to
301 bind_attribute_by_data_type.
303 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
304 adding it doesn't hurt, and will save your bacon if you're modifying a
305 table with more than one LOB column.
309 sub source_bind_attributes
317 foreach my $column ($source->columns) {
318 my $data_type = $source->column_info($column)->{data_type} || '';
319 next unless $data_type;
321 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
323 if ($data_type =~ /^[BC]LOB$/i) {
324 if ($DBD::Oracle::VERSION eq '1.23') {
325 $self->throw_exception(
326 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
327 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
331 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
332 ? DBD::Oracle::ORA_CLOB()
333 : DBD::Oracle::ORA_BLOB()
335 $column_bind_attrs{'ora_field'} = $column;
338 $bind_attributes{$column} = \%column_bind_attrs;
341 return \%bind_attributes;
345 my ($self, $name) = @_;
346 $self->_get_dbh->do("SAVEPOINT $name");
349 # Oracle automatically releases a savepoint when you start another one with the
351 sub _svp_release { 1 }
354 my ($self, $name) = @_;
355 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
358 =head2 relname_to_table_alias
360 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
363 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
364 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
367 See L<DBIx::Class::Storage/"relname_to_table_alias">.
371 sub relname_to_table_alias {
373 my ($relname, $join_count) = @_;
375 my $alias = $self->next::method(@_);
377 return $self->sql_maker->_shorten_identifier($alias, [$relname]);
380 =head2 with_deferred_fk_checks
382 Runs a coderef between:
384 alter session set constraints = deferred
386 alter session set constraints = immediate
388 to defer foreign key checks.
390 Constraints must be declared C<DEFERRABLE> for this to work.
394 sub with_deferred_fk_checks {
395 my ($self, $sub) = @_;
397 my $txn_scope_guard = $self->txn_scope_guard;
399 $self->_do_query('alter session set constraints = deferred');
401 my $sg = Scope::Guard->new(sub {
402 $self->_do_query('alter session set constraints = immediate');
406 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
411 Following additional attributes can be used in resultsets.
413 =head2 connect_by or connect_by_nocycle
417 =item Value: \%connect_by
421 A hashref of conditions used to specify the relationship between parent rows
422 and child rows of the hierarchy.
425 connect_by => { parentid => 'prior personid' }
427 # adds a connect by statement to the query:
429 # me.persionid me.firstname, me.lastname, me.parentid
433 # parentid = prior persionid
436 connect_by_nocycle => { parentid => 'prior personid' }
438 # adds a connect by statement to the query:
440 # me.persionid me.firstname, me.lastname, me.parentid
444 # parentid = prior persionid
451 =item Value: \%condition
455 A hashref of conditions which specify the root row(s) of the hierarchy.
457 It uses the same syntax as L<DBIx::Class::ResultSet/search>
459 start_with => { firstname => 'Foo', lastname => 'Bar' }
462 # me.persionid me.firstname, me.lastname, me.parentid
466 # firstname = 'foo' and lastname = 'bar'
468 # parentid = prior persionid
470 =head2 order_siblings_by
474 =item Value: ($order_siblings_by | \@order_siblings_by)
478 Which column(s) to order the siblings by.
480 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
482 'order_siblings_by' => 'firstname ASC'
485 # me.persionid me.firstname, me.lastname, me.parentid
489 # parentid = prior persionid
495 See L<DBIx::Class/CONTRIBUTORS>.
499 You may distribute this code under the same terms as Perl itself.