1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve ();
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;
91 my $oracle_version = try { $self->_get_dbh->get_info(18) };
93 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
95 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
98 sub _dbh_last_insert_id {
99 my ($self, $dbh, $source, @columns) = @_;
101 foreach my $col (@columns) {
102 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
103 my $id = $self->_sequence_fetch( 'currval', $seq );
109 sub _dbh_get_autoinc_seq {
110 my ($self, $dbh, $source, $col) = @_;
112 my $sql_maker = $self->sql_maker;
115 if ( ref $source->name eq 'SCALAR' ) {
116 $source_name = ${$source->name};
119 $source_name = $source->name;
121 $source_name = uc($source_name) unless $sql_maker->quote_char;
123 # trigger_body is a LONG
124 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
126 # disable default bindtype
127 local $sql_maker->{bindtype} = 'normal';
129 # look up the correct sequence automatically
130 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
131 my ($sql, @bind) = $sql_maker->select (
135 $schema ? (owner => $schema) : (),
136 table_name => $table || $source_name,
137 triggering_event => { -like => '%INSERT%' },
141 my $sth = $dbh->prepare($sql);
142 $sth->execute (@bind);
144 while (my ($insert_trigger) = $sth->fetchrow_array) {
145 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
147 $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
150 sub _sequence_fetch {
151 my ( $self, $type, $seq ) = @_;
152 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
159 my $dbh = $self->_dbh or return 0;
161 local $dbh->{RaiseError} = 1;
162 local $dbh->{PrintError} = 0;
165 $dbh->do('select 1 from dual');
174 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
177 my $wantarray = wantarray();
178 my $next = $self->next::can;
181 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
183 if (!defined $wantarray) {
186 elsif (! $wantarray) {
196 if (! $tried and $_ =~ /ORA-01003/) {
197 # ORA-01003: no statement parsed (someone changed the table somehow,
198 # invalidating your cursor.)
199 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
200 delete $dbh->{CachedKids}{$sql};
203 $self->throw_exception($_);
206 } while (! $tried++);
208 return $wantarray ? @res : $res[0];
211 =head2 get_autoinc_seq
213 Returns the sequence name for an autoincrement column
217 sub get_autoinc_seq {
218 my ($self, $source, $col) = @_;
220 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
223 =head2 datetime_parser_type
225 This sets the proper DateTime::Format module for use with
226 L<DBIx::Class::InflateColumn::DateTime>.
230 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
232 =head2 connect_call_datetime_setup
236 on_connect_call => 'datetime_setup'
238 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
239 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
240 and the necessary environment variables for L<DateTime::Format::Oracle>, which
243 Maximum allowable precision is used, unless the environment variables have
246 These are the defaults used:
248 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
249 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
250 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
252 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
253 for your timestamps, use something like this:
255 use Time::HiRes 'time';
256 my $ts = DateTime->from_epoch(epoch => time);
260 sub connect_call_datetime_setup {
263 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
264 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
265 'YYYY-MM-DD HH24:MI:SS.FF';
266 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
267 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
270 "alter session set nls_date_format = '$date_format'"
273 "alter session set nls_timestamp_format = '$timestamp_format'"
276 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
280 =head2 source_bind_attributes
282 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
283 with the driver assuming your input is the deprecated LONG type if you
284 encode it as a hex string. That ain't gonna fly at larger values, where
285 you'll discover you have to do what this does.
287 This method had to be overridden because we need to set ora_field to the
288 actual column, and that isn't passed to the call (provided by Storage) to
289 bind_attribute_by_data_type.
291 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
292 adding it doesn't hurt, and will save your bacon if you're modifying a
293 table with more than one LOB column.
297 sub source_bind_attributes
305 foreach my $column ($source->columns) {
306 my $data_type = $source->column_info($column)->{data_type} || '';
307 next unless $data_type;
309 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
311 if ($data_type =~ /^[BC]LOB$/i) {
312 if ($DBD::Oracle::VERSION eq '1.23') {
313 $self->throw_exception(
314 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
315 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
319 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
320 ? DBD::Oracle::ORA_CLOB()
321 : DBD::Oracle::ORA_BLOB()
323 $column_bind_attrs{'ora_field'} = $column;
326 $bind_attributes{$column} = \%column_bind_attrs;
329 return \%bind_attributes;
333 my ($self, $name) = @_;
334 $self->_get_dbh->do("SAVEPOINT $name");
337 # Oracle automatically releases a savepoint when you start another one with the
339 sub _svp_release { 1 }
342 my ($self, $name) = @_;
343 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
346 =head2 relname_to_table_alias
348 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
351 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
352 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
355 See L<DBIx::Class::Storage/"relname_to_table_alias">.
359 sub relname_to_table_alias {
361 my ($relname, $join_count) = @_;
363 my $alias = $self->next::method(@_);
365 return $alias if length($alias) <= 30;
367 # get a base64 md5 of the alias with join_count
369 my $ctx = Digest::MD5->new;
371 my $md5 = $ctx->b64digest;
373 # remove alignment mark just in case
376 # truncate and prepend to truncated relname without vowels
377 (my $devoweled = $relname) =~ s/[aeiou]//g;
378 my $shortened = substr($devoweled, 0, 18);
381 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
386 =head2 with_deferred_fk_checks
388 Runs a coderef between:
390 alter session set constraints = deferred
392 alter session set constraints = immediate
394 to defer foreign key checks.
396 Constraints must be declared C<DEFERRABLE> for this to work.
400 sub with_deferred_fk_checks {
401 my ($self, $sub) = @_;
403 my $txn_scope_guard = $self->txn_scope_guard;
405 $self->_do_query('alter session set constraints = deferred');
407 my $sg = Scope::Guard->new(sub {
408 $self->_do_query('alter session set constraints = immediate');
411 return Context::Preserve::preserve_context(sub { $sub->() },
412 after => sub { $txn_scope_guard->commit });
417 Following additional attributes can be used in resultsets.
419 =head2 connect_by or connect_by_nocycle
423 =item Value: \%connect_by
427 A hashref of conditions used to specify the relationship between parent rows
428 and child rows of the hierarchy.
431 connect_by => { parentid => 'prior personid' }
433 # adds a connect by statement to the query:
435 # me.persionid me.firstname, me.lastname, me.parentid
439 # parentid = prior persionid
442 connect_by_nocycle => { parentid => 'prior personid' }
444 # adds a connect by statement to the query:
446 # me.persionid me.firstname, me.lastname, me.parentid
450 # parentid = prior persionid
457 =item Value: \%condition
461 A hashref of conditions which specify the root row(s) of the hierarchy.
463 It uses the same syntax as L<DBIx::Class::ResultSet/search>
465 start_with => { firstname => 'Foo', lastname => 'Bar' }
468 # me.persionid me.firstname, me.lastname, me.parentid
472 # firstname = 'foo' and lastname = 'bar'
474 # parentid = prior persionid
476 =head2 order_siblings_by
480 =item Value: ($order_siblings_by | \@order_siblings_by)
484 Which column(s) to order the siblings by.
486 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
488 'order_siblings_by' => 'firstname ASC'
491 # me.persionid me.firstname, me.lastname, me.parentid
495 # parentid = prior persionid
501 See L<DBIx::Class/CONTRIBUTORS>.
505 You may distribute this code under the same terms as Perl itself.