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