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