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