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