lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm

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