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