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