lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm

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