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

   1 package DBIx::Class::Storage::DBI::Oracle::Generic;
   2
   3 use strict;
   4 use warnings;
   5 use Scope::Guard ();
   6 use Context::Preserve ();
   7 use Try::Tiny;
   8
   9 =head1 NAME
  10
  11 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
  12
  13 =head1 SYNOPSIS
  14
  15   # In your result (table) classes
  16   use base 'DBIx::Class::Core';
  17   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  18   __PACKAGE__->set_primary_key('id');
  19   __PACKAGE__->sequence('mysequence');
  20
  21 =head1 DESCRIPTION
  22
  23 This class implements base Oracle support. The subclass
  24 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
  25 versions before 9.
  26
  27 =head1 METHODS
  28
  29 =cut
  30
  31 use base qw/DBIx::Class::Storage::DBI/;
  32 use mro 'c3';
  33
  34 sub deployment_statements {
  35   my $self = shift;;
  36   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
  37
  38   $sqltargs ||= {};
  39   my $quote_char = $self->schema->storage->sql_maker->quote_char;
  40   $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
  41   $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
  42
  43   my $oracle_version = try { $self->_get_dbh->get_info(18) };
  44
  45   $sqltargs->{producer_args}{oracle_version} = $oracle_version;
  46
  47   $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
  48 }
  49
  50 sub _dbh_last_insert_id {
  51   my ($self, $dbh, $source, @columns) = @_;
  52   my @ids = ();
  53   foreach my $col (@columns) {
  54     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
  55     my $id = $self->_sequence_fetch( 'currval', $seq );
  56     push @ids, $id;
  57   }
  58   return @ids;
  59 }
  60
  61 sub _dbh_get_autoinc_seq {
  62   my ($self, $dbh, $source, $col) = @_;
  63
  64   my $sql_maker = $self->sql_maker;
  65
  66   my $source_name;
  67   if ( ref $source->name eq 'SCALAR' ) {
  68     $source_name = ${$source->name};
  69   }
  70   else {
  71     $source_name = $source->name;
  72   }
  73   $source_name = uc($source_name) unless $sql_maker->quote_char;
  74
  75   # trigger_body is a LONG
  76   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
  77
  78   # disable default bindtype
  79   local $sql_maker->{bindtype} = 'normal';
  80
  81   # look up the correct sequence automatically
  82   my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
  83   my ($sql, @bind) = $sql_maker->select (
  84     'ALL_TRIGGERS',
  85     ['trigger_body'],
  86     {
  87       $schema ? (owner => $schema) : (),
  88       table_name => $table || $source_name,
  89       triggering_event => { -like => '%INSERT%' },
  90       status => 'ENABLED',
  91      },
  92   );
  93   my $sth = $dbh->prepare($sql);
  94   $sth->execute (@bind);
  95
  96   while (my ($insert_trigger) = $sth->fetchrow_array) {
  97     return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
  98   }
  99   $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
 100 }
 101
 102 sub _sequence_fetch {
 103   my ( $self, $type, $seq ) = @_;
 104   my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
 105   return $id;
 106 }
 107
 108 sub _ping {
 109   my $self = shift;
 110
 111   my $dbh = $self->_dbh or return 0;
 112
 113   local $dbh->{RaiseError} = 1;
 114   local $dbh->{PrintError} = 0;
 115
 116   return try {
 117     $dbh->do('select 1 from dual');
 118     1;
 119   } catch {
 120     0;
 121   };
 122 }
 123
 124 sub _dbh_execute {
 125   my $self = shift;
 126   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 127
 128   my (@res, $retried);
 129   my $wantarray = wantarray();
 130   my $next = $self->next::can;
 131   while (1) {
 132     try {
 133       my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
 134
 135       if (!defined $wantarray) {
 136         $exec->();
 137       }
 138       elsif (! $wantarray) {
 139         $res[0] = $exec->();
 140       }
 141       else {
 142         @res = $exec->();
 143       }
 144     }
 145     catch {
 146       if (!$retried++ and $_ =~ /ORA-01003/) {
 147         # ORA-01003: no statement parsed (someone changed the table somehow,
 148         # invalidating your cursor.)
 149         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 150         delete $dbh->{CachedKids}{$sql};
 151       }
 152       else {
 153         $self->throw_exception($_);
 154       }
 155     };
 156   }
 157
 158   return $wantarray ? @res : $res[0];
 159 }
 160
 161 =head2 get_autoinc_seq
 162
 163 Returns the sequence name for an autoincrement column
 164
 165 =cut
 166
 167 sub get_autoinc_seq {
 168   my ($self, $source, $col) = @_;
 169
 170   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 171 }
 172
 173 =head2 datetime_parser_type
 174
 175 This sets the proper DateTime::Format module for use with
 176 L<DBIx::Class::InflateColumn::DateTime>.
 177
 178 =cut
 179
 180 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 181
 182 =head2 connect_call_datetime_setup
 183
 184 Used as:
 185
 186     on_connect_call => 'datetime_setup'
 187
 188 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 189 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 190 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 191 is used by it.
 192
 193 Maximum allowable precision is used, unless the environment variables have
 194 already been set.
 195
 196 These are the defaults used:
 197
 198   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 199   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 200   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 201
 202 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 203 for your timestamps, use something like this:
 204
 205   use Time::HiRes 'time';
 206   my $ts = DateTime->from_epoch(epoch => time);
 207
 208 =cut
 209
 210 sub connect_call_datetime_setup {
 211   my $self = shift;
 212
 213   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 214   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 215     'YYYY-MM-DD HH24:MI:SS.FF';
 216   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 217     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 218
 219   $self->_do_query(
 220     "alter session set nls_date_format = '$date_format'"
 221   );
 222   $self->_do_query(
 223     "alter session set nls_timestamp_format = '$timestamp_format'"
 224   );
 225   $self->_do_query(
 226     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 227   );
 228 }
 229
 230 =head2 source_bind_attributes
 231
 232 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 233 with the driver assuming your input is the deprecated LONG type if you
 234 encode it as a hex string.  That ain't gonna fly at larger values, where
 235 you'll discover you have to do what this does.
 236
 237 This method had to be overridden because we need to set ora_field to the
 238 actual column, and that isn't passed to the call (provided by Storage) to
 239 bind_attribute_by_data_type.
 240
 241 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 242 adding it doesn't hurt, and will save your bacon if you're modifying a
 243 table with more than one LOB column.
 244
 245 =cut
 246
 247 sub source_bind_attributes
 248 {
 249   require DBD::Oracle;
 250   my $self = shift;
 251   my($source) = @_;
 252
 253   my %bind_attributes;
 254
 255   foreach my $column ($source->columns) {
 256     my $data_type = $source->column_info($column)->{data_type} || '';
 257     next unless $data_type;
 258
 259     my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 260
 261     if ($data_type =~ /^[BC]LOB$/i) {
 262       if ($DBD::Oracle::VERSION eq '1.23') {
 263         $self->throw_exception(
 264 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 265 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 266         );
 267       }
 268
 269       $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
 270         ? DBD::Oracle::ORA_CLOB()
 271         : DBD::Oracle::ORA_BLOB()
 272       ;
 273       $column_bind_attrs{'ora_field'} = $column;
 274     }
 275
 276     $bind_attributes{$column} = \%column_bind_attrs;
 277   }
 278
 279   return \%bind_attributes;
 280 }
 281
 282 sub _svp_begin {
 283   my ($self, $name) = @_;
 284   $self->_get_dbh->do("SAVEPOINT $name");
 285 }
 286
 287 # Oracle automatically releases a savepoint when you start another one with the
 288 # same name.
 289 sub _svp_release { 1 }
 290
 291 sub _svp_rollback {
 292   my ($self, $name) = @_;
 293   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 294 }
 295
 296 =head2 relname_to_table_alias
 297
 298 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 299 queries.
 300
 301 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 302 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 303 MD5 hash.
 304
 305 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 306
 307 =cut
 308
 309 sub relname_to_table_alias {
 310   my $self = shift;
 311   my ($relname, $join_count) = @_;
 312
 313   my $alias = $self->next::method(@_);
 314
 315   return $alias if length($alias) <= 30;
 316
 317   # get a base64 md5 of the alias with join_count
 318   require Digest::MD5;
 319   my $ctx = Digest::MD5->new;
 320   $ctx->add($alias);
 321   my $md5 = $ctx->b64digest;
 322
 323   # remove alignment mark just in case
 324   $md5 =~ s/=*\z//;
 325
 326   # truncate and prepend to truncated relname without vowels
 327   (my $devoweled = $relname) =~ s/[aeiou]//g;
 328   my $shortened = substr($devoweled, 0, 18);
 329
 330   my $new_alias =
 331     $shortened . '_' . substr($md5, 0, 30 - length($shortened) - 1);
 332
 333   return $new_alias;
 334 }
 335
 336 =head2 with_deferred_fk_checks
 337
 338 Runs a coderef between:
 339
 340   alter session set constraints = deferred
 341   ...
 342   alter session set constraints = immediate
 343
 344 to defer foreign key checks.
 345
 346 Constraints must be declared C<DEFERRABLE> for this to work.
 347
 348 =cut
 349
 350 sub with_deferred_fk_checks {
 351   my ($self, $sub) = @_;
 352
 353   my $txn_scope_guard = $self->txn_scope_guard;
 354
 355   $self->_do_query('alter session set constraints = deferred');
 356
 357   my $sg = Scope::Guard->new(sub {
 358     $self->_do_query('alter session set constraints = immediate');
 359   });
 360
 361   return Context::Preserve::preserve_context(sub { $sub->() },
 362     after => sub { $txn_scope_guard->commit });
 363 }
 364
 365 =head1 AUTHOR
 366
 367 See L<DBIx::Class/CONTRIBUTORS>.
 368
 369 =head1 LICENSE
 370
 371 You may distribute this code under the same terms as Perl itself.
 372
 373 =cut
 374
 375 1;