savepoint support
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Oracle / Generic.pm
1 package DBIx::Class::Storage::DBI::Oracle::Generic;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
9
10 =head1 SYNOPSIS
11
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');
17
18 =head1 DESCRIPTION
19
20 This class implements autoincrements for Oracle.
21
22 =head1 METHODS
23
24 =cut
25
26 use base qw/DBIx::Class::Storage::DBI/;
27 use mro 'c3';
28
29 # For ORA_BLOB => 113, ORA_CLOB => 112
30 use DBD::Oracle qw( :ora_types );
31
32 sub _dbh_last_insert_id {
33   my ($self, $dbh, $source, @columns) = @_;
34   my @ids = ();
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 );
38     push @ids, $id;
39   }
40   return @ids;
41 }
42
43 sub _dbh_get_autoinc_seq {
44   my ($self, $dbh, $source, $col) = @_;
45
46   # look up the correct sequence automatically
47   my $sql = q{
48     SELECT trigger_body FROM ALL_TRIGGERS t
49     WHERE t.table_name = ?
50     AND t.triggering_event = 'INSERT'
51     AND t.status = 'ENABLED'
52   };
53
54   # trigger_body is a LONG
55   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
56
57   my $sth;
58
59   # check for fully-qualified name (eg. SCHEMA.TABLENAME)
60   if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
61     $sql = q{
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'
66     };
67     $sth = $dbh->prepare($sql);
68     $sth->execute( uc($schema), uc($table) );
69   }
70   else {
71     $sth = $dbh->prepare($sql);
72     $sth->execute( uc( $source->name ) );
73   }
74   while (my ($insert_trigger) = $sth->fetchrow_array) {
75     return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
76   }
77   $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
78 }
79
80 sub _sequence_fetch {
81   my ( $self, $type, $seq ) = @_;
82   my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
83   return $id;
84 }
85
86 sub _ping {
87   my $self = shift;
88
89   my $dbh = $self->_dbh or return 0;
90
91   local $dbh->{RaiseError} = 1;
92
93   eval {
94     $dbh->do("select 1 from dual");
95   };
96
97   return $@ ? 0 : 1;
98 }
99
100 sub _dbh_execute {
101   my $self = shift;
102   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
103
104   my $wantarray = wantarray;
105
106   my (@res, $exception, $retried);
107
108   RETRY: {
109     do {
110       eval {
111         if ($wantarray) {
112           @res    = $self->next::method(@_);
113         } else {
114           $res[0] = $self->next::method(@_);
115         }
116       };
117       $exception = $@;
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};
123       } else {
124         last RETRY;
125       }
126     } while (not $retried++);
127   }
128
129   $self->throw_exception($exception) if $exception;
130
131   wantarray ? @res : $res[0]
132 }
133
134 =head2 get_autoinc_seq
135
136 Returns the sequence name for an autoincrement column
137
138 =cut
139
140 sub get_autoinc_seq {
141   my ($self, $source, $col) = @_;
142
143   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
144 }
145
146 =head2 columns_info_for
147
148 This wraps the superclass version of this method to force table
149 names to uppercase
150
151 =cut
152
153 sub columns_info_for {
154   my ($self, $table) = @_;
155
156   $self->next::method(uc($table));
157 }
158
159 =head2 datetime_parser_type
160
161 This sets the proper DateTime::Format module for use with
162 L<DBIx::Class::InflateColumn::DateTime>.
163
164 =cut
165
166 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
167
168 =head2 connect_call_datetime_setup
169
170 Used as:
171
172     on_connect_call => 'datetime_setup'
173
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
177 by it.
178
179 Maximum allowable precision is used, unless the environment variables have
180 already been set.
181
182 These are the defaults used:
183
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';
187
188 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
189 for your timestamps, use something like this:
190
191   use Time::HiRes 'time';
192   my $ts = DateTime->from_epoch(epoch => time);
193
194 =cut
195
196 sub connect_call_datetime_setup {
197   my $self = shift;
198
199   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
200   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
201     'YYYY-MM-DD HH24:MI:SS.FF';
202   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
203     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
204
205   $self->_do_query("alter session set nls_date_format = '$date_format'");
206   $self->_do_query(
207 "alter session set nls_timestamp_format = '$timestamp_format'");
208   $self->_do_query(
209 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
210 }
211
212 =head2 source_bind_attributes
213
214 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
215 with the driver assuming your input is the deprecated LONG type if you
216 encode it as a hex string.  That ain't gonna fly at larger values, where
217 you'll discover you have to do what this does.
218
219 This method had to be overridden because we need to set ora_field to the
220 actual column, and that isn't passed to the call (provided by Storage) to
221 bind_attribute_by_data_type.
222
223 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
224 adding it doesn't hurt, and will save your bacon if you're modifying a
225 table with more than one LOB column.
226
227 =cut
228
229 sub source_bind_attributes 
230 {
231         my $self = shift;
232         my($source) = @_;
233
234         my %bind_attributes;
235
236         foreach my $column ($source->columns) {
237                 my $data_type = $source->column_info($column)->{data_type} || '';
238                 next unless $data_type;
239
240                 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
241
242                 if ($data_type =~ /^[BC]LOB$/i) {
243                         $column_bind_attrs{'ora_type'}
244                                 = uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
245                         $column_bind_attrs{'ora_field'} = $column;
246                 }
247
248                 $bind_attributes{$column} = \%column_bind_attrs;
249         }
250
251         return \%bind_attributes;
252 }
253
254 sub _svp_begin {
255     my ($self, $name) = @_;
256
257     $self->dbh->do("SAVEPOINT $name");
258 }
259
260 # Oracle automatically releases a savepoint when you start another one with the
261 # same name.
262 sub _svp_release { 1 }
263
264 sub _svp_rollback {
265     my ($self, $name) = @_;
266
267     $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
268 }
269
270 =head1 AUTHOR
271
272 See L<DBIx::Class/CONTRIBUTORS>.
273
274 =head1 LICENSE
275
276 You may distribute this code under the same terms as Perl itself.
277
278 =cut
279
280 1;