1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve ();
10 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
14 # In your result (table) classes
15 use base 'DBIx::Class::Core';
16 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
17 __PACKAGE__->set_primary_key('id');
18 __PACKAGE__->sequence('mysequence');
20 # Somewhere in your Code
21 # add some data to a table with a hierarchical relationship
22 $schema->resultset('Person')->create ({
27 firstname => 'child1',
31 firstname => 'grandchild',
37 firstname => 'child2',
43 # select from the hierarchical relationship
44 my $rs = $schema->resultset('Person')->search({},
46 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
47 'connect_by' => { 'parentid' => { '-prior' => \'persionid' },
48 'order_siblings_by' => { -asc => 'name' },
52 # this will select the whole tree starting from person "foo bar", creating
55 # me.persionid me.firstname, me.lastname, me.parentid
59 # firstname = 'foo' and lastname = 'bar'
61 # parentid = prior persionid
67 This class implements base Oracle support. The subclass
68 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
75 use base qw/DBIx::Class::Storage::DBI/;
78 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
80 sub deployment_statements {
82 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
85 my $quote_char = $self->schema->storage->sql_maker->quote_char;
86 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
87 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
89 my $oracle_version = eval { $self->_get_dbh->get_info(18) };
91 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
93 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
96 sub _dbh_last_insert_id {
97 my ($self, $dbh, $source, @columns) = @_;
99 foreach my $col (@columns) {
100 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
101 my $id = $self->_sequence_fetch( 'currval', $seq );
107 sub _dbh_get_autoinc_seq {
108 my ($self, $dbh, $source, $col) = @_;
110 my $sql_maker = $self->sql_maker;
113 if ( ref $source->name eq 'SCALAR' ) {
114 $source_name = ${$source->name};
117 $source_name = $source->name;
119 $source_name = uc($source_name) unless $sql_maker->quote_char;
121 # trigger_body is a LONG
122 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
124 # disable default bindtype
125 local $sql_maker->{bindtype} = 'normal';
127 # look up the correct sequence automatically
128 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
129 my ($sql, @bind) = $sql_maker->select (
133 $schema ? (owner => $schema) : (),
134 table_name => $table || $source_name,
135 triggering_event => 'INSERT',
139 my $sth = $dbh->prepare($sql);
140 $sth->execute (@bind);
142 while (my ($insert_trigger) = $sth->fetchrow_array) {
143 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
145 $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
148 sub _sequence_fetch {
149 my ( $self, $type, $seq ) = @_;
150 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
157 my $dbh = $self->_dbh or return 0;
159 local $dbh->{RaiseError} = 1;
160 local $dbh->{PrintError} = 0;
163 $dbh->do('select 1 from dual');
171 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
173 my $wantarray = wantarray;
175 my (@res, $exception, $retried);
181 @res = $self->next::method(@_);
183 $res[0] = $self->next::method(@_);
187 if ($exception =~ /ORA-01003/) {
188 # ORA-01003: no statement parsed (someone changed the table somehow,
189 # invalidating your cursor.)
190 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
191 delete $dbh->{CachedKids}{$sql};
195 } while (not $retried++);
198 $self->throw_exception($exception) if $exception;
200 $wantarray ? @res : $res[0]
203 =head2 get_autoinc_seq
205 Returns the sequence name for an autoincrement column
209 sub get_autoinc_seq {
210 my ($self, $source, $col) = @_;
212 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
215 =head2 columns_info_for
217 This wraps the superclass version of this method to force table
222 sub columns_info_for {
223 my ($self, $table) = @_;
225 $self->next::method($table);
228 =head2 datetime_parser_type
230 This sets the proper DateTime::Format module for use with
231 L<DBIx::Class::InflateColumn::DateTime>.
235 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
237 =head2 connect_call_datetime_setup
241 on_connect_call => 'datetime_setup'
243 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
244 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
245 and the necessary environment variables for L<DateTime::Format::Oracle>, which
248 Maximum allowable precision is used, unless the environment variables have
251 These are the defaults used:
253 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
254 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
255 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
257 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
258 for your timestamps, use something like this:
260 use Time::HiRes 'time';
261 my $ts = DateTime->from_epoch(epoch => time);
265 sub connect_call_datetime_setup {
268 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
269 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
270 'YYYY-MM-DD HH24:MI:SS.FF';
271 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
272 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
275 "alter session set nls_date_format = '$date_format'"
278 "alter session set nls_timestamp_format = '$timestamp_format'"
281 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
285 =head2 source_bind_attributes
287 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
288 with the driver assuming your input is the deprecated LONG type if you
289 encode it as a hex string. That ain't gonna fly at larger values, where
290 you'll discover you have to do what this does.
292 This method had to be overridden because we need to set ora_field to the
293 actual column, and that isn't passed to the call (provided by Storage) to
294 bind_attribute_by_data_type.
296 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
297 adding it doesn't hurt, and will save your bacon if you're modifying a
298 table with more than one LOB column.
302 sub source_bind_attributes
310 foreach my $column ($source->columns) {
311 my $data_type = $source->column_info($column)->{data_type} || '';
312 next unless $data_type;
314 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
316 if ($data_type =~ /^[BC]LOB$/i) {
317 if ($DBD::Oracle::VERSION eq '1.23') {
318 $self->throw_exception(
319 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
320 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
324 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
325 ? DBD::Oracle::ORA_CLOB()
326 : DBD::Oracle::ORA_BLOB()
328 $column_bind_attrs{'ora_field'} = $column;
331 $bind_attributes{$column} = \%column_bind_attrs;
334 return \%bind_attributes;
338 my ($self, $name) = @_;
339 $self->_get_dbh->do("SAVEPOINT $name");
342 # Oracle automatically releases a savepoint when you start another one with the
344 sub _svp_release { 1 }
347 my ($self, $name) = @_;
348 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
351 =head2 relname_to_table_alias
353 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
356 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
357 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
360 See L<DBIx::Class::Storage/"relname_to_table_alias">.
364 sub relname_to_table_alias {
366 my ($relname, $join_count) = @_;
368 my $alias = $self->next::method(@_);
370 return $alias if length($alias) <= 30;
372 # get a base64 md5 of the alias with join_count
374 my $ctx = Digest::MD5->new;
376 my $md5 = $ctx->b64digest;
378 # remove alignment mark just in case
381 # truncate and prepend to truncated relname without vowels
382 (my $devoweled = $relname) =~ s/[aeiou]//g;
383 my $shortened = substr($devoweled, 0, 18);
386 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
391 =head2 with_deferred_fk_checks
393 Runs a coderef between:
395 alter session set constraints = deferred
397 alter session set constraints = immediate
399 to defer foreign key checks.
401 Constraints must be declared C<DEFERRABLE> for this to work.
405 sub with_deferred_fk_checks {
406 my ($self, $sub) = @_;
408 my $txn_scope_guard = $self->txn_scope_guard;
410 $self->_do_query('alter session set constraints = deferred');
412 my $sg = Scope::Guard->new(sub {
413 $self->_do_query('alter session set constraints = immediate');
416 return Context::Preserve::preserve_context(sub { $sub->() },
417 after => sub { $txn_scope_guard->commit });
422 Following additional attributes can be used in resultsets.
428 =item Value: \%connect_by
432 A hashref of conditions used to specify the relationship between parent rows
433 and child rows of the hierarchy.
435 connect_by => { parentid => 'prior personid' }
437 # adds a connect by statement to the query:
439 # me.persionid me.firstname, me.lastname, me.parentid
443 # parentid = prior persionid
445 =head2 connect_by_nocycle
453 If you want to use NOCYCLE set to 1.
455 connect_by => { parentid => 'prior personid' },
456 connect_by_nocycle => 1
458 # adds a connect by statement to the query:
460 # me.persionid me.firstname, me.lastname, me.parentid
464 # parentid = prior persionid
471 =item Value: \%condition
475 A hashref of conditions which specify the root row(s) of the hierarchy.
477 It uses the same syntax as L<DBIx::Class::ResultSet/search>
479 start_with => { firstname => 'Foo', lastname => 'Bar' }
482 # me.persionid me.firstname, me.lastname, me.parentid
486 # firstname = 'foo' and lastname = 'bar'
488 # parentid = prior persionid
490 =head2 order_siblings_by
494 =item Value: ($order_siblings_by | \@order_siblings_by)
498 Which column(s) to order the siblings by.
500 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
502 'order_siblings_by' => 'firstname ASC'
505 # me.persionid me.firstname, me.lastname, me.parentid
509 # parentid = prior persionid
515 See L<DBIx::Class/CONTRIBUTORS>.
519 You may distribute this code under the same terms as Perl itself.