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 'preserve_context';
   7 use Try::Tiny;
   8 use namespace::clean;
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
  13
  14 =head1 SYNOPSIS
  15
  16   # In your result (table) classes
  17   use base 'DBIx::Class::Core';
  18   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  19   __PACKAGE__->set_primary_key('id');
  20   __PACKAGE__->sequence('mysequence');
  21
  22 =head1 DESCRIPTION
  23
  24 This class implements base Oracle support. The subclass
  25 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
  26 versions before 9.
  27
  28 =head1 METHODS
  29
  30 =cut
  31
  32 use base qw/DBIx::Class::Storage::DBI/;
  33 use mro 'c3';
  34
  35 sub deployment_statements {
  36   my $self = shift;;
  37   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
  38
  39   $sqltargs ||= {};
  40   my $quote_char = $self->schema->storage->sql_maker->quote_char;
  41   $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
  42   $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
  43
  44   my $oracle_version = try { $self->_get_dbh->get_info(18) };
  45
  46   $sqltargs->{producer_args}{oracle_version} = $oracle_version;
  47
  48   $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
  49 }
  50
  51 sub _dbh_last_insert_id {
  52   my ($self, $dbh, $source, @columns) = @_;
  53   my @ids = ();
  54   foreach my $col (@columns) {
  55     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
  56     my $id = $self->_sequence_fetch( 'currval', $seq );
  57     push @ids, $id;
  58   }
  59   return @ids;
  60 }
  61
  62 sub _dbh_get_autoinc_seq {
  63   my ($self, $dbh, $source, $col) = @_;
  64
  65   my $sql_maker = $self->sql_maker;
  66
  67   my $source_name;
  68   if ( ref $source->name eq 'SCALAR' ) {
  69     $source_name = ${$source->name};
  70   }
  71   else {
  72     $source_name = $source->name;
  73   }
  74   $source_name = uc($source_name) unless $sql_maker->quote_char;
  75
  76   # trigger_body is a LONG
  77   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
  78
  79   # disable default bindtype
  80   local $sql_maker->{bindtype} = 'normal';
  81
  82   # look up the correct sequence automatically
  83   my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
  84   my ($sql, @bind) = $sql_maker->select (
  85     'ALL_TRIGGERS',
  86     ['trigger_body'],
  87     {
  88       $schema ? (owner => $schema) : (),
  89       table_name => $table || $source_name,
  90       triggering_event => { -like => '%INSERT%' },
  91       status => 'ENABLED',
  92      },
  93   );
  94   my $sth = $dbh->prepare($sql);
  95   $sth->execute (@bind);
  96
  97   while (my ($insert_trigger) = $sth->fetchrow_array) {
  98     return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
  99   }
 100   $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
 101 }
 102
 103 sub _sequence_fetch {
 104   my ( $self, $type, $seq ) = @_;
 105   my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
 106   return $id;
 107 }
 108
 109 sub _ping {
 110   my $self = shift;
 111
 112   my $dbh = $self->_dbh or return 0;
 113
 114   local $dbh->{RaiseError} = 1;
 115   local $dbh->{PrintError} = 0;
 116
 117   return try {
 118     $dbh->do('select 1 from dual');
 119     1;
 120   } catch {
 121     0;
 122   };
 123 }
 124
 125 sub _dbh_execute {
 126   my $self = shift;
 127   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 128
 129   my (@res, $tried);
 130   my $wantarray = wantarray();
 131   my $next = $self->next::can;
 132   do {
 133     try {
 134       my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
 135
 136       if (!defined $wantarray) {
 137         $exec->();
 138       }
 139       elsif (! $wantarray) {
 140         $res[0] = $exec->();
 141       }
 142       else {
 143         @res = $exec->();
 144       }
 145
 146       $tried++;
 147     }
 148     catch {
 149       if (! $tried and $_ =~ /ORA-01003/) {
 150         # ORA-01003: no statement parsed (someone changed the table somehow,
 151         # invalidating your cursor.)
 152         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 153         delete $dbh->{CachedKids}{$sql};
 154       }
 155       else {
 156         $self->throw_exception($_);
 157       }
 158     };
 159   } while (! $tried++);
 160
 161   return $wantarray ? @res : $res[0];
 162 }
 163
 164 =head2 get_autoinc_seq
 165
 166 Returns the sequence name for an autoincrement column
 167
 168 =cut
 169
 170 sub get_autoinc_seq {
 171   my ($self, $source, $col) = @_;
 172
 173   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 174 }
 175
 176 =head2 datetime_parser_type
 177
 178 This sets the proper DateTime::Format module for use with
 179 L<DBIx::Class::InflateColumn::DateTime>.
 180
 181 =cut
 182
 183 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 184
 185 =head2 connect_call_datetime_setup
 186
 187 Used as:
 188
 189     on_connect_call => 'datetime_setup'
 190
 191 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 192 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 193 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 194 is used by it.
 195
 196 Maximum allowable precision is used, unless the environment variables have
 197 already been set.
 198
 199 These are the defaults used:
 200
 201   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 202   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 203   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 204
 205 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 206 for your timestamps, use something like this:
 207
 208   use Time::HiRes 'time';
 209   my $ts = DateTime->from_epoch(epoch => time);
 210
 211 =cut
 212
 213 sub connect_call_datetime_setup {
 214   my $self = shift;
 215
 216   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 217   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 218     'YYYY-MM-DD HH24:MI:SS.FF';
 219   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 220     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 221
 222   $self->_do_query(
 223     "alter session set nls_date_format = '$date_format'"
 224   );
 225   $self->_do_query(
 226     "alter session set nls_timestamp_format = '$timestamp_format'"
 227   );
 228   $self->_do_query(
 229     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 230   );
 231 }
 232
 233 =head2 source_bind_attributes
 234
 235 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 236 with the driver assuming your input is the deprecated LONG type if you
 237 encode it as a hex string.  That ain't gonna fly at larger values, where
 238 you'll discover you have to do what this does.
 239
 240 This method had to be overridden because we need to set ora_field to the
 241 actual column, and that isn't passed to the call (provided by Storage) to
 242 bind_attribute_by_data_type.
 243
 244 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 245 adding it doesn't hurt, and will save your bacon if you're modifying a
 246 table with more than one LOB column.
 247
 248 =cut
 249
 250 sub source_bind_attributes
 251 {
 252   require DBD::Oracle;
 253   my $self = shift;
 254   my($source) = @_;
 255
 256   my %bind_attributes;
 257
 258   foreach my $column ($source->columns) {
 259     my $data_type = $source->column_info($column)->{data_type} || '';
 260     next unless $data_type;
 261
 262     my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 263
 264     if ($data_type =~ /^[BC]LOB$/i) {
 265       if ($DBD::Oracle::VERSION eq '1.23') {
 266         $self->throw_exception(
 267 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 268 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 269         );
 270       }
 271
 272       $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
 273         ? DBD::Oracle::ORA_CLOB()
 274         : DBD::Oracle::ORA_BLOB()
 275       ;
 276       $column_bind_attrs{'ora_field'} = $column;
 277     }
 278
 279     $bind_attributes{$column} = \%column_bind_attrs;
 280   }
 281
 282   return \%bind_attributes;
 283 }
 284
 285 sub _svp_begin {
 286   my ($self, $name) = @_;
 287   $self->_get_dbh->do("SAVEPOINT $name");
 288 }
 289
 290 # Oracle automatically releases a savepoint when you start another one with the
 291 # same name.
 292 sub _svp_release { 1 }
 293
 294 sub _svp_rollback {
 295   my ($self, $name) = @_;
 296   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 297 }
 298
 299 =head2 relname_to_table_alias
 300
 301 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 302 queries.
 303
 304 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 305 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 306 MD5 hash.
 307
 308 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 309
 310 =cut
 311
 312 sub relname_to_table_alias {
 313   my $self = shift;
 314   my ($relname, $join_count) = @_;
 315
 316   my $alias = $self->next::method(@_);
 317
 318   return $alias if length($alias) <= 30;
 319
 320   # get a base64 md5 of the alias with join_count
 321   require Digest::MD5;
 322   my $ctx = Digest::MD5->new;
 323   $ctx->add($alias);
 324   my $md5 = $ctx->b64digest;
 325
 326   # remove alignment mark just in case
 327   $md5 =~ s/=*\z//;
 328
 329   # truncate and prepend to truncated relname without vowels
 330   (my $devoweled = $relname) =~ s/[aeiou]//g;
 331   my $shortened = substr($devoweled, 0, 18);
 332
 333   my $new_alias =
 334     $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
 335
 336   return $new_alias;
 337 }
 338
 339 =head2 with_deferred_fk_checks
 340
 341 Runs a coderef between:
 342
 343   alter session set constraints = deferred
 344   ...
 345   alter session set constraints = immediate
 346
 347 to defer foreign key checks.
 348
 349 Constraints must be declared C<DEFERRABLE> for this to work.
 350
 351 =cut
 352
 353 sub with_deferred_fk_checks {
 354   my ($self, $sub) = @_;
 355
 356   my $txn_scope_guard = $self->txn_scope_guard;
 357
 358   $self->_do_query('alter session set constraints = deferred');
 359
 360   my $sg = Scope::Guard->new(sub {
 361     $self->_do_query('alter session set constraints = immediate');
 362   });
 363
 364   return
 365     preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
 366 }
 367
 368 =head1 AUTHOR
 369
 370 See L<DBIx::Class/CONTRIBUTORS>.
 371
 372 =head1 LICENSE
 373
 374 You may distribute this code under the same terms as Perl itself.
 375
 376 =cut
 377
 378 1;