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' => 'firstname ASC',
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;
162 $dbh->do("select 1 from dual");
170 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
172 my $wantarray = wantarray;
174 my (@res, $exception, $retried);
180 @res = $self->next::method(@_);
182 $res[0] = $self->next::method(@_);
186 if ($exception =~ /ORA-01003/) {
187 # ORA-01003: no statement parsed (someone changed the table somehow,
188 # invalidating your cursor.)
189 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
190 delete $dbh->{CachedKids}{$sql};
194 } while (not $retried++);
197 $self->throw_exception($exception) if $exception;
199 $wantarray ? @res : $res[0]
202 =head2 get_autoinc_seq
204 Returns the sequence name for an autoincrement column
208 sub get_autoinc_seq {
209 my ($self, $source, $col) = @_;
211 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
214 =head2 columns_info_for
216 This wraps the superclass version of this method to force table
221 sub columns_info_for {
222 my ($self, $table) = @_;
224 $self->next::method($table);
227 =head2 datetime_parser_type
229 This sets the proper DateTime::Format module for use with
230 L<DBIx::Class::InflateColumn::DateTime>.
234 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
236 =head2 connect_call_datetime_setup
240 on_connect_call => 'datetime_setup'
242 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
243 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
244 necessary environment variables for L<DateTime::Format::Oracle>, which is used
247 Maximum allowable precision is used, unless the environment variables have
250 These are the defaults used:
252 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
253 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
254 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
256 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
257 for your timestamps, use something like this:
259 use Time::HiRes 'time';
260 my $ts = DateTime->from_epoch(epoch => time);
264 sub connect_call_datetime_setup {
267 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
268 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
269 'YYYY-MM-DD HH24:MI:SS.FF';
270 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
271 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
274 "alter session set nls_date_format = '$date_format'"
277 "alter session set nls_timestamp_format = '$timestamp_format'"
280 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
284 =head2 source_bind_attributes
286 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
287 with the driver assuming your input is the deprecated LONG type if you
288 encode it as a hex string. That ain't gonna fly at larger values, where
289 you'll discover you have to do what this does.
291 This method had to be overridden because we need to set ora_field to the
292 actual column, and that isn't passed to the call (provided by Storage) to
293 bind_attribute_by_data_type.
295 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
296 adding it doesn't hurt, and will save your bacon if you're modifying a
297 table with more than one LOB column.
301 sub source_bind_attributes
309 foreach my $column ($source->columns) {
310 my $data_type = $source->column_info($column)->{data_type} || '';
311 next unless $data_type;
313 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
315 if ($data_type =~ /^[BC]LOB$/i) {
316 if ($DBD::Oracle::VERSION eq '1.23') {
317 $self->throw_exception(
318 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
319 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
323 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
324 ? DBD::Oracle::ORA_CLOB()
325 : DBD::Oracle::ORA_BLOB()
327 $column_bind_attrs{'ora_field'} = $column;
330 $bind_attributes{$column} = \%column_bind_attrs;
333 return \%bind_attributes;
337 my ($self, $name) = @_;
338 $self->_get_dbh->do("SAVEPOINT $name");
341 # Oracle automatically releases a savepoint when you start another one with the
343 sub _svp_release { 1 }
346 my ($self, $name) = @_;
347 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
350 =head2 relname_to_table_alias
352 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
355 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
356 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
359 See L<DBIx::Class::Storage/"relname_to_table_alias">.
363 sub relname_to_table_alias {
365 my ($relname, $join_count) = @_;
367 my $alias = $self->next::method(@_);
369 return $alias if length($alias) <= 30;
371 # get a base64 md5 of the alias with join_count
373 my $ctx = Digest::MD5->new;
375 my $md5 = $ctx->b64digest;
377 # remove alignment mark just in case
380 # truncate and prepend to truncated relname without vowels
381 (my $devoweled = $relname) =~ s/[aeiou]//g;
382 my $shortened = substr($devoweled, 0, 18);
385 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
390 =head2 with_deferred_fk_checks
392 Runs a coderef between:
394 alter session set constraints = deferred
396 alter session set constraints = immediate
398 to defer foreign key checks.
400 Constraints must be declared C<DEFERRABLE> for this to work.
404 sub with_deferred_fk_checks {
405 my ($self, $sub) = @_;
407 my $txn_scope_guard = $self->txn_scope_guard;
409 $self->_do_query('alter session set constraints = deferred');
411 my $sg = Scope::Guard->new(sub {
412 $self->_do_query('alter session set constraints = immediate');
415 return Context::Preserve::preserve_context(sub { $sub->() },
416 after => sub { $txn_scope_guard->commit });
420 my ($self, $ident, $select, $where, $attrs) = @_;
422 my $connect_by_args = {};
423 if ( $attrs->{connect_by} || $attrs->{start_with} || $attrs->{order_siblings_by} ) {
425 connect_by => $attrs->{connect_by},
426 start_with => $attrs->{start_with},
427 order_siblings_by => $attrs->{order_siblings_by},
431 my @rv = $self->next::method($ident, $select, $where, $attrs);
433 return (@rv, $connect_by_args);
438 Following additional attributes can be used in resultsets.
444 =item Value: \%connect_by
448 A hashref of conditions used to specify the relationship between parent rows
449 and child rows of the hierarchy.
451 connect_by => { parentid => 'prior personid' }
453 # adds a connect by statement to the query:
455 # me.persionid me.firstname, me.lastname, me.parentid
459 # parentid = prior persionid
465 =item Value: \%condition
469 A hashref of conditions which specify the root row(s) of the hierarchy.
471 It uses the same syntax as L<DBIx::Class::ResultSet/search>
473 start_with => { firstname => 'Foo', lastname => 'Bar' }
476 # me.persionid me.firstname, me.lastname, me.parentid
480 # firstname = 'foo' and lastname = 'bar'
482 # parentid = prior persionid
484 =head2 order_siblings_by
488 =item Value: ($order_siblings_by | \@order_siblings_by)
492 Which column(s) to order the siblings by.
494 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
496 'order_siblings_by' => 'firstname ASC'
499 # me.persionid me.firstname, me.lastname, me.parentid
503 # parentid = prior persionid
509 See L<DBIx::Class/CONTRIBUTORS>.
513 You may distribute this code under the same terms as Perl itself.