1 package DBIx::Class::Storage::DBI::Oracle::Generic;
8 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
12 # In your table classes
13 __PACKAGE__->load_components(qw/PK::Auto 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 autoincrements for Oracle.
26 use base qw/DBIx::Class::Storage::DBI/;
29 sub _dbh_last_insert_id {
30 my ($self, $dbh, $source, @columns) = @_;
32 foreach my $col (@columns) {
33 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
34 my $id = $self->_sequence_fetch( 'currval', $seq );
40 sub _dbh_get_autoinc_seq {
41 my ($self, $dbh, $source, $col) = @_;
43 # look up the correct sequence automatically
45 SELECT trigger_body FROM ALL_TRIGGERS t
46 WHERE t.table_name = ?
47 AND t.triggering_event = 'INSERT'
48 AND t.status = 'ENABLED'
51 # trigger_body is a LONG
52 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
56 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
57 if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
59 SELECT trigger_body FROM ALL_TRIGGERS t
60 WHERE t.owner = ? AND t.table_name = ?
61 AND t.triggering_event = 'INSERT'
62 AND t.status = 'ENABLED'
64 $sth = $dbh->prepare($sql);
65 $sth->execute( uc($schema), uc($table) );
68 $sth = $dbh->prepare($sql);
69 $sth->execute( uc( $source->name ) );
71 while (my ($insert_trigger) = $sth->fetchrow_array) {
72 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
74 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
78 my ( $self, $type, $seq ) = @_;
79 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
86 my $dbh = $self->_dbh or return 0;
88 local $dbh->{RaiseError} = 1;
91 $dbh->do("select 1 from dual");
99 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
101 my $wantarray = wantarray;
103 my (@res, $exception, $retried);
109 @res = $self->next::method(@_);
111 $res[0] = $self->next::method(@_);
115 if ($exception =~ /ORA-01003/) {
116 # ORA-01003: no statement parsed (someone changed the table somehow,
117 # invalidating your cursor.)
118 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
119 delete $dbh->{CachedKids}{$sql};
123 } while (not $retried++);
126 $self->throw_exception($exception) if $exception;
128 wantarray ? @res : $res[0]
131 =head2 get_autoinc_seq
133 Returns the sequence name for an autoincrement column
137 sub get_autoinc_seq {
138 my ($self, $source, $col) = @_;
140 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
143 =head2 columns_info_for
145 This wraps the superclass version of this method to force table
150 sub columns_info_for {
151 my ($self, $table) = @_;
153 $self->next::method(uc($table));
156 =head2 datetime_parser_type
158 This sets the proper DateTime::Format module for use with
159 L<DBIx::Class::InflateColumn::DateTime>.
163 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
165 =head2 connect_call_datetime_setup
169 on_connect_call => 'datetime_setup'
171 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
172 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
173 necessary environment variables for L<DateTime::Format::Oracle>, which is used
176 Maximum allowable precision is used, unless the environment variables have
179 These are the defaults used:
181 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
182 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
183 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
185 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
186 for your timestamps, use something like this:
188 use Time::HiRes 'time';
189 my $ts = DateTime->from_epoch(epoch => time);
193 sub connect_call_datetime_setup {
196 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
197 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
198 'YYYY-MM-DD HH24:MI:SS.FF';
199 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
200 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
202 $self->_do_query("alter session set nls_date_format = '$date_format'");
204 "alter session set nls_timestamp_format = '$timestamp_format'");
206 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
209 =head2 source_bind_attributes
211 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
212 with the driver assuming your input is the deprecated LONG type if you
213 encode it as a hex string. That ain't gonna fly at larger values, where
214 you'll discover you have to do what this does.
216 This method had to be overridden because we need to set ora_field to the
217 actual column, and that isn't passed to the call (provided by Storage) to
218 bind_attribute_by_data_type.
220 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
221 adding it doesn't hurt, and will save your bacon if you're modifying a
222 table with more than one LOB column.
226 sub source_bind_attributes
234 foreach my $column ($source->columns) {
235 my $data_type = $source->column_info($column)->{data_type} || '';
236 next unless $data_type;
238 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
240 if ($data_type =~ /^[BC]LOB$/i) {
241 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
242 DBD::Oracle::ORA_CLOB() :
243 DBD::Oracle::ORA_BLOB();
244 $column_bind_attrs{'ora_field'} = $column;
247 $bind_attributes{$column} = \%column_bind_attrs;
250 return \%bind_attributes;
254 my ($self, $name) = @_;
256 $self->_get_dbh->do("SAVEPOINT $name");
259 # Oracle automatically releases a savepoint when you start another one with the
261 sub _svp_release { 1 }
264 my ($self, $name) = @_;
266 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
271 See L<DBIx::Class/CONTRIBUTORS>.
275 You may distribute this code under the same terms as Perl itself.