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