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');
18 # Somewhere in your Code
19 # add some data to a table with a hierarchical relationship
20 $schema->resultset('Person')->create ({
25 firstname => 'child1',
29 firstname => 'grandchild',
35 firstname => 'child2',
41 # select from the hierarchical relationship
42 my $rs = $schema->resultset('Person')->search({},
44 'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
45 'connect_by' => { 'parentid' => 'prior persionid'},
46 'order_siblings_by' => 'firstname ASC',
50 # this will select the whole tree starting from person "foo bar", creating
53 # me.persionid me.firstname, me.lastname, me.parentid
57 # firstname = 'foo' and lastname = 'bar'
59 # parentid = prior persionid
65 This class implements autoincrements for Oracle and adds support for Oracle
66 specific hierarchical queries.
72 use base qw/DBIx::Class::Storage::DBI/;
75 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
77 sub _dbh_last_insert_id {
78 my ($self, $dbh, $source, @columns) = @_;
80 foreach my $col (@columns) {
81 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
82 my $id = $self->_sequence_fetch( 'currval', $seq );
88 sub _dbh_get_autoinc_seq {
89 my ($self, $dbh, $source, $col) = @_;
91 # look up the correct sequence automatically
93 SELECT trigger_body FROM ALL_TRIGGERS t
94 WHERE t.table_name = ?
95 AND t.triggering_event = 'INSERT'
96 AND t.status = 'ENABLED'
99 # trigger_body is a LONG
100 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
105 if ( ref $source->name ne 'SCALAR' ) {
106 $source_name = $source->name;
109 $source_name = ${$source->name};
112 # check for fully-qualified name (eg. SCHEMA.TABLENAME)
113 if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
115 SELECT trigger_body FROM ALL_TRIGGERS t
116 WHERE t.owner = ? AND t.table_name = ?
117 AND t.triggering_event = 'INSERT'
118 AND t.status = 'ENABLED'
120 $sth = $dbh->prepare($sql);
121 $sth->execute( uc($schema), uc($table) );
124 $sth = $dbh->prepare($sql);
125 $sth->execute( uc( $source_name ) );
127 while (my ($insert_trigger) = $sth->fetchrow_array) {
128 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
130 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
133 sub _sequence_fetch {
134 my ( $self, $type, $seq ) = @_;
135 my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
142 my $dbh = $self->_dbh or return 0;
144 local $dbh->{RaiseError} = 1;
147 $dbh->do("select 1 from dual");
155 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
157 my $wantarray = wantarray;
159 my (@res, $exception, $retried);
165 @res = $self->next::method(@_);
167 $res[0] = $self->next::method(@_);
171 if ($exception =~ /ORA-01003/) {
172 # ORA-01003: no statement parsed (someone changed the table somehow,
173 # invalidating your cursor.)
174 my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
175 delete $dbh->{CachedKids}{$sql};
179 } while (not $retried++);
182 $self->throw_exception($exception) if $exception;
184 wantarray ? @res : $res[0]
187 =head2 get_autoinc_seq
189 Returns the sequence name for an autoincrement column
193 sub get_autoinc_seq {
194 my ($self, $source, $col) = @_;
196 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
199 =head2 columns_info_for
201 This wraps the superclass version of this method to force table
206 sub columns_info_for {
207 my ($self, $table) = @_;
209 $self->next::method(uc($table));
212 =head2 datetime_parser_type
214 This sets the proper DateTime::Format module for use with
215 L<DBIx::Class::InflateColumn::DateTime>.
219 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
221 =head2 connect_call_datetime_setup
225 on_connect_call => 'datetime_setup'
227 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
228 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
229 necessary environment variables for L<DateTime::Format::Oracle>, which is used
232 Maximum allowable precision is used, unless the environment variables have
235 These are the defaults used:
237 $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
238 $ENV{NLS_TIMESTAMP_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF';
239 $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
241 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
242 for your timestamps, use something like this:
244 use Time::HiRes 'time';
245 my $ts = DateTime->from_epoch(epoch => time);
249 sub connect_call_datetime_setup {
252 my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
253 my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
254 'YYYY-MM-DD HH24:MI:SS.FF';
255 my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
256 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
258 $self->_do_query("alter session set nls_date_format = '$date_format'");
260 "alter session set nls_timestamp_format = '$timestamp_format'");
262 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
265 =head2 source_bind_attributes
267 Handle LOB types in Oracle. Under a certain size (4k?), you can get away
268 with the driver assuming your input is the deprecated LONG type if you
269 encode it as a hex string. That ain't gonna fly at larger values, where
270 you'll discover you have to do what this does.
272 This method had to be overridden because we need to set ora_field to the
273 actual column, and that isn't passed to the call (provided by Storage) to
274 bind_attribute_by_data_type.
276 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
277 adding it doesn't hurt, and will save your bacon if you're modifying a
278 table with more than one LOB column.
282 sub source_bind_attributes
290 foreach my $column ($source->columns) {
291 my $data_type = $source->column_info($column)->{data_type} || '';
292 next unless $data_type;
294 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
296 if ($data_type =~ /^[BC]LOB$/i) {
297 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
298 DBD::Oracle::ORA_CLOB() :
299 DBD::Oracle::ORA_BLOB();
300 $column_bind_attrs{'ora_field'} = $column;
303 $bind_attributes{$column} = \%column_bind_attrs;
306 return \%bind_attributes;
310 my ($self, $name) = @_;
312 $self->_get_dbh->do("SAVEPOINT $name");
315 # Oracle automatically releases a savepoint when you start another one with the
317 sub _svp_release { 1 }
320 my ($self, $name) = @_;
322 $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
326 my ($self, $ident, $select, $where, $attrs) = @_;
328 my $connect_by_args = {};
329 if ( $attrs->{connect_by} || $attrs->{start_with} || $attrs->{order_siblings_by} ) {
331 connect_by => $attrs->{connect_by},
332 start_with => $attrs->{start_with},
333 order_siblings_by => $attrs->{order_siblings_by},
337 my @rv = $self->next::method($ident, $select, $where, $attrs);
339 return (@rv, $connect_by_args);
344 Following additional attributes can be used in resultsets.
350 =item Value: \%connect_by
354 A hashref of conditions used to specify the relationship between parent rows
355 and child rows of the hierarchy.
357 connect_by => { parentid => 'prior personid' }
359 # adds a connect by statement to the query:
361 # me.persionid me.firstname, me.lastname, me.parentid
365 # parentid = prior persionid
371 =item Value: \%condition
375 A hashref of conditions which specify the root row(s) of the hierarchy.
377 It uses the same syntax as L<DBIx::Class::ResultSet/search>
379 start_with => { firstname => 'Foo', lastname => 'Bar' }
382 # me.persionid me.firstname, me.lastname, me.parentid
386 # firstname = 'foo' and lastname = 'bar'
388 # parentid = prior persionid
390 =head2 order_siblings_by
394 =item Value: ($order_siblings_by | \@order_siblings_by)
398 Which column(s) to order the siblings by.
400 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
402 'order_siblings_by' => 'firstname ASC'
405 # me.persionid me.firstname, me.lastname, me.parentid
409 # parentid = prior persionid
415 See L<DBIx::Class/CONTRIBUTORS>.
419 You may distribute this code under the same terms as Perl itself.