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 mro 'c3';
  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 sub _ping {
  87   my $self = shift;
  88
  89   my $dbh = $self->_dbh or return 0;
  90
  91   local $dbh->{RaiseError} = 1;
  92
  93   eval {
  94     $dbh->do("select 1 from dual");
  95   };
  96
  97   return $@ ? 0 : 1;
  98 }
  99
 100 sub _dbh_execute {
 101   my $self = shift;
 102   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 103
 104   my $wantarray = wantarray;
 105
 106   my (@res, $exception, $retried);
 107
 108   RETRY: {
 109     do {
 110       eval {
 111         if ($wantarray) {
 112           @res    = $self->next::method(@_);
 113         } else {
 114           $res[0] = $self->next::method(@_);
 115         }
 116       };
 117       $exception = $@;
 118       if ($exception =~ /ORA-01003/) {
 119         # ORA-01003: no statement parsed (someone changed the table somehow,
 120         # invalidating your cursor.)
 121         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 122         delete $dbh->{CachedKids}{$sql};
 123       } else {
 124         last RETRY;
 125       }
 126     } while (not $retried++);
 127   }
 128
 129   $self->throw_exception($exception) if $exception;
 130
 131   wantarray ? @res : $res[0]
 132 }
 133
 134 =head2 get_autoinc_seq
 135
 136 Returns the sequence name for an autoincrement column
 137
 138 =cut
 139
 140 sub get_autoinc_seq {
 141   my ($self, $source, $col) = @_;
 142
 143   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 144 }
 145
 146 =head2 columns_info_for
 147
 148 This wraps the superclass version of this method to force table
 149 names to uppercase
 150
 151 =cut
 152
 153 sub columns_info_for {
 154   my ($self, $table) = @_;
 155
 156   $self->next::method(uc($table));
 157 }
 158
 159 =head2 datetime_parser_type
 160
 161 This sets the proper DateTime::Format module for use with
 162 L<DBIx::Class::InflateColumn::DateTime>.
 163
 164 =cut
 165
 166 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 167
 168 =head2 connect_call_datetime_setup
 169
 170 Used as:
 171
 172     on_connect_call => 'datetime_setup'
 173
 174 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
 175 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
 176 necessary environment variables for L<DateTime::Format::Oracle>, which is used
 177 by it.
 178
 179 Maximum allowable precision is used, unless the environment variables have
 180 already been set.
 181
 182 These are the defaults used:
 183
 184   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 185   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 186   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 187
 188 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 189 for your timestamps, use something like this:
 190
 191   use Time::HiRes 'time';
 192   my $ts = DateTime->from_epoch(epoch => time);
 193
 194 =cut
 195
 196 sub connect_call_datetime_setup {
 197   my $self = shift;
 198   my $dbh  = $self->dbh;
 199
 200   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 201   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 202     'YYYY-MM-DD HH24:MI:SS.FF';
 203   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 204     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 205
 206   $dbh->do("alter session set nls_date_format = '$date_format'");
 207   $dbh->do("alter session set nls_timestamp_format = '$timestamp_format'");
 208   $dbh->do("alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
 209 }
 210
 211 sub _svp_begin {
 212     my ($self, $name) = @_;
 213
 214     $self->dbh->do("SAVEPOINT $name");
 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         my $self = shift;
 237         my($source) = @_;
 238
 239         my %bind_attributes;
 240
 241         foreach my $column ($source->columns) {
 242                 my $data_type = $source->column_info($column)->{data_type} || '';
 243                 next unless $data_type;
 244
 245                 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 246
 247                 if ($data_type =~ /^[BC]LOB$/i) {
 248                         $column_bind_attrs{'ora_type'}
 249                                 = uc($data_type) eq 'CLOB' ? ORA_CLOB : 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->dbh->do("ROLLBACK TO SAVEPOINT $name")
 267 }
 268
 269 =head1 AUTHORS
 270
 271 Andy Grundman <andy@hybridized.org>
 272
 273 Scott Connelly <scottsweep@yahoo.com>
 274
 275 =head1 LICENSE
 276
 277 You may distribute this code under the same terms as Perl itself.
 278
 279 =cut
 280
 281 1;