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, $dbh, $sql, @args) = @_;
 276
 277   my (@res, $tried);
 278   my $want = wantarray;
 279   my $next = $self->next::can;
 280   do {
 281     try {
 282       my $exec = sub { $self->$next($dbh, $sql, @args) };
 283
 284       if (!defined $want) {
 285         $exec->();
 286       }
 287       elsif (! $want) {
 288         $res[0] = $exec->();
 289       }
 290       else {
 291         @res = $exec->();
 292       }
 293
 294       $tried++;
 295     }
 296     catch {
 297       if (! $tried and $_ =~ /ORA-01003/) {
 298         # ORA-01003: no statement parsed (someone changed the table somehow,
 299         # invalidating your cursor.)
 300         delete $dbh->{CachedKids}{$sql};
 301       }
 302       else {
 303         $self->throw_exception($_);
 304       }
 305     };
 306   } while (! $tried++);
 307
 308   return wantarray ? @res : $res[0];
 309 }
 310
 311 sub _dbh_execute_array {
 312   #my ($self, $sth, $tuple_status, @extra) = @_;
 313
 314   # DBD::Oracle warns loudly on partial execute_array failures
 315   local $_[1]->{PrintWarn} = 0;
 316
 317   shift->next::method(@_);
 318 }
 319
 320 =head2 get_autoinc_seq
 321
 322 Returns the sequence name for an autoincrement column
 323
 324 =cut
 325
 326 sub get_autoinc_seq {
 327   my ($self, $source, $col) = @_;
 328
 329   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 330 }
 331
 332 =head2 datetime_parser_type
 333
 334 This sets the proper DateTime::Format module for use with
 335 L<DBIx::Class::InflateColumn::DateTime>.
 336
 337 =head2 connect_call_datetime_setup
 338
 339 Used as:
 340
 341     on_connect_call => 'datetime_setup'
 342
 343 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 344 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 345 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 346 is used by it.
 347
 348 Maximum allowable precision is used, unless the environment variables have
 349 already been set.
 350
 351 These are the defaults used:
 352
 353   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 354   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 355   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 356
 357 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 358 for your timestamps, use something like this:
 359
 360   use Time::HiRes 'time';
 361   my $ts = DateTime->from_epoch(epoch => time);
 362
 363 =cut
 364
 365 sub connect_call_datetime_setup {
 366   my $self = shift;
 367
 368   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 369   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 370     'YYYY-MM-DD HH24:MI:SS.FF';
 371   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 372     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 373
 374   $self->_do_query(
 375     "alter session set nls_date_format = '$date_format'"
 376   );
 377   $self->_do_query(
 378     "alter session set nls_timestamp_format = '$timestamp_format'"
 379   );
 380   $self->_do_query(
 381     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 382   );
 383 }
 384
 385 ### Note originally by Ron "Quinn" Straight <quinnfazigu@gmail.org>
 386 ### http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits/DBIx-Class.git;a=commitdiff;h=5db2758de644d53e07cd3e05f0e9037bf40116fc
 387 #
 388 # Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 389 # with the driver assuming your input is the deprecated LONG type if you
 390 # encode it as a hex string.  That ain't gonna fly at larger values, where
 391 # you'll discover you have to do what this does.
 392 #
 393 # This method had to be overridden because we need to set ora_field to the
 394 # actual column, and that isn't passed to the call (provided by Storage) to
 395 # bind_attribute_by_data_type.
 396 #
 397 # According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 398 # adding it doesn't hurt, and will save your bacon if you're modifying a
 399 # table with more than one LOB column.
 400 #
 401 sub _dbi_attrs_for_bind {
 402   my ($self, $ident, $bind) = @_;
 403   my $attrs = $self->next::method($ident, $bind);
 404
 405   for my $i (0 .. $#$attrs) {
 406     if (keys %{$attrs->[$i]||{}} and my $col = $bind->[$i][0]{dbic_colname}) {
 407       $attrs->[$i]{ora_field} = $col;
 408     }
 409   }
 410
 411   $attrs;
 412 }
 413
 414 my $dbd_loaded;
 415 sub bind_attribute_by_data_type {
 416   my ($self, $dt) = @_;
 417
 418   $dbd_loaded ||= do {
 419     require DBD::Oracle;
 420     if ($DBD::Oracle::VERSION eq '1.23') {
 421       $self->throw_exception(
 422         "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 423         "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 424       );
 425     }
 426     1;
 427   };
 428
 429   if ($self->_is_lob_type($dt)) {
 430     return {
 431       ora_type => $self->_is_text_lob_type($dt)
 432         ? DBD::Oracle::ORA_CLOB()
 433         : DBD::Oracle::ORA_BLOB()
 434     };
 435   }
 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;