lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm

   1 package DBIx::Class::Storage::DBI::Oracle::Generic;
   2 # -*- mode: cperl; cperl-indent-level: 2 -*-
   3
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9 DBIx::Class::Storage::DBI::Oracle::Generic - Automatic primary key class for Oracle
  10
  11 =head1 SYNOPSIS
  12
  13   # In your table classes
  14   __PACKAGE__->load_components(qw/PK::Auto Core/);
  15   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  16   __PACKAGE__->set_primary_key('id');
  17   __PACKAGE__->sequence('mysequence');
  18
  19 =head1 DESCRIPTION
  20
  21 This class implements autoincrements for Oracle.
  22
  23 =head1 METHODS
  24
  25 =cut
  26
  27 use Carp::Clan qw/^DBIx::Class/;
  28
  29 use DBD::Oracle qw( :ora_types );
  30 #use constant ORA_BLOB => 113;  ## ORA_CLOB is 112
  31
  32 use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
  33
  34 # __PACKAGE__->load_components(qw/PK::Auto/);
  35
  36 sub _dbh_last_insert_id {
  37   my ($self, $dbh, $source, @columns) = @_;
  38   my @ids = ();
  39   foreach my $col (@columns) {
  40     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
  41     my $id = $self->_sequence_fetch( 'currval', $seq );
  42     push @ids, $id;
  43   }
  44   return @ids;
  45 }
  46
  47 sub _dbh_get_autoinc_seq {
  48   my ($self, $dbh, $source, $col) = @_;
  49
  50   # look up the correct sequence automatically
  51   my $sql = q{
  52     SELECT trigger_body FROM ALL_TRIGGERS t
  53     WHERE t.table_name = ?
  54     AND t.triggering_event = 'INSERT'
  55     AND t.status = 'ENABLED'
  56   };
  57
  58   # trigger_body is a LONG
  59   $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
  60
  61   my $sth;
  62
  63   # check for fully-qualified name (eg. SCHEMA.TABLENAME)
  64   if ( my ( $schema, $table ) = $source->name =~ /(\w+)\.(\w+)/ ) {
  65     $sql = q{
  66       SELECT trigger_body FROM ALL_TRIGGERS t
  67       WHERE t.owner = ? AND t.table_name = ?
  68       AND t.triggering_event = 'INSERT'
  69       AND t.status = 'ENABLED'
  70     };
  71     $sth = $dbh->prepare($sql);
  72     $sth->execute( uc($schema), uc($table) );
  73   }
  74   else {
  75     $sth = $dbh->prepare($sql);
  76     $sth->execute( uc( $source->name ) );
  77   }
  78   while (my ($insert_trigger) = $sth->fetchrow_array) {
  79     return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
  80   }
  81   $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
  82 }
  83
  84 sub _sequence_fetch {
  85   my ( $self, $type, $seq ) = @_;
  86   my ($id) = $self->dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
  87   return $id;
  88 }
  89
  90 =head2 connected
  91
  92 Returns true if we have an open (and working) database connection, false if it is not (yet)
  93 open (or does not work). (Executes a simple SELECT to make sure it works.)
  94
  95 The reason this is needed is that L<DBD::Oracle>'s ping() does not do a real
  96 OCIPing but just gets the server version, which doesn't help if someone killed
  97 your session.
  98
  99 =cut
 100
 101 sub connected {
 102   my $self = shift;
 103
 104   if (not $self->SUPER::connected(@_)) {
 105     return 0;
 106   }
 107   else {
 108     my $dbh = $self->_dbh;
 109
 110     local $dbh->{RaiseError} = 1;
 111
 112     eval {
 113       my $ping_sth = $dbh->prepare_cached("select 1 from dual");
 114       $ping_sth->execute;
 115       $ping_sth->finish;
 116     };
 117
 118     return $@ ? 0 : 1;
 119   }
 120 }
 121
 122 sub _dbh_execute {
 123   my $self = shift;
 124   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 125
 126   my $wantarray = wantarray;
 127
 128   my (@res, $exception, $retried);
 129
 130   RETRY: {
 131     do {
 132       eval {
 133         if ($wantarray) {
 134           @res    = $self->SUPER::_dbh_execute(@_);
 135         } else {
 136           $res[0] = $self->SUPER::_dbh_execute(@_);
 137         }
 138       };
 139       $exception = $@;
 140       if ($exception =~ /ORA-01003/) {
 141         # ORA-01003: no statement parsed (someone changed the table somehow,
 142         # invalidating your cursor.)
 143         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 144         delete $dbh->{CachedKids}{$sql};
 145       } else {
 146         last RETRY;
 147       }
 148     } while (not $retried++);
 149   }
 150
 151   $self->throw_exception($exception) if $exception;
 152
 153   wantarray ? @res : $res[0]
 154 }
 155
 156 =head2 get_autoinc_seq
 157
 158 Returns the sequence name for an autoincrement column
 159
 160 =cut
 161
 162 sub get_autoinc_seq {
 163   my ($self, $source, $col) = @_;
 164
 165   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 166 }
 167
 168 =head2 columns_info_for
 169
 170 This wraps the superclass version of this method to force table
 171 names to uppercase
 172
 173 =cut
 174
 175 sub columns_info_for {
 176   my ($self, $table) = @_;
 177
 178   $self->next::method(uc($table));
 179 }
 180
 181 =head2 datetime_parser_type
 182
 183 This sets the proper DateTime::Format module for use with
 184 L<DBIx::Class::InflateColumn::DateTime>.
 185
 186 =cut
 187
 188 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 189
 190 sub _svp_begin {
 191     my ($self, $name) = @_;
 192
 193     $self->dbh->do("SAVEPOINT $name");
 194 }
 195
 196 =head2 source_bind_attributes
 197
 198 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 199 with the driver assuming your input is the deprecated LONG type if you
 200 encode it as a hex string.  That ain't gonna fly at larger values, where
 201 you'll discover you have to do what this does.
 202
 203 This method had to be overridden because we need to set ora_field to the
 204 actual column, and that isn't passed to the call (provided by Storage) to
 205 bind_attribute_by_data_type.
 206
 207 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 208 adding it doesn't hurt, and will save your bacon if you're modifying a
 209 table with more than one LOB column.
 210
 211 =cut
 212
 213 sub source_bind_attributes
 214 {
 215         my $self = shift;
 216         my($source) = @_;
 217
 218         my %bind_attributes;
 219
 220         foreach my $column ($source->columns) {
 221                 my $data_type = $source->column_info($column)->{data_type} || '';
 222                 next unless $data_type;
 223
 224                 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 225
 226                 if ($data_type =~ /^[BC]LOB$/i) {
 227                         $column_bind_attrs{'ora_type'}
 228                                 = uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
 229                         $column_bind_attrs{'ora_field'} = $column;
 230                 }
 231
 232                 $bind_attributes{$column} = \%column_bind_attrs;
 233         }
 234
 235         return \%bind_attributes;
 236 }
 237
 238 # Oracle automatically releases a savepoint when you start another one with the
 239 # same name.
 240 sub _svp_release { 1 }
 241
 242 sub _svp_rollback {
 243     my ($self, $name) = @_;
 244
 245     $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
 246 }
 247
 248 =head1 AUTHORS
 249
 250 Andy Grundman <andy@hybridized.org>
 251
 252 Scott Connelly <scottsweep@yahoo.com>
 253
 254 =head1 LICENSE
 255
 256 You may distribute this code under the same terms as Perl itself.
 257
 258 =cut
 259
 260 1;