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
 114   eval {
 115     $dbh->do("select 1 from dual");
 116   };
 117
 118   return $@ ? 0 : 1;
 119 }
 120
 121 sub _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
 157 Returns the sequence name for an autoincrement column
 158
 159 =cut
 160
 161 sub 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
 169 This wraps the superclass version of this method to force table
 170 names to uppercase
 171
 172 =cut
 173
 174 sub columns_info_for {
 175   my ($self, $table) = @_;
 176
 177   $self->next::method($table);
 178 }
 179
 180 =head2 datetime_parser_type
 181
 182 This sets the proper DateTime::Format module for use with
 183 L<DBIx::Class::InflateColumn::DateTime>.
 184
 185 =cut
 186
 187 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 188
 189 =head2 connect_call_datetime_setup
 190
 191 Used as:
 192
 193     on_connect_call => 'datetime_setup'
 194
 195 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
 196 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
 197 necessary environment variables for L<DateTime::Format::Oracle>, which is used
 198 by it.
 199
 200 Maximum allowable precision is used, unless the environment variables have
 201 already been set.
 202
 203 These 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
 209 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 210 for your timestamps, use something like this:
 211
 212   use Time::HiRes 'time';
 213   my $ts = DateTime->from_epoch(epoch => time);
 214
 215 =cut
 216
 217 sub 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
 239 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 240 with the driver assuming your input is the deprecated LONG type if you
 241 encode it as a hex string.  That ain't gonna fly at larger values, where
 242 you'll discover you have to do what this does.
 243
 244 This method had to be overridden because we need to set ora_field to the
 245 actual column, and that isn't passed to the call (provided by Storage) to
 246 bind_attribute_by_data_type.
 247
 248 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 249 adding it doesn't hurt, and will save your bacon if you're modifying a
 250 table with more than one LOB column.
 251
 252 =cut
 253
 254 sub 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
 289 sub _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.
 296 sub _svp_release { 1 }
 297
 298 sub _svp_rollback {
 299   my ($self, $name) = @_;
 300   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 301 }
 302
 303 =head2 relname_to_table_alias
 304
 305 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 306 queries.
 307
 308 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 309 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 310 MD5 hash.
 311
 312 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 313
 314 =cut
 315
 316 sub 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
 345 Runs a coderef between:
 346
 347   alter session set constraints = deferred
 348   ...
 349   alter session set constraints = immediate
 350
 351 to defer foreign key checks.
 352
 353 Constraints must be declared C<DEFERRABLE> for this to work.
 354
 355 =cut
 356
 357 sub 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
 374 See L<DBIx::Class/CONTRIBUTORS>.
 375
 376 =head1 LICENSE
 377
 378 You may distribute this code under the same terms as Perl itself.
 379
 380 =cut
 381
 382 1;