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 table classes
  13   __PACKAGE__->load_components(qw/PK::Auto 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 autoincrements for Oracle.
  21
  22 =head1 METHODS
  23
  24 =cut
  25
  26 use base qw/DBIx::Class::Storage::DBI/;
  27 use mro 'c3';
  28
  29 sub _dbh_last_insert_id {
  30   my ($self, $dbh, $source, @columns) = @_;
  31   my @ids = ();
  32   foreach my $col (@columns) {
  33     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
  34     my $id = $self->_sequence_fetch( 'currval', $seq );
  35     push @ids, $id;
  36   }
  37   return @ids;
  38 }
  39
  40 sub _dbh_get_autoinc_seq {
  41   my ($self, $dbh, $source, $col) = @_;
  42
  43   # look up the correct sequence automatically
  44   my $sql = q{
  45     SELECT trigger_body FROM ALL_TRIGGERS t
  46     WHERE t.table_name = ?
  47     AND t.triggering_event = 'INSERT'
  48     AND t.status = 'ENABLED'
  49   };
  50
  51   # trigger_body is a LONG
  52   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
  53
  54   my $sth;
  55
  56   # check for fully-qualified name (eg. SCHEMA.TABLENAME)
  57   if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
  58     $sql = q{
  59       SELECT trigger_body FROM ALL_TRIGGERS t
  60       WHERE t.owner = ? AND t.table_name = ?
  61       AND t.triggering_event = 'INSERT'
  62       AND t.status = 'ENABLED'
  63     };
  64     $sth = $dbh->prepare($sql);
  65     $sth->execute( uc($schema), uc($table) );
  66   }
  67   else {
  68     $sth = $dbh->prepare($sql);
  69     $sth->execute( uc( $source->name ) );
  70   }
  71   while (my ($insert_trigger) = $sth->fetchrow_array) {
  72     return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
  73   }
  74   $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
  75 }
  76
  77 sub _sequence_fetch {
  78   my ( $self, $type, $seq ) = @_;
  79   my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
  80   return $id;
  81 }
  82
  83 sub _ping {
  84   my $self = shift;
  85
  86   my $dbh = $self->_dbh or return 0;
  87
  88   local $dbh->{RaiseError} = 1;
  89
  90   eval {
  91     $dbh->do("select 1 from dual");
  92   };
  93
  94   return $@ ? 0 : 1;
  95 }
  96
  97 sub _dbh_execute {
  98   my $self = shift;
  99   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 100
 101   my $wantarray = wantarray;
 102
 103   my (@res, $exception, $retried);
 104
 105   RETRY: {
 106     do {
 107       eval {
 108         if ($wantarray) {
 109           @res    = $self->next::method(@_);
 110         } else {
 111           $res[0] = $self->next::method(@_);
 112         }
 113       };
 114       $exception = $@;
 115       if ($exception =~ /ORA-01003/) {
 116         # ORA-01003: no statement parsed (someone changed the table somehow,
 117         # invalidating your cursor.)
 118         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 119         delete $dbh->{CachedKids}{$sql};
 120       } else {
 121         last RETRY;
 122       }
 123     } while (not $retried++);
 124   }
 125
 126   $self->throw_exception($exception) if $exception;
 127
 128   wantarray ? @res : $res[0]
 129 }
 130
 131 =head2 get_autoinc_seq
 132
 133 Returns the sequence name for an autoincrement column
 134
 135 =cut
 136
 137 sub get_autoinc_seq {
 138   my ($self, $source, $col) = @_;
 139
 140   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 141 }
 142
 143 =head2 columns_info_for
 144
 145 This wraps the superclass version of this method to force table
 146 names to uppercase
 147
 148 =cut
 149
 150 sub columns_info_for {
 151   my ($self, $table) = @_;
 152
 153   $self->next::method(uc($table));
 154 }
 155
 156 =head2 datetime_parser_type
 157
 158 This sets the proper DateTime::Format module for use with
 159 L<DBIx::Class::InflateColumn::DateTime>.
 160
 161 =cut
 162
 163 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 164
 165 =head2 connect_call_datetime_setup
 166
 167 Used as:
 168
 169     on_connect_call => 'datetime_setup'
 170
 171 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
 172 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
 173 necessary environment variables for L<DateTime::Format::Oracle>, which is used
 174 by it.
 175
 176 Maximum allowable precision is used, unless the environment variables have
 177 already been set.
 178
 179 These are the defaults used:
 180
 181   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 182   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 183   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 184
 185 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 186 for your timestamps, use something like this:
 187
 188   use Time::HiRes 'time';
 189   my $ts = DateTime->from_epoch(epoch => time);
 190
 191 =cut
 192
 193 sub connect_call_datetime_setup {
 194   my $self = shift;
 195
 196   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 197   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 198     'YYYY-MM-DD HH24:MI:SS.FF';
 199   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 200     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 201
 202   $self->_do_query("alter session set nls_date_format = '$date_format'");
 203   $self->_do_query(
 204 "alter session set nls_timestamp_format = '$timestamp_format'");
 205   $self->_do_query(
 206 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
 207 }
 208
 209 sub _svp_begin {
 210     my ($self, $name) = @_;
 211
 212     $self->_get_dbh->do("SAVEPOINT $name");
 213 }
 214
 215 =head2 source_bind_attributes
 216
 217 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 218 with the driver assuming your input is the deprecated LONG type if you
 219 encode it as a hex string.  That ain't gonna fly at larger values, where
 220 you'll discover you have to do what this does.
 221
 222 This method had to be overridden because we need to set ora_field to the
 223 actual column, and that isn't passed to the call (provided by Storage) to
 224 bind_attribute_by_data_type.
 225
 226 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 227 adding it doesn't hurt, and will save your bacon if you're modifying a
 228 table with more than one LOB column.
 229
 230 =cut
 231
 232 sub source_bind_attributes
 233 {
 234         require DBD::Oracle;
 235         my $self = shift;
 236         my($source) = @_;
 237
 238         my %bind_attributes;
 239
 240         foreach my $column ($source->columns) {
 241                 my $data_type = $source->column_info($column)->{data_type} || '';
 242                 next unless $data_type;
 243
 244                 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 245
 246                 if ($data_type =~ /^[BC]LOB$/i) {
 247                         $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
 248                                 DBD::Oracle::ORA_CLOB() :
 249                                 DBD::Oracle::ORA_BLOB();
 250                         $column_bind_attrs{'ora_field'} = $column;
 251                 }
 252
 253                 $bind_attributes{$column} = \%column_bind_attrs;
 254         }
 255
 256         return \%bind_attributes;
 257 }
 258
 259 # Oracle automatically releases a savepoint when you start another one with the
 260 # same name.
 261 sub _svp_release { 1 }
 262
 263 sub _svp_rollback {
 264     my ($self, $name) = @_;
 265
 266     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 267 }
 268
 269 =head1 AUTHOR
 270
 271 See L<DBIx::Class/CONTRIBUTORS>.
 272
 273 =head1 LICENSE
 274
 275 You may distribute this code under the same terms as Perl itself.
 276
 277 =cut
 278
 279 1;