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 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 =cut
 338
 339 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 340
 341 =head2 connect_call_datetime_setup
 342
 343 Used as:
 344
 345     on_connect_call => 'datetime_setup'
 346
 347 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 348 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 349 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 350 is used by it.
 351
 352 Maximum allowable precision is used, unless the environment variables have
 353 already been set.
 354
 355 These are the defaults used:
 356
 357   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 358   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 359   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 360
 361 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 362 for your timestamps, use something like this:
 363
 364   use Time::HiRes 'time';
 365   my $ts = DateTime->from_epoch(epoch => time);
 366
 367 =cut
 368
 369 sub connect_call_datetime_setup {
 370   my $self = shift;
 371
 372   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 373   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 374     'YYYY-MM-DD HH24:MI:SS.FF';
 375   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 376     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 377
 378   $self->_do_query(
 379     "alter session set nls_date_format = '$date_format'"
 380   );
 381   $self->_do_query(
 382     "alter session set nls_timestamp_format = '$timestamp_format'"
 383   );
 384   $self->_do_query(
 385     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 386   );
 387 }
 388
 389 =head2 source_bind_attributes
 390
 391 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 392 with the driver assuming your input is the deprecated LONG type if you
 393 encode it as a hex string.  That ain't gonna fly at larger values, where
 394 you'll discover you have to do what this does.
 395
 396 This method had to be overridden because we need to set ora_field to the
 397 actual column, and that isn't passed to the call (provided by Storage) to
 398 bind_attribute_by_data_type.
 399
 400 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 401 adding it doesn't hurt, and will save your bacon if you're modifying a
 402 table with more than one LOB column.
 403
 404 =cut
 405
 406 sub source_bind_attributes
 407 {
 408   require DBD::Oracle;
 409   my $self = shift;
 410   my($source) = @_;
 411
 412   my %bind_attributes;
 413
 414   foreach my $column ($source->columns) {
 415     my $data_type = $source->column_info($column)->{data_type}
 416       or next;
 417
 418     my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 419
 420     if ($data_type =~ /^[BC]LOB$/i) {
 421       if ($DBD::Oracle::VERSION eq '1.23') {
 422         $self->throw_exception(
 423 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 424 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 425         );
 426       }
 427
 428       $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
 429         ? DBD::Oracle::ORA_CLOB()
 430         : DBD::Oracle::ORA_BLOB()
 431       ;
 432       $column_bind_attrs{'ora_field'} = $column;
 433     }
 434
 435     $bind_attributes{$column} = \%column_bind_attrs;
 436   }
 437
 438   return \%bind_attributes;
 439 }
 440
 441 sub _svp_begin {
 442   my ($self, $name) = @_;
 443   $self->_get_dbh->do("SAVEPOINT $name");
 444 }
 445
 446 # Oracle automatically releases a savepoint when you start another one with the
 447 # same name.
 448 sub _svp_release { 1 }
 449
 450 sub _svp_rollback {
 451   my ($self, $name) = @_;
 452   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 453 }
 454
 455 =head2 relname_to_table_alias
 456
 457 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 458 queries.
 459
 460 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 461 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 462 MD5 hash.
 463
 464 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 465
 466 =cut
 467
 468 sub relname_to_table_alias {
 469   my $self = shift;
 470   my ($relname, $join_count) = @_;
 471
 472   my $alias = $self->next::method(@_);
 473
 474   return $self->sql_maker->_shorten_identifier($alias, [$relname]);
 475 }
 476
 477 =head2 with_deferred_fk_checks
 478
 479 Runs a coderef between:
 480
 481   alter session set constraints = deferred
 482   ...
 483   alter session set constraints = immediate
 484
 485 to defer foreign key checks.
 486
 487 Constraints must be declared C<DEFERRABLE> for this to work.
 488
 489 =cut
 490
 491 sub with_deferred_fk_checks {
 492   my ($self, $sub) = @_;
 493
 494   my $txn_scope_guard = $self->txn_scope_guard;
 495
 496   $self->_do_query('alter session set constraints = deferred');
 497
 498   my $sg = Scope::Guard->new(sub {
 499     $self->_do_query('alter session set constraints = immediate');
 500   });
 501
 502   return
 503     preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
 504 }
 505
 506 =head1 ATTRIBUTES
 507
 508 Following additional attributes can be used in resultsets.
 509
 510 =head2 connect_by or connect_by_nocycle
 511
 512 =over 4
 513
 514 =item Value: \%connect_by
 515
 516 =back
 517
 518 A hashref of conditions used to specify the relationship between parent rows
 519 and child rows of the hierarchy.
 520
 521
 522   connect_by => { parentid => 'prior personid' }
 523
 524   # adds a connect by statement to the query:
 525   # SELECT
 526   #     me.persionid me.firstname, me.lastname, me.parentid
 527   # FROM
 528   #     person me
 529   # CONNECT BY
 530   #     parentid = prior persionid
 531
 532
 533   connect_by_nocycle => { parentid => 'prior personid' }
 534
 535   # adds a connect by statement to the query:
 536   # SELECT
 537   #     me.persionid me.firstname, me.lastname, me.parentid
 538   # FROM
 539   #     person me
 540   # CONNECT BY NOCYCLE
 541   #     parentid = prior persionid
 542
 543
 544 =head2 start_with
 545
 546 =over 4
 547
 548 =item Value: \%condition
 549
 550 =back
 551
 552 A hashref of conditions which specify the root row(s) of the hierarchy.
 553
 554 It uses the same syntax as L<DBIx::Class::ResultSet/search>
 555
 556   start_with => { firstname => 'Foo', lastname => 'Bar' }
 557
 558   # SELECT
 559   #     me.persionid me.firstname, me.lastname, me.parentid
 560   # FROM
 561   #     person me
 562   # START WITH
 563   #     firstname = 'foo' and lastname = 'bar'
 564   # CONNECT BY
 565   #     parentid = prior persionid
 566
 567 =head2 order_siblings_by
 568
 569 =over 4
 570
 571 =item Value: ($order_siblings_by | \@order_siblings_by)
 572
 573 =back
 574
 575 Which column(s) to order the siblings by.
 576
 577 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
 578
 579   'order_siblings_by' => 'firstname ASC'
 580
 581   # SELECT
 582   #     me.persionid me.firstname, me.lastname, me.parentid
 583   # FROM
 584   #     person me
 585   # CONNECT BY
 586   #     parentid = prior persionid
 587   # ORDER SIBLINGS BY
 588   #     firstname ASC
 589
 590 =head1 AUTHOR
 591
 592 See L<DBIx::Class/CONTRIBUTORS>.
 593
 594 =head1 LICENSE
 595
 596 You may distribute this code under the same terms as Perl itself.
 597
 598 =cut
 599
 600 1;