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