1 package DBIx::Class::Storage::DBI::Oracle::Generic;
8 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
12 # In your result (table) classes
13 use base 'DBIx::Class::Core';
14 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
15 __PACKAGE__->set_primary_key('id');
16 __PACKAGE__->sequence('mysequence');
20 This class implements base Oracle support. The subclass
21 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
28 use base qw/DBIx::Class::Storage::DBI/;
31 sub _dbh_last_insert_id {
32 my ($self, $dbh, $source, @columns) = @_;
34 foreach my $col (@columns) {
35 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
36 my $id = $self->_sequence_fetch( 'currval', $seq );
42 sub _dbh_get_autoinc_seq {
43 my ($self, $dbh, $source, $col) = @_;
45 my $quote_char = $self->schema->storage->{'_sql_maker_opts'}->{'quote_char'};
46 my $name_sep = $self->schema->storage->{'_sql_maker_opts'}->{'name_sep'};
48 # look up the correct sequence automatically
50 SELECT trigger_body FROM ALL_TRIGGERS t
51 WHERE t.table_name = ?
52 AND t.triggering_event = 'INSERT'
53 AND t.status = 'ENABLED'
56 # trigger_body is a LONG
57 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
62 if ( ref $source->name ne 'SCALAR' ) {
63 $source_name = $source->name;
66 $source_name = ${$source->name};
69 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
70 if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
72 SELECT trigger_body FROM ALL_TRIGGERS t
73 WHERE t.owner = ? AND t.table_name = ?
74 AND t.triggering_event = 'INSERT'
75 AND t.status = 'ENABLED'
77 $sth = $dbh->prepare($sql);
78 my $table_name = $quote_char ? "$quote_char$table$quote_char" : uc($table);
80 $sth->execute( uc($schema), $table_name );
83 $sth = $dbh->prepare($sql);
84 $sth->execute( $source_name );
86 while (my ($insert_trigger) = $sth->fetchrow_array) {
87 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
89 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
93 my ( $self, $type, $seq ) = @_;
94 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
101 my $dbh = $self->_dbh or return 0;
103 local $dbh->{RaiseError} = 1;
106 $dbh->do("select 1 from dual");
114 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
116 my $wantarray = wantarray;
118 my (@res, $exception, $retried);
124 @res = $self->next::method(@_);
126 $res[0] = $self->next::method(@_);
130 if ($exception =~ /ORA-01003/) {
131 # ORA-01003: no statement parsed (someone changed the table somehow,
132 # invalidating your cursor.)
133 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
134 delete $dbh->{CachedKids}{$sql};
138 } while (not $retried++);
141 $self->throw_exception($exception) if $exception;
143 wantarray ? @res : $res[0]
146 =head2 get_autoinc_seq
148 Returns the sequence name for an autoincrement column
152 sub get_autoinc_seq {
153 my ($self, $source, $col) = @_;
155 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
158 =head2 columns_info_for
160 This wraps the superclass version of this method to force table
165 sub columns_info_for {
166 my ($self, $table) = @_;
168 $self->next::method(uc($table));
171 =head2 datetime_parser_type
173 This sets the proper DateTime::Format module for use with
174 L<DBIx::Class::InflateColumn::DateTime>.
178 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
180 =head2 connect_call_datetime_setup
184 on_connect_call => 'datetime_setup'
186 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
187 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
188 necessary environment variables for L<DateTime::Format::Oracle>, which is used
191 Maximum allowable precision is used, unless the environment variables have
194 These are the defaults used:
196 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
197 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
198 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
200 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
201 for your timestamps, use something like this:
203 use Time::HiRes 'time';
204 my $ts = DateTime->from_epoch(epoch => time);
208 sub connect_call_datetime_setup {
211 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
212 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
213 'YYYY-MM-DD HH24:MI:SS.FF';
214 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
215 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
218 "alter session set nls_date_format = '$date_format'"
221 "alter session set nls_timestamp_format = '$timestamp_format'"
224 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
228 =head2 source_bind_attributes
230 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
231 with the driver assuming your input is the deprecated LONG type if you
232 encode it as a hex string. That ain't gonna fly at larger values, where
233 you'll discover you have to do what this does.
235 This method had to be overridden because we need to set ora_field to the
236 actual column, and that isn't passed to the call (provided by Storage) to
237 bind_attribute_by_data_type.
239 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
240 adding it doesn't hurt, and will save your bacon if you're modifying a
241 table with more than one LOB column.
245 sub source_bind_attributes
253 foreach my $column ($source->columns) {
254 my $data_type = $source->column_info($column)->{data_type} || '';
255 next unless $data_type;
257 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
259 if ($data_type =~ /^[BC]LOB$/i) {
260 if ($DBD::Oracle::VERSION eq '1.23') {
261 $self->throw_exception(
262 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
263 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
267 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
268 ? DBD::Oracle::ORA_CLOB()
269 : DBD::Oracle::ORA_BLOB()
271 $column_bind_attrs{'ora_field'} = $column;
274 $bind_attributes{$column} = \%column_bind_attrs;
277 return \%bind_attributes;
281 my ($self, $name) = @_;
282 $self->_get_dbh->do("SAVEPOINT $name");
285 # Oracle automatically releases a savepoint when you start another one with the
287 sub _svp_release { 1 }
290 my ($self, $name) = @_;
291 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
294 =head2 relname_to_table_alias
296 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
299 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
300 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
303 See L<DBIx::Class::Storage/"relname_to_table_alias">.
307 sub relname_to_table_alias {
309 my ($relname, $join_count) = @_;
311 my $alias = $self->next::method(@_);
313 return $alias if length($alias) <= 30;
315 # get a base64 md5 of the alias with join_count
317 my $ctx = Digest::MD5->new;
319 my $md5 = $ctx->b64digest;
321 # remove alignment mark just in case
324 # truncate and prepend to truncated relname without vowels
325 (my $devoweled = $relname) =~ s/[aeiou]//g;
326 my $shortened = substr($devoweled, 0, 18);
329 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
336 See L<DBIx::Class/CONTRIBUTORS>.
340 You may distribute this code under the same terms as Perl itself.