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->quote_char;
39 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
40 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
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 my $sql_maker = $self->sql_maker;
66 if ( ref $source->name eq 'SCALAR' ) {
67 $source_name = ${$source->name};
70 $source_name = $source->name;
72 $source_name = uc($source_name) unless $sql_maker->quote_char;
74 # trigger_body is a LONG
75 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
77 # disable default bindtype
78 local $sql_maker->{bindtype} = 'normal';
80 # look up the correct sequence automatically
81 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
82 my ($sql, @bind) = $sql_maker->select (
86 $schema ? (owner => $schema) : (),
87 table_name => $table || $source_name,
88 triggering_event => 'INSERT',
92 my $sth = $dbh->prepare($sql);
93 $sth->execute (@bind);
95 while (my ($insert_trigger) = $sth->fetchrow_array) {
96 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
98 $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
101 sub _sequence_fetch {
102 my ( $self, $type, $seq ) = @_;
103 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
110 my $dbh = $self->_dbh or return 0;
112 local $dbh->{RaiseError} = 1;
115 $dbh->do("select 1 from dual");
123 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
125 my $wantarray = wantarray;
127 my (@res, $exception, $retried);
133 @res = $self->next::method(@_);
135 $res[0] = $self->next::method(@_);
139 if ($exception =~ /ORA-01003/) {
140 # ORA-01003: no statement parsed (someone changed the table somehow,
141 # invalidating your cursor.)
142 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
143 delete $dbh->{CachedKids}{$sql};
147 } while (not $retried++);
150 $self->throw_exception($exception) if $exception;
152 $wantarray ? @res : $res[0]
155 =head2 get_autoinc_seq
157 Returns the sequence name for an autoincrement column
161 sub get_autoinc_seq {
162 my ($self, $source, $col) = @_;
164 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
167 =head2 columns_info_for
169 This wraps the superclass version of this method to force table
174 sub columns_info_for {
175 my ($self, $table) = @_;
177 $self->next::method($table);
180 =head2 datetime_parser_type
182 This sets the proper DateTime::Format module for use with
183 L<DBIx::Class::InflateColumn::DateTime>.
187 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
189 =head2 connect_call_datetime_setup
193 on_connect_call => 'datetime_setup'
195 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
196 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
197 necessary environment variables for L<DateTime::Format::Oracle>, which is used
200 Maximum allowable precision is used, unless the environment variables have
203 These are the defaults used:
205 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
206 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
207 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
209 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
210 for your timestamps, use something like this:
212 use Time::HiRes 'time';
213 my $ts = DateTime->from_epoch(epoch => time);
217 sub connect_call_datetime_setup {
220 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
221 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
222 'YYYY-MM-DD HH24:MI:SS.FF';
223 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
224 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
227 "alter session set nls_date_format = '$date_format'"
230 "alter session set nls_timestamp_format = '$timestamp_format'"
233 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
237 =head2 source_bind_attributes
239 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
240 with the driver assuming your input is the deprecated LONG type if you
241 encode it as a hex string. That ain't gonna fly at larger values, where
242 you'll discover you have to do what this does.
244 This method had to be overridden because we need to set ora_field to the
245 actual column, and that isn't passed to the call (provided by Storage) to
246 bind_attribute_by_data_type.
248 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
249 adding it doesn't hurt, and will save your bacon if you're modifying a
250 table with more than one LOB column.
254 sub source_bind_attributes
262 foreach my $column ($source->columns) {
263 my $data_type = $source->column_info($column)->{data_type} || '';
264 next unless $data_type;
266 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
268 if ($data_type =~ /^[BC]LOB$/i) {
269 if ($DBD::Oracle::VERSION eq '1.23') {
270 $self->throw_exception(
271 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
272 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
276 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
277 ? DBD::Oracle::ORA_CLOB()
278 : DBD::Oracle::ORA_BLOB()
280 $column_bind_attrs{'ora_field'} = $column;
283 $bind_attributes{$column} = \%column_bind_attrs;
286 return \%bind_attributes;
290 my ($self, $name) = @_;
291 $self->_get_dbh->do("SAVEPOINT $name");
294 # Oracle automatically releases a savepoint when you start another one with the
296 sub _svp_release { 1 }
299 my ($self, $name) = @_;
300 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
303 =head2 relname_to_table_alias
305 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
308 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
309 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
312 See L<DBIx::Class::Storage/"relname_to_table_alias">.
316 sub relname_to_table_alias {
318 my ($relname, $join_count) = @_;
320 my $alias = $self->next::method(@_);
322 return $alias if length($alias) <= 30;
324 # get a base64 md5 of the alias with join_count
326 my $ctx = Digest::MD5->new;
328 my $md5 = $ctx->b64digest;
330 # remove alignment mark just in case
333 # truncate and prepend to truncated relname without vowels
334 (my $devoweled = $relname) =~ s/[aeiou]//g;
335 my $shortened = substr($devoweled, 0, 18);
338 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
343 =head2 with_deferred_fk_checks
345 Runs a coderef between:
347 alter session set constraints = deferred
349 alter session set constraints = immediate
351 to defer foreign key checks.
353 Constraints must be declared C<DEFERRABLE> for this to work.
357 sub with_deferred_fk_checks {
358 my ($self, $sub) = @_;
360 my $txn_scope_guard = $self->txn_scope_guard;
362 $self->_do_query('alter session set constraints = deferred');
364 my $sg = Scope::Guard->new(sub {
365 $self->_do_query('alter session set constraints = immediate');
368 return Context::Preserve::preserve_context(sub { $sub->() },
369 after => sub { $txn_scope_guard->commit });
374 See L<DBIx::Class/CONTRIBUTORS>.
378 You may distribute this code under the same terms as Perl itself.