1package DBIx::Class::Storage::DBI::Oracle::Generic;
2
3use strict;
4use warnings;
5use Scope::Guard ();
6use Context::Preserve ();
7
8=head1 NAME
9
10DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
11
12=head1 SYNOPSIS
13
14  # In your result (table) classes
15  use base 'DBIx::Class::Core';
16  __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
17  __PACKAGE__->set_primary_key('id');
18  __PACKAGE__->sequence('mysequence');
19
20=head1 DESCRIPTION
21
22This class implements base Oracle support. The subclass
23L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
24versions before 9.
25
26=head1 METHODS
27
28=cut
29
30use base qw/DBIx::Class::Storage::DBI/;
31use mro 'c3';
32
33sub deployment_statements {
34  my $self = shift;;
35  my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
36
37  $sqltargs ||= {};
38  my $quote_char = $self->schema->storage->sql_maker->quote_char;
39  $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
40  $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
41
42  my $oracle_version = eval { $self->_get_dbh->get_info(18) };
43
44  $sqltargs->{producer_args}{oracle_version} = $oracle_version;
45
46  $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
47}
48
49sub _dbh_last_insert_id {
50  my ($self, $dbh, $source, @columns) = @_;
51  my @ids = ();
52  foreach my $col (@columns) {
53    my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
54    my $id = $self->_sequence_fetch( 'currval', $seq );
55    push @ids, $id;
56  }
57  return @ids;
58}
59
60sub _dbh_get_autoinc_seq {
61  my ($self, $dbh, $source, $col) = @_;
62
63  my $sql_maker = $self->sql_maker;
64
65  my $source_name;
66  if ( ref $source->name eq 'SCALAR' ) {
67    $source_name = ${$source->name};
68  }
69  else {
70    $source_name = $source->name;
71  }
72  $source_name = uc($source_name) unless $sql_maker->quote_char;
73
74  # trigger_body is a LONG
75  local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
76
77  # disable default bindtype
78  local $sql_maker->{bindtype} = 'normal';
79
80  # look up the correct sequence automatically
81  my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
82  my ($sql, @bind) = $sql_maker->select (
83    'ALL_TRIGGERS',
84    ['trigger_body'],
85    {
86      $schema ? (owner => $schema) : (),
87      table_name => $table || $source_name,
88      triggering_event => 'INSERT',
89      status => 'ENABLED',
90     },
91  );
92  my $sth = $dbh->prepare($sql);
93  $sth->execute (@bind);
94
95  while (my ($insert_trigger) = $sth->fetchrow_array) {
96    return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
97  }
98  $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
99}
100
101sub _sequence_fetch {
102  my ( $self, $type, $seq ) = @_;
103  my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
104  return $id;
105}
106
107sub _ping {
108  my $self = shift;
109
110  my $dbh = $self->_dbh or return 0;
111
112  local $dbh->{RaiseError} = 1;
113
114  eval {
115    $dbh->do("select 1 from dual");
116  };
117
118  return $@ ? 0 : 1;
119}
120
121sub _dbh_execute {
122  my $self = shift;
123  my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
124
125  my $wantarray = wantarray;
126
127  my (@res, $exception, $retried);
128
129  RETRY: {
130    do {
131      eval {
132        if ($wantarray) {
133          @res    = $self->next::method(@_);
134        } else {
135          $res[0] = $self->next::method(@_);
136        }
137      };
138      $exception = $@;
139      if ($exception =~ /ORA-01003/) {
140        # ORA-01003: no statement parsed (someone changed the table somehow,
141        # invalidating your cursor.)
142        my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
143        delete $dbh->{CachedKids}{$sql};
144      } else {
145        last RETRY;
146      }
147    } while (not $retried++);
148  }
149
150  $self->throw_exception($exception) if $exception;
151
152  wantarray ? @res : $res[0]
153}
154
155=head2 get_autoinc_seq
156
157Returns the sequence name for an autoincrement column
158
159=cut
160
161sub get_autoinc_seq {
162  my ($self, $source, $col) = @_;
163
164  $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
165}
166
167=head2 columns_info_for
168
169This wraps the superclass version of this method to force table
170names to uppercase
171
172=cut
173
174sub columns_info_for {
175  my ($self, $table) = @_;
176
177  $self->next::method($table);
178}
179
180=head2 datetime_parser_type
181
182This sets the proper DateTime::Format module for use with
183L<DBIx::Class::InflateColumn::DateTime>.
184
185=cut
186
187sub datetime_parser_type { return "DateTime::Format::Oracle"; }
188
189=head2 connect_call_datetime_setup
190
191Used as:
192
193    on_connect_call => 'datetime_setup'
194
195In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
196timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
197necessary environment variables for L<DateTime::Format::Oracle>, which is used
198by it.
199
200Maximum allowable precision is used, unless the environment variables have
201already been set.
202
203These are the defaults used:
204
205  $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
206  $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
207  $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
208
209To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
210for your timestamps, use something like this:
211
212  use Time::HiRes 'time';
213  my $ts = DateTime->from_epoch(epoch => time);
214
215=cut
216
217sub connect_call_datetime_setup {
218  my $self = shift;
219
220  my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
221  my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
222    'YYYY-MM-DD HH24:MI:SS.FF';
223  my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
224    'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
225
226  $self->_do_query(
227    "alter session set nls_date_format = '$date_format'"
228  );
229  $self->_do_query(
230    "alter session set nls_timestamp_format = '$timestamp_format'"
231  );
232  $self->_do_query(
233    "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
234  );
235}
236
237=head2 source_bind_attributes
238
239Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
240with the driver assuming your input is the deprecated LONG type if you
241encode it as a hex string.  That ain't gonna fly at larger values, where
242you'll discover you have to do what this does.
243
244This method had to be overridden because we need to set ora_field to the
245actual column, and that isn't passed to the call (provided by Storage) to
246bind_attribute_by_data_type.
247
248According to L<DBD::Oracle>, the ora_field isn't always necessary, but
249adding it doesn't hurt, and will save your bacon if you're modifying a
250table with more than one LOB column.
251
252=cut
253
254sub source_bind_attributes
255{
256  require DBD::Oracle;
257  my $self = shift;
258  my($source) = @_;
259
260  my %bind_attributes;
261
262  foreach my $column ($source->columns) {
263    my $data_type = $source->column_info($column)->{data_type} || '';
264    next unless $data_type;
265
266    my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
267
268    if ($data_type =~ /^[BC]LOB$/i) {
269      if ($DBD::Oracle::VERSION eq '1.23') {
270        $self->throw_exception(
271"BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
272"version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
273        );
274      }
275
276      $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
277        ? DBD::Oracle::ORA_CLOB()
278        : DBD::Oracle::ORA_BLOB()
279      ;
280      $column_bind_attrs{'ora_field'} = $column;
281    }
282
283    $bind_attributes{$column} = \%column_bind_attrs;
284  }
285
286  return \%bind_attributes;
287}
288
289sub _svp_begin {
290  my ($self, $name) = @_;
291  $self->_get_dbh->do("SAVEPOINT $name");
292}
293
294# Oracle automatically releases a savepoint when you start another one with the
295# same name.
296sub _svp_release { 1 }
297
298sub _svp_rollback {
299  my ($self, $name) = @_;
300  $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
301}
302
303=head2 relname_to_table_alias
304
305L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
306queries.
307
308Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
309the L<DBIx::Class::Relationship> name is shortened and appended with half of an
310MD5 hash.
311
312See L<DBIx::Class::Storage/"relname_to_table_alias">.
313
314=cut
315
316sub relname_to_table_alias {
317  my $self = shift;
318  my ($relname, $join_count) = @_;
319
320  my $alias = $self->next::method(@_);
321
322  return $alias if length($alias) <= 30;
323
324  # get a base64 md5 of the alias with join_count
325  require Digest::MD5;
326  my $ctx = Digest::MD5->new;
327  $ctx->add($alias);
328  my $md5 = $ctx->b64digest;
329
330  # remove alignment mark just in case
331  $md5 =~ s/=*\z//;
332
333  # truncate and prepend to truncated relname without vowels
334  (my $devoweled = $relname) =~ s/[aeiou]//g;
335  my $shortened = substr($devoweled, 0, 18);
336
337  my $new_alias =
338    $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
339
340  return $new_alias;
341}
342
343=head2 with_deferred_fk_checks
344
345Runs a coderef between:
346
347  alter session set constraints = deferred
348  ...
349  alter session set constraints = immediate
350
351to defer foreign key checks.
352
353Constraints must be declared C<DEFERRABLE> for this to work.
354
355=cut
356
357sub with_deferred_fk_checks {
358  my ($self, $sub) = @_;
359
360  my $txn_scope_guard = $self->txn_scope_guard;
361
362  $self->_do_query('alter session set constraints = deferred');
363
364  my $sg = Scope::Guard->new(sub {
365    $self->_do_query('alter session set constraints = immediate');
366  });
367
368  return Context::Preserve::preserve_context(sub { $sub->() },
369    after => sub { $txn_scope_guard->commit });
370}
371
372=head1 AUTHOR
373
374See L<DBIx::Class/CONTRIBUTORS>.
375
376=head1 LICENSE
377
378You may distribute this code under the same terms as Perl itself.
379
380=cut
381
3821;
383