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