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 deployment_statements {
33 my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
36 my $quote_char = $self->schema->storage->{'_sql_maker_opts'}->{'quote_char'};
37 $sqltargs->{quote_table_names} = 0 unless $quote_char;
38 $sqltargs->{quote_field_names} = 0 unless $quote_char;
40 my $oracle_version = eval { $self->_get_dbh->get_info(18) };
42 $sqltargs->{producer_args}{oracle_version} = $oracle_version;
44 $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
47 sub _dbh_last_insert_id {
48 my ($self, $dbh, $source, @columns) = @_;
50 foreach my $col (@columns) {
51 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
52 my $id = $self->_sequence_fetch( 'currval', $seq );
58 sub _dbh_get_autoinc_seq {
59 my ($self, $dbh, $source, $col) = @_;
61 # look up the correct sequence automatically
63 SELECT trigger_body FROM ALL_TRIGGERS t
64 WHERE t.table_name = ?
65 AND t.triggering_event = 'INSERT'
66 AND t.status = 'ENABLED'
69 # trigger_body is a LONG
70 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
75 if ( ref $source->name ne 'SCALAR' ) {
76 $source_name = $source->name;
79 $source_name = ${$source->name};
82 unless ($self->schema->storage->{'_sql_maker_opts'}->{'quote_char'}) {
83 $source_name = uc($source_name);
86 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
87 if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
89 SELECT trigger_body FROM ALL_TRIGGERS t
90 WHERE t.owner = ? AND t.table_name = ?
91 AND t.triggering_event = 'INSERT'
92 AND t.status = 'ENABLED'
94 $sth = $dbh->prepare($sql);
95 my $table_name = $self -> sql_maker -> _quote($table);
96 my $schema_name = $self -> sql_maker -> _quote($schema);
98 $sth->execute( $schema_name, $table_name );
101 $sth = $dbh->prepare($sql);
102 $sth->execute( $source_name );
104 while (my ($insert_trigger) = $sth->fetchrow_array) {
105 return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
107 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
110 sub _sequence_fetch {
111 my ( $self, $type, $seq ) = @_;
112 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
119 my $dbh = $self->_dbh or return 0;
121 local $dbh->{RaiseError} = 1;
124 $dbh->do("select 1 from dual");
132 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
134 my $wantarray = wantarray;
136 my (@res, $exception, $retried);
142 @res = $self->next::method(@_);
144 $res[0] = $self->next::method(@_);
148 if ($exception =~ /ORA-01003/) {
149 # ORA-01003: no statement parsed (someone changed the table somehow,
150 # invalidating your cursor.)
151 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
152 delete $dbh->{CachedKids}{$sql};
156 } while (not $retried++);
159 $self->throw_exception($exception) if $exception;
161 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 columns_info_for
178 This wraps the superclass version of this method to force table
183 sub columns_info_for {
184 my ($self, $table) = @_;
186 $self->next::method($table);
189 =head2 datetime_parser_type
191 This sets the proper DateTime::Format module for use with
192 L<DBIx::Class::InflateColumn::DateTime>.
196 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
198 =head2 connect_call_datetime_setup
202 on_connect_call => 'datetime_setup'
204 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
205 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
206 necessary environment variables for L<DateTime::Format::Oracle>, which is used
209 Maximum allowable precision is used, unless the environment variables have
212 These are the defaults used:
214 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
215 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
216 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
218 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
219 for your timestamps, use something like this:
221 use Time::HiRes 'time';
222 my $ts = DateTime->from_epoch(epoch => time);
226 sub connect_call_datetime_setup {
229 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
230 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
231 'YYYY-MM-DD HH24:MI:SS.FF';
232 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
233 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
236 "alter session set nls_date_format = '$date_format'"
239 "alter session set nls_timestamp_format = '$timestamp_format'"
242 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
246 =head2 source_bind_attributes
248 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
249 with the driver assuming your input is the deprecated LONG type if you
250 encode it as a hex string. That ain't gonna fly at larger values, where
251 you'll discover you have to do what this does.
253 This method had to be overridden because we need to set ora_field to the
254 actual column, and that isn't passed to the call (provided by Storage) to
255 bind_attribute_by_data_type.
257 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
258 adding it doesn't hurt, and will save your bacon if you're modifying a
259 table with more than one LOB column.
263 sub source_bind_attributes
271 foreach my $column ($source->columns) {
272 my $data_type = $source->column_info($column)->{data_type} || '';
273 next unless $data_type;
275 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
277 if ($data_type =~ /^[BC]LOB$/i) {
278 if ($DBD::Oracle::VERSION eq '1.23') {
279 $self->throw_exception(
280 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
281 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
285 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
286 ? DBD::Oracle::ORA_CLOB()
287 : DBD::Oracle::ORA_BLOB()
289 $column_bind_attrs{'ora_field'} = $column;
292 $bind_attributes{$column} = \%column_bind_attrs;
295 return \%bind_attributes;
299 my ($self, $name) = @_;
300 $self->_get_dbh->do("SAVEPOINT $name");
303 # Oracle automatically releases a savepoint when you start another one with the
305 sub _svp_release { 1 }
308 my ($self, $name) = @_;
309 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
312 =head2 relname_to_table_alias
314 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
317 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
318 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
321 See L<DBIx::Class::Storage/"relname_to_table_alias">.
325 sub relname_to_table_alias {
327 my ($relname, $join_count) = @_;
329 my $alias = $self->next::method(@_);
331 return $alias if length($alias) <= 30;
333 # get a base64 md5 of the alias with join_count
335 my $ctx = Digest::MD5->new;
337 my $md5 = $ctx->b64digest;
339 # remove alignment mark just in case
342 # truncate and prepend to truncated relname without vowels
343 (my $devoweled = $relname) =~ s/[aeiou]//g;
344 my $shortened = substr($devoweled, 0, 18);
347 $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
354 See L<DBIx::Class/CONTRIBUTORS>.
358 You may distribute this code under the same terms as Perl itself.