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