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