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');
22 This class implements base Oracle support. The subclass
23 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
30 use base qw/DBIx::Class::Storage::DBI/;
33 sub deployment_statements {
35 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
38 my $quote_char = $self->schema->storage->{'_sql_maker_opts'}->{'quote_char'};
39 $sqltargs->{quote_table_names} = 0 unless $quote_char;
40 $sqltargs->{quote_field_names} = 0 unless $quote_char;
42 my $oracle_version = eval { $self->_get_dbh->get_info(18) };
44 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
46 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
49 sub _dbh_last_insert_id {
50 my ($self, $dbh, $source, @columns) = @_;
52 foreach my $col (@columns) {
53 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
54 my $id = $self->_sequence_fetch( 'currval', $seq );
60 sub _dbh_get_autoinc_seq {
61 my ($self, $dbh, $source, $col) = @_;
63 # look up the correct sequence automatically
65 SELECT trigger_body FROM ALL_TRIGGERS t
66 WHERE t.table_name = ?
67 AND t.triggering_event = 'INSERT'
68 AND t.status = 'ENABLED'
71 # trigger_body is a LONG
72 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
77 if ( ref $source->name ne 'SCALAR' ) {
78 $source_name = $source->name;
81 $source_name = ${$source->name};
84 unless ($self->schema->storage->{'_sql_maker_opts'}->{'quote_char'}) {
85 $source_name = uc($source_name);
88 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
89 if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
91 SELECT trigger_body FROM ALL_TRIGGERS t
92 WHERE t.owner = ? AND t.table_name = ?
93 AND t.triggering_event = 'INSERT'
94 AND t.status = 'ENABLED'
96 $sth = $dbh->prepare($sql);
97 my $table_name = $self -> sql_maker -> _quote($table);
98 my $schema_name = $self -> sql_maker -> _quote($schema);
100 $sth->execute( $schema_name, $table_name );
103 $sth = $dbh->prepare($sql);
104 $sth->execute( $source_name );
106 while (my ($insert_trigger) = $sth->fetchrow_array) {
107 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
109 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
112 sub _sequence_fetch {
113 my ( $self, $type, $seq ) = @_;
114 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
121 my $dbh = $self->_dbh or return 0;
123 local $dbh->{RaiseError} = 1;
126 $dbh->do("select 1 from dual");
134 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
136 my $wantarray = wantarray;
138 my (@res, $exception, $retried);
144 @res = $self->next::method(@_);
146 $res[0] = $self->next::method(@_);
150 if ($exception =~ /ORA-01003/) {
151 # ORA-01003: no statement parsed (someone changed the table somehow,
152 # invalidating your cursor.)
153 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
154 delete $dbh->{CachedKids}{$sql};
158 } while (not $retried++);
161 $self->throw_exception($exception) if $exception;
163 wantarray ? @res : $res[0]
166 =head2 get_autoinc_seq
168 Returns the sequence name for an autoincrement column
172 sub get_autoinc_seq {
173 my ($self, $source, $col) = @_;
175 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
178 =head2 columns_info_for
180 This wraps the superclass version of this method to force table
185 sub columns_info_for {
186 my ($self, $table) = @_;
188 $self->next::method($table);
191 =head2 datetime_parser_type
193 This sets the proper DateTime::Format module for use with
194 L<DBIx::Class::InflateColumn::DateTime>.
198 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
200 =head2 connect_call_datetime_setup
204 on_connect_call => 'datetime_setup'
206 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
207 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
208 necessary environment variables for L<DateTime::Format::Oracle>, which is used
211 Maximum allowable precision is used, unless the environment variables have
214 These are the defaults used:
216 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
217 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
218 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
220 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
221 for your timestamps, use something like this:
223 use Time::HiRes 'time';
224 my $ts = DateTime->from_epoch(epoch => time);
228 sub connect_call_datetime_setup {
231 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
232 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
233 'YYYY-MM-DD HH24:MI:SS.FF';
234 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
235 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
238 "alter session set nls_date_format = '$date_format'"
241 "alter session set nls_timestamp_format = '$timestamp_format'"
244 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
248 =head2 source_bind_attributes
250 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
251 with the driver assuming your input is the deprecated LONG type if you
252 encode it as a hex string. That ain't gonna fly at larger values, where
253 you'll discover you have to do what this does.
255 This method had to be overridden because we need to set ora_field to the
256 actual column, and that isn't passed to the call (provided by Storage) to
257 bind_attribute_by_data_type.
259 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
260 adding it doesn't hurt, and will save your bacon if you're modifying a
261 table with more than one LOB column.
265 sub source_bind_attributes
273 foreach my $column ($source->columns) {
274 my $data_type = $source->column_info($column)->{data_type} || '';
275 next unless $data_type;
277 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
279 if ($data_type =~ /^[BC]LOB$/i) {
280 if ($DBD::Oracle::VERSION eq '1.23') {
281 $self->throw_exception(
282 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
283 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
287 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
288 ? DBD::Oracle::ORA_CLOB()
289 : DBD::Oracle::ORA_BLOB()
291 $column_bind_attrs{'ora_field'} = $column;
294 $bind_attributes{$column} = \%column_bind_attrs;
297 return \%bind_attributes;
301 my ($self, $name) = @_;
302 $self->_get_dbh->do("SAVEPOINT $name");
305 # Oracle automatically releases a savepoint when you start another one with the
307 sub _svp_release { 1 }
310 my ($self, $name) = @_;
311 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
314 =head2 relname_to_table_alias
316 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
319 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
320 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
323 See L<DBIx::Class::Storage/"relname_to_table_alias">.
327 sub relname_to_table_alias {
329 my ($relname, $join_count) = @_;
331 my $alias = $self->next::method(@_);
333 return $alias if length($alias) <= 30;
335 # get a base64 md5 of the alias with join_count
337 my $ctx = Digest::MD5->new;
339 my $md5 = $ctx->b64digest;
341 # remove alignment mark just in case
344 # truncate and prepend to truncated relname without vowels
345 (my $devoweled = $relname) =~ s/[aeiou]//g;
346 my $shortened = substr($devoweled, 0, 18);
349 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
354 =head2 with_deferred_fk_checks
356 Runs a coderef between:
358 alter session set constraints = deferred
360 alter session set constraints = immediate
362 to defer foreign key checks.
364 Constraints must be declared C<DEFERRABLE> for this to work.
368 sub with_deferred_fk_checks {
369 my ($self, $sub) = @_;
371 my $txn_scope_guard = $self->txn_scope_guard;
373 $self->_do_query('alter session set constraints = deferred');
375 my $sg = Scope::Guard->new(sub {
376 $self->_do_query('alter session set constraints = immediate');
379 return Context::Preserve::preserve_context(sub { $sub->() },
380 after => sub { $txn_scope_guard->commit });
385 See L<DBIx::Class/CONTRIBUTORS>.
389 You may distribute this code under the same terms as Perl itself.