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