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