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 # look up the correct sequence automatically
47 SELECT trigger_body FROM ALL_TRIGGERS t
48 WHERE t.table_name = ?
49 AND t.triggering_event = 'INSERT'
50 AND t.status = 'ENABLED'
53 # trigger_body is a LONG
54 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
59 if ( ref $source->name ne 'SCALAR' ) {
60 $source_name = $source->name;
63 $source_name = ${$source->name};
66 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
67 if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
69 SELECT trigger_body FROM ALL_TRIGGERS t
70 WHERE t.owner = ? AND t.table_name = ?
71 AND t.triggering_event = 'INSERT'
72 AND t.status = 'ENABLED'
74 $sth = $dbh->prepare($sql);
75 $sth->execute( uc($schema), uc($table) );
78 $sth = $dbh->prepare($sql);
79 $sth->execute( uc( $source_name ) );
81 while (my ($insert_trigger) = $sth->fetchrow_array) {
82 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
84 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
88 my ( $self, $type, $seq ) = @_;
89 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
96 my $dbh = $self->_dbh or return 0;
98 local $dbh->{RaiseError} = 1;
101 $dbh->do("select 1 from dual");
109 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
111 my $wantarray = wantarray;
113 my (@res, $exception, $retried);
119 @res = $self->next::method(@_);
121 $res[0] = $self->next::method(@_);
125 if ($exception =~ /ORA-01003/) {
126 # ORA-01003: no statement parsed (someone changed the table somehow,
127 # invalidating your cursor.)
128 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
129 delete $dbh->{CachedKids}{$sql};
133 } while (not $retried++);
136 $self->throw_exception($exception) if $exception;
138 wantarray ? @res : $res[0]
141 =head2 get_autoinc_seq
143 Returns the sequence name for an autoincrement column
147 sub get_autoinc_seq {
148 my ($self, $source, $col) = @_;
150 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
153 =head2 columns_info_for
155 This wraps the superclass version of this method to force table
160 sub columns_info_for {
161 my ($self, $table) = @_;
163 $self->next::method(uc($table));
166 =head2 datetime_parser_type
168 This sets the proper DateTime::Format module for use with
169 L<DBIx::Class::InflateColumn::DateTime>.
173 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
175 =head2 connect_call_datetime_setup
179 on_connect_call => 'datetime_setup'
181 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
182 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
183 necessary environment variables for L<DateTime::Format::Oracle>, which is used
186 Maximum allowable precision is used, unless the environment variables have
189 These are the defaults used:
191 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
192 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
193 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
195 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
196 for your timestamps, use something like this:
198 use Time::HiRes 'time';
199 my $ts = DateTime->from_epoch(epoch => time);
203 sub connect_call_datetime_setup {
206 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
207 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
208 'YYYY-MM-DD HH24:MI:SS.FF';
209 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
210 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
212 $self->_do_query("alter session set nls_date_format = '$date_format'");
214 "alter session set nls_timestamp_format = '$timestamp_format'");
216 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
219 =head2 source_bind_attributes
221 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
222 with the driver assuming your input is the deprecated LONG type if you
223 encode it as a hex string. That ain't gonna fly at larger values, where
224 you'll discover you have to do what this does.
226 This method had to be overridden because we need to set ora_field to the
227 actual column, and that isn't passed to the call (provided by Storage) to
228 bind_attribute_by_data_type.
230 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
231 adding it doesn't hurt, and will save your bacon if you're modifying a
232 table with more than one LOB column.
236 sub source_bind_attributes
244 foreach my $column ($source->columns) {
245 my $data_type = $source->column_info($column)->{data_type} || '';
246 next unless $data_type;
248 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
250 if ($data_type =~ /^[BC]LOB$/i) {
251 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
252 DBD::Oracle::ORA_CLOB() :
253 DBD::Oracle::ORA_BLOB();
254 $column_bind_attrs{'ora_field'} = $column;
257 $bind_attributes{$column} = \%column_bind_attrs;
260 return \%bind_attributes;
264 my ($self, $name) = @_;
266 $self->_get_dbh->do("SAVEPOINT $name");
269 # Oracle automatically releases a savepoint when you start another one with the
271 sub _svp_release { 1 }
274 my ($self, $name) = @_;
276 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
279 =head2 relname_to_table_alias
281 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
284 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
285 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
288 See L<DBIx::Class::Storage/"relname_to_table_alias">.
292 sub relname_to_table_alias {
294 my ($relname, $join_count) = @_;
296 my $alias = $self->next::method(@_);
298 return $alias if length($alias) <= 30;
300 # get a base64 md5 of the alias with join_count
302 my $ctx = Digest::MD5->new;
304 my $md5 = $ctx->b64digest;
306 # remove alignment mark just in case
309 # truncate and prepend to truncated relname without vowels
310 (my $devoweled = $relname) =~ s/[aeiou]//g;
311 my $shortened = substr($devoweled, 0, 18);
314 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
321 See L<DBIx::Class/CONTRIBUTORS>.
325 You may distribute this code under the same terms as Perl itself.