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