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/;
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");
89 my $dbh = $self->_dbh or return 0;
91 local $dbh->{RaiseError} = 1;
94 $dbh->do("select 1 from dual");
102 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
104 my $wantarray = wantarray;
106 my (@res, $exception, $retried);
112 @res = $self->next::method(@_);
114 $res[0] = $self->next::method(@_);
118 if ($exception =~ /ORA-01003/) {
119 # ORA-01003: no statement parsed (someone changed the table somehow,
120 # invalidating your cursor.)
121 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
122 delete $dbh->{CachedKids}{$sql};
126 } while (not $retried++);
129 $self->throw_exception($exception) if $exception;
131 wantarray ? @res : $res[0]
134 =head2 get_autoinc_seq
136 Returns the sequence name for an autoincrement column
140 sub get_autoinc_seq {
141 my ($self, $source, $col) = @_;
143 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
146 =head2 columns_info_for
148 This wraps the superclass version of this method to force table
153 sub columns_info_for {
154 my ($self, $table) = @_;
156 $self->next::method(uc($table));
159 =head2 datetime_parser_type
161 This sets the proper DateTime::Format module for use with
162 L<DBIx::Class::InflateColumn::DateTime>.
166 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
168 =head2 connect_call_datetime_setup
172 on_connect_call => 'datetime_setup'
174 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
175 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
176 necessary environment variables for L<DateTime::Format::Oracle>, which is used
179 Maximum allowable precision is used, unless the environment variables have
182 These are the defaults used:
184 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
185 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
186 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
188 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
189 for your timestamps, use something like this:
191 use Time::HiRes 'time';
192 my $ts = DateTime->from_epoch(epoch => time);
196 sub connect_call_datetime_setup {
198 my $dbh = $self->dbh;
200 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
201 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
202 'YYYY-MM-DD HH24:MI:SS.FF';
203 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
204 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
206 $dbh->do("alter session set nls_date_format = '$date_format'");
207 $dbh->do("alter session set nls_timestamp_format = '$timestamp_format'");
208 $dbh->do("alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
212 my ($self, $name) = @_;
214 $self->dbh->do("SAVEPOINT $name");
217 =head2 source_bind_attributes
219 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
220 with the driver assuming your input is the deprecated LONG type if you
221 encode it as a hex string. That ain't gonna fly at larger values, where
222 you'll discover you have to do what this does.
224 This method had to be overridden because we need to set ora_field to the
225 actual column, and that isn't passed to the call (provided by Storage) to
226 bind_attribute_by_data_type.
228 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
229 adding it doesn't hurt, and will save your bacon if you're modifying a
230 table with more than one LOB column.
234 sub source_bind_attributes
241 foreach my $column ($source->columns) {
242 my $data_type = $source->column_info($column)->{data_type} || '';
243 next unless $data_type;
245 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
247 if ($data_type =~ /^[BC]LOB$/i) {
248 $column_bind_attrs{'ora_type'}
249 = uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
250 $column_bind_attrs{'ora_field'} = $column;
253 $bind_attributes{$column} = \%column_bind_attrs;
256 return \%bind_attributes;
259 # Oracle automatically releases a savepoint when you start another one with the
261 sub _svp_release { 1 }
264 my ($self, $name) = @_;
266 $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
271 Andy Grundman <andy@hybridized.org>
273 Scott Connelly <scottsweep@yahoo.com>
277 You may distribute this code under the same terms as Perl itself.