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