1 package DBIx::Class::Storage::DBI::Oracle::Generic;
6 use Context::Preserve 'preserve_context';
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');
24 This class implements base Oracle support. The subclass
25 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
32 use base qw/DBIx::Class::Storage::DBI/;
35 sub deployment_statements {
37 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
40 my $quote_char = $self->schema->storage->sql_maker->quote_char;
41 $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
42 $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
44 my $oracle_version = try { $self->_get_dbh->get_info(18) };
46 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
48 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
51 sub _dbh_last_insert_id {
52 my ($self, $dbh, $source, @columns) = @_;
54 foreach my $col (@columns) {
55 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
56 my $id = $self->_sequence_fetch( 'currval', $seq );
62 sub _dbh_get_autoinc_seq {
63 my ($self, $dbh, $source, $col) = @_;
65 my $sql_maker = $self->sql_maker;
68 if ( ref $source->name eq 'SCALAR' ) {
69 $source_name = ${$source->name};
72 $source_name = $source->name;
74 $source_name = uc($source_name) unless $sql_maker->quote_char;
76 # trigger_body is a LONG
77 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
79 # disable default bindtype
80 local $sql_maker->{bindtype} = 'normal';
82 # look up the correct sequence automatically
83 my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
84 my ($sql, @bind) = $sql_maker->select (
88 $schema ? (owner => $schema) : (),
89 table_name => $table || $source_name,
90 triggering_event => { -like => '%INSERT%' },
94 my $sth = $dbh->prepare($sql);
95 $sth->execute (@bind);
97 while (my ($insert_trigger) = $sth->fetchrow_array) {
98 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
100 $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
103 sub _sequence_fetch {
104 my ( $self, $type, $seq ) = @_;
105 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
112 my $dbh = $self->_dbh or return 0;
114 local $dbh->{RaiseError} = 1;
115 local $dbh->{PrintError} = 0;
118 $dbh->do('select 1 from dual');
127 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
130 my $wantarray = wantarray();
131 my $next = $self->next::can;
134 my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
136 if (!defined $wantarray) {
139 elsif (! $wantarray) {
149 if (! $tried and $_ =~ /ORA-01003/) {
150 # ORA-01003: no statement parsed (someone changed the table somehow,
151 # invalidating your cursor.)
152 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
153 delete $dbh->{CachedKids}{$sql};
156 $self->throw_exception($_);
159 } while (! $tried++);
161 return $wantarray ? @res : $res[0];
164 =head2 get_autoinc_seq
166 Returns the sequence name for an autoincrement column
170 sub get_autoinc_seq {
171 my ($self, $source, $col) = @_;
173 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
176 =head2 datetime_parser_type
178 This sets the proper DateTime::Format module for use with
179 L<DBIx::Class::InflateColumn::DateTime>.
183 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
185 =head2 connect_call_datetime_setup
189 on_connect_call => 'datetime_setup'
191 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
192 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
193 and the necessary environment variables for L<DateTime::Format::Oracle>, which
196 Maximum allowable precision is used, unless the environment variables have
199 These are the defaults used:
201 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
202 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
203 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
205 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
206 for your timestamps, use something like this:
208 use Time::HiRes 'time';
209 my $ts = DateTime->from_epoch(epoch => time);
213 sub connect_call_datetime_setup {
216 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
217 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
218 'YYYY-MM-DD HH24:MI:SS.FF';
219 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
220 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
223 "alter session set nls_date_format = '$date_format'"
226 "alter session set nls_timestamp_format = '$timestamp_format'"
229 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
233 =head2 source_bind_attributes
235 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
236 with the driver assuming your input is the deprecated LONG type if you
237 encode it as a hex string. That ain't gonna fly at larger values, where
238 you'll discover you have to do what this does.
240 This method had to be overridden because we need to set ora_field to the
241 actual column, and that isn't passed to the call (provided by Storage) to
242 bind_attribute_by_data_type.
244 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
245 adding it doesn't hurt, and will save your bacon if you're modifying a
246 table with more than one LOB column.
250 sub source_bind_attributes
258 foreach my $column ($source->columns) {
259 my $data_type = $source->column_info($column)->{data_type} || '';
260 next unless $data_type;
262 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
264 if ($data_type =~ /^[BC]LOB$/i) {
265 if ($DBD::Oracle::VERSION eq '1.23') {
266 $self->throw_exception(
267 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
268 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
272 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
273 ? DBD::Oracle::ORA_CLOB()
274 : DBD::Oracle::ORA_BLOB()
276 $column_bind_attrs{'ora_field'} = $column;
279 $bind_attributes{$column} = \%column_bind_attrs;
282 return \%bind_attributes;
286 my ($self, $name) = @_;
287 $self->_get_dbh->do("SAVEPOINT $name");
290 # Oracle automatically releases a savepoint when you start another one with the
292 sub _svp_release { 1 }
295 my ($self, $name) = @_;
296 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
299 =head2 relname_to_table_alias
301 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
304 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
305 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
308 See L<DBIx::Class::Storage/"relname_to_table_alias">.
312 sub relname_to_table_alias {
314 my ($relname, $join_count) = @_;
316 my $alias = $self->next::method(@_);
318 return $alias if length($alias) <= 30;
320 # get a base64 md5 of the alias with join_count
322 my $ctx = Digest::MD5->new;
324 my $md5 = $ctx->b64digest;
326 # remove alignment mark just in case
329 # truncate and prepend to truncated relname without vowels
330 (my $devoweled = $relname) =~ s/[aeiou]//g;
331 my $shortened = substr($devoweled, 0, 18);
334 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
339 =head2 with_deferred_fk_checks
341 Runs a coderef between:
343 alter session set constraints = deferred
345 alter session set constraints = immediate
347 to defer foreign key checks.
349 Constraints must be declared C<DEFERRABLE> for this to work.
353 sub with_deferred_fk_checks {
354 my ($self, $sub) = @_;
356 my $txn_scope_guard = $self->txn_scope_guard;
358 $self->_do_query('alter session set constraints = deferred');
360 my $sg = Scope::Guard->new(sub {
361 $self->_do_query('alter session set constraints = immediate');
365 preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
370 See L<DBIx::Class/CONTRIBUTORS>.
374 You may distribute this code under the same terms as Perl itself.