Merge 'trunk' into 'sybase'
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Storage / DBI / Oracle / Generic.pm
CommitLineData
18360aed 1package DBIx::Class::Storage::DBI::Oracle::Generic;
2
3use strict;
4use warnings;
5
7137528d 6=head1 NAME
7
7a84c41b 8DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
7137528d 9
10=head1 SYNOPSIS
11
12 # In your table classes
13 __PACKAGE__->load_components(qw/PK::Auto Core/);
2e46b6eb 14 __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
7137528d 15 __PACKAGE__->set_primary_key('id');
16 __PACKAGE__->sequence('mysequence');
17
18=head1 DESCRIPTION
19
20This class implements autoincrements for Oracle.
21
22=head1 METHODS
23
24=cut
25
db56cf3d 26use base qw/DBIx::Class::Storage::DBI/;
2ad62d97 27use mro 'c3';
18360aed 28
18360aed 29sub _dbh_last_insert_id {
2e46b6eb 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;
18360aed 38}
39
40sub _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
7a84c41b 52 local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
18360aed 53
cb464582 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 }
18360aed 71 while (my ($insert_trigger) = $sth->fetchrow_array) {
72 return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
73 }
66cab05c 74 $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
18360aed 75}
76
2e46b6eb 77sub _sequence_fetch {
78 my ( $self, $type, $seq ) = @_;
a52c8b22 79 my ($id) = $self->last_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
2e46b6eb 80 return $id;
81}
82
6dc4be0f 83sub _ping {
c2481821 84 my $self = shift;
7ba7a57d 85
6dc4be0f 86 my $dbh = $self->_dbh or return 0;
7ba7a57d 87
6dc4be0f 88 local $dbh->{RaiseError} = 1;
c2d7baef 89
6dc4be0f 90 eval {
91 $dbh->do("select 1 from dual");
92 };
7ba7a57d 93
6dc4be0f 94 return $@ ? 0 : 1;
c2481821 95}
96
d789fa99 97sub _dbh_execute {
98 my $self = shift;
99 my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
100
101 my $wantarray = wantarray;
d789fa99 102
c2d7baef 103 my (@res, $exception, $retried);
104
0f0abc97 105 RETRY: {
106 do {
107 eval {
108 if ($wantarray) {
c3515436 109 @res = $self->next::method(@_);
0f0abc97 110 } else {
c3515436 111 $res[0] = $self->next::method(@_);
0f0abc97 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};
d789fa99 120 } else {
0f0abc97 121 last RETRY;
d789fa99 122 }
0f0abc97 123 } while (not $retried++);
124 }
d789fa99 125
126 $self->throw_exception($exception) if $exception;
127
128 wantarray ? @res : $res[0]
129}
130
7137528d 131=head2 get_autoinc_seq
132
133Returns the sequence name for an autoincrement column
134
135=cut
136
18360aed 137sub get_autoinc_seq {
138 my ($self, $source, $col) = @_;
d4daee7b 139
373940e1 140 $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
18360aed 141}
142
7137528d 143=head2 columns_info_for
144
145This wraps the superclass version of this method to force table
146names to uppercase
147
148=cut
149
18360aed 150sub columns_info_for {
151 my ($self, $table) = @_;
152
153 $self->next::method(uc($table));
154}
155
8f7e044c 156=head2 datetime_parser_type
157
158This sets the proper DateTime::Format module for use with
159L<DBIx::Class::InflateColumn::DateTime>.
160
161=cut
162
163sub datetime_parser_type { return "DateTime::Format::Oracle"; }
164
9900b569 165=head2 connect_call_datetime_setup
d2a3958e 166
167Used as:
168
9900b569 169 on_connect_call => 'datetime_setup'
d2a3958e 170
82f6f45f 171In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
172timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
173necessary environment variables for L<DateTime::Format::Oracle>, which is used
174by it.
d2a3958e 175
82f6f45f 176Maximum allowable precision is used, unless the environment variables have
177already been set.
d2a3958e 178
9900b569 179These 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
d9e53b85 185To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
186for your timestamps, use something like this:
187
188 use Time::HiRes 'time';
189 my $ts = DateTime->from_epoch(epoch => time);
190
d2a3958e 191=cut
192
9900b569 193sub connect_call_datetime_setup {
d2a3958e 194 my $self = shift;
d2a3958e 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
7a84c41b 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'");
d2a3958e 207}
208
5db2758d 209=head2 source_bind_attributes
210
211Handle LOB types in Oracle. Under a certain size (4k?), you can get away
212with the driver assuming your input is the deprecated LONG type if you
213encode it as a hex string. That ain't gonna fly at larger values, where
214you'll discover you have to do what this does.
215
216This method had to be overridden because we need to set ora_field to the
217actual column, and that isn't passed to the call (provided by Storage) to
218bind_attribute_by_data_type.
219
220According to L<DBD::Oracle>, the ora_field isn't always necessary, but
221adding it doesn't hurt, and will save your bacon if you're modifying a
222table with more than one LOB column.
223
224=cut
225
226sub source_bind_attributes
227{
efc5bf40 228 require DBD::Oracle;
5db2758d 229 my $self = shift;
230 my($source) = @_;
231
232 my %bind_attributes;
233
234 foreach my $column ($source->columns) {
235 my $data_type = $source->column_info($column)->{data_type} || '';
236 next unless $data_type;
237
238 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
239
240 if ($data_type =~ /^[BC]LOB$/i) {
0d1207e8 241 $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
242 DBD::Oracle::ORA_CLOB() :
243 DBD::Oracle::ORA_BLOB();
5db2758d 244 $column_bind_attrs{'ora_field'} = $column;
245 }
246
247 $bind_attributes{$column} = \%column_bind_attrs;
248 }
249
250 return \%bind_attributes;
251}
252
1816be4f 253sub _svp_begin {
254 my ($self, $name) = @_;
255
44e538d0 256 $self->last_dbh->do("SAVEPOINT $name");
1816be4f 257}
258
281719d2 259# Oracle automatically releases a savepoint when you start another one with the
260# same name.
261sub _svp_release { 1 }
262
263sub _svp_rollback {
264 my ($self, $name) = @_;
265
a52c8b22 266 $self->last_dbh->do("ROLLBACK TO SAVEPOINT $name")
281719d2 267}
268
7a84c41b 269=head1 AUTHOR
18360aed 270
7a84c41b 271See L<DBIx::Class/CONTRIBUTORS>.
18360aed 272
273=head1 LICENSE
274
275You may distribute this code under the same terms as Perl itself.
276
277=cut
7137528d 278
2791;