1 package DBIx::Class::Storage::DBI::Oracle::Generic;
2 # -*- mode: cperl; cperl-indent-level: 2 -*-
9 DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle
13 # In your table classes
14 __PACKAGE__->load_components(qw/PK::Auto Core/);
15 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
16 __PACKAGE__->set_primary_key('id');
17 __PACKAGE__->sequence('mysequence');
21 This class implements autoincrements for Oracle.
27 use Carp::Clan qw/^DBIx::Class/;
29 # For ORA_BLOB => 113, ORA_CLOB => 112
30 use DBD::Oracle qw( :ora_types );
32 use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
34 # __PACKAGE__->load_components(qw/PK::Auto/);
36 sub _dbh_last_insert_id {
37 my ($self, $dbh, $source, @columns) = @_;
39 foreach my $col (@columns) {
40 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
41 my $id = $self->_sequence_fetch( 'currval', $seq );
47 sub _dbh_get_autoinc_seq {
48 my ($self, $dbh, $source, $col) = @_;
50 # look up the correct sequence automatically
52 SELECT trigger_body FROM ALL_TRIGGERS t
53 WHERE t.table_name = ?
54 AND t.triggering_event = 'INSERT'
55 AND t.status = 'ENABLED'
58 # trigger_body is a LONG
59 $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
63 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
64 if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
66 SELECT trigger_body FROM ALL_TRIGGERS t
67 WHERE t.owner = ? AND t.table_name = ?
68 AND t.triggering_event = 'INSERT'
69 AND t.status = 'ENABLED'
71 $sth = $dbh->prepare($sql);
72 $sth->execute( uc($schema), uc($table) );
75 $sth = $dbh->prepare($sql);
76 $sth->execute( uc( $source->name ) );
78 while (my ($insert_trigger) = $sth->fetchrow_array) {
79 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
81 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
85 my ( $self, $type, $seq ) = @_;
86 my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
92 Returns true if we have an open (and working) database connection, false if it is not (yet)
93 open (or does not work). (Executes a simple SELECT to make sure it works.)
95 The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
96 OCIPing but just gets the server version, which doesn't help if someone killed
104 if (not $self->SUPER::connected(@_)) {
108 my $dbh = $self->_dbh;
110 local $dbh->{RaiseError} = 1;
113 my $ping_sth = $dbh->prepare_cached("select 1 from dual");
124 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
126 my $wantarray = wantarray;
128 my (@res, $exception, $retried);
134 @res = $self->SUPER::_dbh_execute(@_);
136 $res[0] = $self->SUPER::_dbh_execute(@_);
140 if ($exception =~ /ORA-01003/) {
141 # ORA-01003: no statement parsed (someone changed the table somehow,
142 # invalidating your cursor.)
143 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
144 delete $dbh->{CachedKids}{$sql};
148 } while (not $retried++);
151 $self->throw_exception($exception) if $exception;
153 wantarray ? @res : $res[0]
156 =head2 get_autoinc_seq
158 Returns the sequence name for an autoincrement column
162 sub get_autoinc_seq {
163 my ($self, $source, $col) = @_;
165 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
168 =head2 columns_info_for
170 This wraps the superclass version of this method to force table
175 sub columns_info_for {
176 my ($self, $table) = @_;
178 $self->next::method(uc($table));
181 =head2 datetime_parser_type
183 This sets the proper DateTime::Format module for use with
184 L<DBIx::Class::InflateColumn::DateTime>.
188 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
191 my ($self, $name) = @_;
193 $self->dbh->do("SAVEPOINT $name");
196 =head2 source_bind_attributes
198 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
199 with the driver assuming your input is the deprecated LONG type if you
200 encode it as a hex string. That ain't gonna fly at larger values, where
201 you'll discover you have to do what this does.
203 This method had to be overridden because we need to set ora_field to the
204 actual column, and that isn't passed to the call (provided by Storage) to
205 bind_attribute_by_data_type.
207 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
208 adding it doesn't hurt, and will save your bacon if you're modifying a
209 table with more than one LOB column.
213 sub source_bind_attributes
220 foreach my $column ($source->columns) {
221 my $data_type = $source->column_info($column)->{data_type} || '';
222 next unless $data_type;
224 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
226 if ($data_type =~ /^[BC]LOB$/i) {
227 $column_bind_attrs{'ora_type'}
228 = uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
229 $column_bind_attrs{'ora_field'} = $column;
232 $bind_attributes{$column} = \%column_bind_attrs;
235 return \%bind_attributes;
238 # Oracle automatically releases a savepoint when you start another one with the
240 sub _svp_release { 1 }
243 my ($self, $name) = @_;
245 $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
250 Andy Grundman <andy@hybridized.org>
252 Scott Connelly <scottsweep@yahoo.com>
256 You may distribute this code under the same terms as Perl itself.