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   }
 103   else {
 104     my $dbh = $self->_dbh;
 105
 106     local $dbh->{RaiseError} = 1;
 107
 108     eval {
 109       my $ping_sth = $dbh->prepare_cached("select 1 from dual");
 110       $ping_sth->execute;
 111       $ping_sth->finish;
 112     };
 113
 114     return $@ ? 0 : 1;
 115   }
 116 }
 117
 118 sub _dbh_execute {
 119   my $self = shift;
 120   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 121
 122   my $wantarray = wantarray;
 123
 124   my (@res, $exception, $retried);
 125
 126   RETRY: {
 127     do {
 128       eval {
 129         if ($wantarray) {
 130           @res    = $self->next::method(@_);
 131         } else {
 132           $res[0] = $self->next::method(@_);
 133         }
 134       };
 135       $exception = $@;
 136       if ($exception =~ /ORA-01003/) {
 137         # ORA-01003: no statement parsed (someone changed the table somehow,
 138         # invalidating your cursor.)
 139         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 140         delete $dbh->{CachedKids}{$sql};
 141       } else {
 142         last RETRY;
 143       }
 144     } while (not $retried++);
 145   }
 146
 147   $self->throw_exception($exception) if $exception;
 148
 149   wantarray ? @res : $res[0]
 150 }
 151
 152 =head2 get_autoinc_seq
 153
 154 Returns the sequence name for an autoincrement column
 155
 156 =cut
 157
 158 sub get_autoinc_seq {
 159   my ($self, $source, $col) = @_;
 160
 161   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 162 }
 163
 164 =head2 columns_info_for
 165
 166 This wraps the superclass version of this method to force table
 167 names to uppercase
 168
 169 =cut
 170
 171 sub columns_info_for {
 172   my ($self, $table) = @_;
 173
 174   $self->next::method(uc($table));
 175 }
 176
 177 =head2 datetime_parser_type
 178
 179 This sets the proper DateTime::Format module for use with
 180 L<DBIx::Class::InflateColumn::DateTime>.
 181
 182 =cut
 183
 184 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 185
 186 =head2 connect_call_datetime_setup
 187
 188 Used as:
 189
 190     on_connect_call => 'datetime_setup'
 191
 192 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
 193 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
 194 necessary environment variables for L<DateTime::Format::Oracle>, which is used
 195 by it.
 196
 197 Maximum allowable precision is used, unless the environment variables have
 198 already been set.
 199
 200 These are the defaults used:
 201
 202   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 203   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 204   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 205
 206 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 207 for your timestamps, use something like this:
 208
 209   use Time::HiRes 'time';
 210   my $ts = DateTime->from_epoch(epoch => time);
 211
 212 =cut
 213
 214 sub connect_call_datetime_setup {
 215   my $self = shift;
 216   my $dbh  = $self->dbh;
 217
 218   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 219   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 220     'YYYY-MM-DD HH24:MI:SS.FF';
 221   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 222     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 223
 224   $dbh->do("alter session set nls_date_format = '$date_format'");
 225   $dbh->do("alter session set nls_timestamp_format = '$timestamp_format'");
 226   $dbh->do("alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
 227 }
 228
 229 sub _svp_begin {
 230     my ($self, $name) = @_;
 231
 232     $self->dbh->do("SAVEPOINT $name");
 233 }
 234
 235 =head2 source_bind_attributes
 236
 237 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 238 with the driver assuming your input is the deprecated LONG type if you
 239 encode it as a hex string.  That ain't gonna fly at larger values, where
 240 you'll discover you have to do what this does.
 241
 242 This method had to be overridden because we need to set ora_field to the
 243 actual column, and that isn't passed to the call (provided by Storage) to
 244 bind_attribute_by_data_type.
 245
 246 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 247 adding it doesn't hurt, and will save your bacon if you're modifying a
 248 table with more than one LOB column.
 249
 250 =cut
 251
 252 sub source_bind_attributes
 253 {
 254         my $self = shift;
 255         my($source) = @_;
 256
 257         my %bind_attributes;
 258
 259         foreach my $column ($source->columns) {
 260                 my $data_type = $source->column_info($column)->{data_type} || '';
 261                 next unless $data_type;
 262
 263                 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 264
 265                 if ($data_type =~ /^[BC]LOB$/i) {
 266                         $column_bind_attrs{'ora_type'}
 267                                 = uc($data_type) eq 'CLOB' ? ORA_CLOB : ORA_BLOB;
 268                         $column_bind_attrs{'ora_field'} = $column;
 269                 }
 270
 271                 $bind_attributes{$column} = \%column_bind_attrs;
 272         }
 273
 274         return \%bind_attributes;
 275 }
 276
 277 # Oracle automatically releases a savepoint when you start another one with the
 278 # same name.
 279 sub _svp_release { 1 }
 280
 281 sub _svp_rollback {
 282     my ($self, $name) = @_;
 283
 284     $self->dbh->do("ROLLBACK TO SAVEPOINT $name")
 285 }
 286
 287 =head1 AUTHORS
 288
 289 Andy Grundman <andy@hybridized.org>
 290
 291 Scott Connelly <scottsweep@yahoo.com>
 292
 293 =head1 LICENSE
 294
 295 You may distribute this code under the same terms as Perl itself.
 296
 297 =cut
 298
 299 1;