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 'preserve_context';
   7 use Try::Tiny;
   8 use namespace::clean;
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
  13
  14 =head1 SYNOPSIS
  15
  16   # In your result (table) classes
  17   use base 'DBIx::Class::Core';
  18   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  19   __PACKAGE__->set_primary_key('id');
  20   __PACKAGE__->sequence('mysequence');
  21
  22   # Somewhere in your Code
  23   # add some data to a table with a hierarchical relationship
  24   $schema->resultset('Person')->create ({
  25         firstname => 'foo',
  26         lastname => 'bar',
  27         children => [
  28             {
  29                 firstname => 'child1',
  30                 lastname => 'bar',
  31                 children => [
  32                     {
  33                         firstname => 'grandchild',
  34                         lastname => 'bar',
  35                     }
  36                 ],
  37             },
  38             {
  39                 firstname => 'child2',
  40                 lastname => 'bar',
  41             },
  42         ],
  43     });
  44
  45   # select from the hierarchical relationship
  46   my $rs = $schema->resultset('Person')->search({},
  47     {
  48       'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
  49       'connect_by' => { 'parentid' => { '-prior' => \'persionid' },
  50       'order_siblings_by' => { -asc => 'name' },
  51     };
  52   );
  53
  54   # this will select the whole tree starting from person "foo bar", creating
  55   # following query:
  56   # SELECT
  57   #     me.persionid me.firstname, me.lastname, me.parentid
  58   # FROM
  59   #     person me
  60   # START WITH
  61   #     firstname = 'foo' and lastname = 'bar'
  62   # CONNECT BY
  63   #     parentid = prior persionid
  64   # ORDER SIBLINGS BY
  65   #     firstname ASC
  66
  67 =head1 DESCRIPTION
  68
  69 This class implements base Oracle support. The subclass
  70 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
  71 versions before 9.
  72
  73 =head1 METHODS
  74
  75 =cut
  76
  77 use base qw/DBIx::Class::Storage::DBI/;
  78 use mro 'c3';
  79
  80 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
  81
  82 sub deployment_statements {
  83   my $self = shift;;
  84   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
  85
  86   $sqltargs ||= {};
  87   my $quote_char = $self->schema->storage->sql_maker->quote_char;
  88   $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
  89   $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
  90
  91   if (
  92     ! exists $sqltargs->{producer_args}{oracle_version}
  93       and
  94     my $dver = $self->_server_info->{dbms_version}
  95   ) {
  96     $sqltargs->{producer_args}{oracle_version} = $dver;
  97   }
  98
  99   $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
 100 }
 101
 102 sub _dbh_last_insert_id {
 103   my ($self, $dbh, $source, @columns) = @_;
 104   my @ids = ();
 105   foreach my $col (@columns) {
 106     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
 107     my $id = $self->_sequence_fetch( 'currval', $seq );
 108     push @ids, $id;
 109   }
 110   return @ids;
 111 }
 112
 113 sub _dbh_get_autoinc_seq {
 114   my ($self, $dbh, $source, $col) = @_;
 115
 116   my $sql_maker = $self->sql_maker;
 117
 118   my $source_name;
 119   if ( ref $source->name eq 'SCALAR' ) {
 120     $source_name = ${$source->name};
 121   }
 122   else {
 123     $source_name = $source->name;
 124   }
 125   $source_name = uc($source_name) unless $sql_maker->quote_char;
 126
 127   # trigger_body is a LONG
 128   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
 129
 130   # disable default bindtype
 131   local $sql_maker->{bindtype} = 'normal';
 132
 133   # look up the correct sequence automatically
 134   my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
 135   my ($sql, @bind) = $sql_maker->select (
 136     'ALL_TRIGGERS',
 137     ['trigger_body'],
 138     {
 139       $schema ? (owner => $schema) : (),
 140       table_name => $table || $source_name,
 141       triggering_event => { -like => '%INSERT%' },
 142       status => 'ENABLED',
 143      },
 144   );
 145   my $sth = $dbh->prepare($sql);
 146   $sth->execute (@bind);
 147
 148   while (my ($insert_trigger) = $sth->fetchrow_array) {
 149     return $1 if $insert_trigger =~ m!("?\w+"?)\.nextval!i; # col name goes here???
 150   }
 151   $self->throw_exception("Unable to find a sequence INSERT trigger on table '$source_name'.");
 152 }
 153
 154 sub _sequence_fetch {
 155   my ( $self, $type, $seq ) = @_;
 156   my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
 157   return $id;
 158 }
 159
 160 sub _ping {
 161   my $self = shift;
 162
 163   my $dbh = $self->_dbh or return 0;
 164
 165   local $dbh->{RaiseError} = 1;
 166   local $dbh->{PrintError} = 0;
 167
 168   return try {
 169     $dbh->do('select 1 from dual');
 170     1;
 171   } catch {
 172     0;
 173   };
 174 }
 175
 176 sub _dbh_execute {
 177   my $self = shift;
 178   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 179
 180   my (@res, $tried);
 181   my $wantarray = wantarray();
 182   my $next = $self->next::can;
 183   do {
 184     try {
 185       my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
 186
 187       if (!defined $wantarray) {
 188         $exec->();
 189       }
 190       elsif (! $wantarray) {
 191         $res[0] = $exec->();
 192       }
 193       else {
 194         @res = $exec->();
 195       }
 196
 197       $tried++;
 198     }
 199     catch {
 200       if (! $tried and $_ =~ /ORA-01003/) {
 201         # ORA-01003: no statement parsed (someone changed the table somehow,
 202         # invalidating your cursor.)
 203         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 204         delete $dbh->{CachedKids}{$sql};
 205       }
 206       else {
 207         $self->throw_exception($_);
 208       }
 209     };
 210   } while (! $tried++);
 211
 212   return $wantarray ? @res : $res[0];
 213 }
 214
 215 =head2 get_autoinc_seq
 216
 217 Returns the sequence name for an autoincrement column
 218
 219 =cut
 220
 221 sub get_autoinc_seq {
 222   my ($self, $source, $col) = @_;
 223
 224   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 225 }
 226
 227 =head2 datetime_parser_type
 228
 229 This sets the proper DateTime::Format module for use with
 230 L<DBIx::Class::InflateColumn::DateTime>.
 231
 232 =cut
 233
 234 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 235
 236 =head2 connect_call_datetime_setup
 237
 238 Used as:
 239
 240     on_connect_call => 'datetime_setup'
 241
 242 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 243 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 244 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 245 is used by it.
 246
 247 Maximum allowable precision is used, unless the environment variables have
 248 already been set.
 249
 250 These are the defaults used:
 251
 252   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 253   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 254   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 255
 256 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 257 for your timestamps, use something like this:
 258
 259   use Time::HiRes 'time';
 260   my $ts = DateTime->from_epoch(epoch => time);
 261
 262 =cut
 263
 264 sub connect_call_datetime_setup {
 265   my $self = shift;
 266
 267   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 268   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 269     'YYYY-MM-DD HH24:MI:SS.FF';
 270   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 271     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 272
 273   $self->_do_query(
 274     "alter session set nls_date_format = '$date_format'"
 275   );
 276   $self->_do_query(
 277     "alter session set nls_timestamp_format = '$timestamp_format'"
 278   );
 279   $self->_do_query(
 280     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 281   );
 282 }
 283
 284 =head2 source_bind_attributes
 285
 286 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 287 with the driver assuming your input is the deprecated LONG type if you
 288 encode it as a hex string.  That ain't gonna fly at larger values, where
 289 you'll discover you have to do what this does.
 290
 291 This method had to be overridden because we need to set ora_field to the
 292 actual column, and that isn't passed to the call (provided by Storage) to
 293 bind_attribute_by_data_type.
 294
 295 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 296 adding it doesn't hurt, and will save your bacon if you're modifying a
 297 table with more than one LOB column.
 298
 299 =cut
 300
 301 sub source_bind_attributes
 302 {
 303   require DBD::Oracle;
 304   my $self = shift;
 305   my($source) = @_;
 306
 307   my %bind_attributes;
 308
 309   foreach my $column ($source->columns) {
 310     my $data_type = $source->column_info($column)->{data_type} || '';
 311     next unless $data_type;
 312
 313     my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 314
 315     if ($data_type =~ /^[BC]LOB$/i) {
 316       if ($DBD::Oracle::VERSION eq '1.23') {
 317         $self->throw_exception(
 318 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 319 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 320         );
 321       }
 322
 323       $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
 324         ? DBD::Oracle::ORA_CLOB()
 325         : DBD::Oracle::ORA_BLOB()
 326       ;
 327       $column_bind_attrs{'ora_field'} = $column;
 328     }
 329
 330     $bind_attributes{$column} = \%column_bind_attrs;
 331   }
 332
 333   return \%bind_attributes;
 334 }
 335
 336 sub _svp_begin {
 337   my ($self, $name) = @_;
 338   $self->_get_dbh->do("SAVEPOINT $name");
 339 }
 340
 341 # Oracle automatically releases a savepoint when you start another one with the
 342 # same name.
 343 sub _svp_release { 1 }
 344
 345 sub _svp_rollback {
 346   my ($self, $name) = @_;
 347   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 348 }
 349
 350 =head2 relname_to_table_alias
 351
 352 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 353 queries.
 354
 355 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 356 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 357 MD5 hash.
 358
 359 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 360
 361 =cut
 362
 363 sub relname_to_table_alias {
 364   my $self = shift;
 365   my ($relname, $join_count) = @_;
 366
 367   my $alias = $self->next::method(@_);
 368
 369   return $self->sql_maker->_shorten_identifier($alias, [$relname]);
 370 }
 371
 372 =head2 with_deferred_fk_checks
 373
 374 Runs a coderef between:
 375
 376   alter session set constraints = deferred
 377   ...
 378   alter session set constraints = immediate
 379
 380 to defer foreign key checks.
 381
 382 Constraints must be declared C<DEFERRABLE> for this to work.
 383
 384 =cut
 385
 386 sub with_deferred_fk_checks {
 387   my ($self, $sub) = @_;
 388
 389   my $txn_scope_guard = $self->txn_scope_guard;
 390
 391   $self->_do_query('alter session set constraints = deferred');
 392
 393   my $sg = Scope::Guard->new(sub {
 394     $self->_do_query('alter session set constraints = immediate');
 395   });
 396
 397   return
 398     preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
 399 }
 400
 401 =head1 ATTRIBUTES
 402
 403 Following additional attributes can be used in resultsets.
 404
 405 =head2 connect_by or connect_by_nocycle
 406
 407 =over 4
 408
 409 =item Value: \%connect_by
 410
 411 =back
 412
 413 A hashref of conditions used to specify the relationship between parent rows
 414 and child rows of the hierarchy.
 415
 416
 417   connect_by => { parentid => 'prior personid' }
 418
 419   # adds a connect by statement to the query:
 420   # SELECT
 421   #     me.persionid me.firstname, me.lastname, me.parentid
 422   # FROM
 423   #     person me
 424   # CONNECT BY
 425   #     parentid = prior persionid
 426
 427
 428   connect_by_nocycle => { parentid => 'prior personid' }
 429
 430   # adds a connect by statement to the query:
 431   # SELECT
 432   #     me.persionid me.firstname, me.lastname, me.parentid
 433   # FROM
 434   #     person me
 435   # CONNECT BY NOCYCLE
 436   #     parentid = prior persionid
 437
 438
 439 =head2 start_with
 440
 441 =over 4
 442
 443 =item Value: \%condition
 444
 445 =back
 446
 447 A hashref of conditions which specify the root row(s) of the hierarchy.
 448
 449 It uses the same syntax as L<DBIx::Class::ResultSet/search>
 450
 451   start_with => { firstname => 'Foo', lastname => 'Bar' }
 452
 453   # SELECT
 454   #     me.persionid me.firstname, me.lastname, me.parentid
 455   # FROM
 456   #     person me
 457   # START WITH
 458   #     firstname = 'foo' and lastname = 'bar'
 459   # CONNECT BY
 460   #     parentid = prior persionid
 461
 462 =head2 order_siblings_by
 463
 464 =over 4
 465
 466 =item Value: ($order_siblings_by | \@order_siblings_by)
 467
 468 =back
 469
 470 Which column(s) to order the siblings by.
 471
 472 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
 473
 474   'order_siblings_by' => 'firstname ASC'
 475
 476   # SELECT
 477   #     me.persionid me.firstname, me.lastname, me.parentid
 478   # FROM
 479   #     person me
 480   # CONNECT BY
 481   #     parentid = prior persionid
 482   # ORDER SIBLINGS BY
 483   #     firstname ASC
 484
 485 =head1 AUTHOR
 486
 487 See L<DBIx::Class/CONTRIBUTORS>.
 488
 489 =head1 LICENSE
 490
 491 You may distribute this code under the same terms as Perl itself.
 492
 493 =cut
 494
 495 1;