1 package DBIx::Class::Storage::DBI::Oracle::Generic;
8 DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle
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/;
27 use Carp::Clan qw/^DBIx::Class/;
29 # For ORA_BLOB => 113, ORA_CLOB => 112
30 use DBD::Oracle qw( :ora_types );
32 sub _dbh_last_insert_id {
33 my ($self, $dbh, $source, @columns) = @_;
35 foreach my $col (@columns) {
36 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
37 my $id = $self->_sequence_fetch( 'currval', $seq );
43 sub _dbh_get_autoinc_seq {
44 my ($self, $dbh, $source, $col) = @_;
46 # look up the correct sequence automatically
48 SELECT trigger_body FROM ALL_TRIGGERS t
49 WHERE t.table_name = ?
50 AND t.triggering_event = 'INSERT'
51 AND t.status = 'ENABLED'
54 # trigger_body is a LONG
55 $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
59 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
60 if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
62 SELECT trigger_body FROM ALL_TRIGGERS t
63 WHERE t.owner = ? AND t.table_name = ?
64 AND t.triggering_event = 'INSERT'
65 AND t.status = 'ENABLED'
67 $sth = $dbh->prepare($sql);
68 $sth->execute( uc($schema), uc($table) );
71 $sth = $dbh->prepare($sql);
72 $sth->execute( uc( $source->name ) );
74 while (my ($insert_trigger) = $sth->fetchrow_array) {
75 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
77 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
81 my ( $self, $type, $seq ) = @_;
82 my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
88 Returns true if we have an open (and working) database connection, false if it is not (yet)
89 open (or does not work). (Executes a simple SELECT to make sure it works.)
91 The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
92 OCIPing but just gets the server version, which doesn't help if someone killed
100 if (not $self->next::method(@_)) {
104 my $dbh = $self->_dbh;
106 local $dbh->{RaiseError} = 1;
109 my $ping_sth = $dbh->prepare_cached("select 1 from dual");
120 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
122 my $wantarray = wantarray;
124 my (@res, $exception, $retried);
130 @res = $self->next::method(@_);
132 $res[0] = $self->next::method(@_);
136 if ($exception =~ /ORA-01003/) {
137 # ORA-01003: no statement parsed (someone changed the table somehow,
138 # invalidating your cursor.)
139 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
140 delete $dbh->{CachedKids}{$sql};
144 } while (not $retried++);
147 $self->throw_exception($exception) if $exception;
149 wantarray ? @res : $res[0]
152 =head2 get_autoinc_seq
154 Returns the sequence name for an autoincrement column
158 sub get_autoinc_seq {
159 my ($self, $source, $col) = @_;
161 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
164 =head2 columns_info_for
166 This wraps the superclass version of this method to force table
171 sub columns_info_for {
172 my ($self, $table) = @_;
174 $self->next::method(uc($table));
177 =head2 datetime_parser_type
179 This sets the proper DateTime::Format module for use with
180 L<DBIx::Class::InflateColumn::DateTime>.
184 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
186 =head2 connect_call_datetime_setup
190 on_connect_call => 'datetime_setup'
192 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
193 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
194 necessary environment variables for L<DateTime::Format::Oracle>, which is used
197 Maximum allowable precision is used, unless the environment variables have
200 C<nls_timestamp_tz_format> is also initialized but is not currently used by
201 L<DBIx::Class::InflateColumn::DateTime>.
203 These are the defaults used:
205 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
206 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
207 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
209 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
210 for your timestamps, use something like this:
212 use Time::HiRes 'time';
213 my $ts = DateTime->from_epoch(epoch => time);
217 sub connect_call_datetime_setup {
219 my $dbh = $self->dbh;
221 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
222 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
223 'YYYY-MM-DD HH24:MI:SS.FF';
224 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
225 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
227 $dbh->do("alter session set nls_date_format = '$date_format'");
228 $dbh->do("alter session set nls_timestamp_format = '$timestamp_format'");
229 $dbh->do("alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
233 my ($self, $name) = @_;
235 $self->dbh->do("SAVEPOINT $name");
238 =head2 source_bind_attributes
240 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
241 with the driver assuming your input is the deprecated LONG type if you
242 encode it as a hex string. That ain't gonna fly at larger values, where
243 you'll discover you have to do what this does.
245 This method had to be overridden because we need to set ora_field to the
246 actual column, and that isn't passed to the call (provided by Storage) to
247 bind_attribute_by_data_type.
249 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
250 adding it doesn't hurt, and will save your bacon if you're modifying a
251 table with more than one LOB column.
255 sub source_bind_attributes
262 foreach my $column ($source->columns) {
263 my $data_type = $source->column_info($column)->{data_type} || '';
264 next unless $data_type;
266 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
268 if ($data_type =~ /^[BC]LOB$/i) {
269 $column_bind_attrs{'ora_type'}
270 = uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
271 $column_bind_attrs{'ora_field'} = $column;
274 $bind_attributes{$column} = \%column_bind_attrs;
277 return \%bind_attributes;
280 # Oracle automatically releases a savepoint when you start another one with the
282 sub _svp_release { 1 }
285 my ($self, $name) = @_;
287 $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
292 Andy Grundman <andy@hybridized.org>
294 Scott Connelly <scottsweep@yahoo.com>
298 You may distribute this code under the same terms as Perl itself.