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