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
  84 sub _determine_supports_insert_returning {
  85   my $self = shift;
  86
  87 # TODO find out which version supports the RETURNING syntax
  88 # 8i has it and earlier docs are a 404 on oracle.com
  89
  90   return 1
  91     if $self->_server_info->{normalized_dbms_version} >= 8.001;
  92
  93   return 0;
  94 }
  95
  96 __PACKAGE__->_use_insert_returning_bound (1);
  97
  98 sub deployment_statements {
  99   my $self = shift;;
 100   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
 101
 102   $sqltargs ||= {};
 103   my $quote_char = $self->schema->storage->sql_maker->quote_char;
 104   $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
 105   $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
 106
 107   if (
 108     ! exists $sqltargs->{producer_args}{oracle_version}
 109       and
 110     my $dver = $self->_server_info->{dbms_version}
 111   ) {
 112     $sqltargs->{producer_args}{oracle_version} = $dver;
 113   }
 114
 115   $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
 116 }
 117
 118 sub _dbh_last_insert_id {
 119   my ($self, $dbh, $source, @columns) = @_;
 120   my @ids = ();
 121   foreach my $col (@columns) {
 122     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
 123     my $id = $self->_sequence_fetch( 'CURRVAL', $seq );
 124     push @ids, $id;
 125   }
 126   return @ids;
 127 }
 128
 129 sub _dbh_get_autoinc_seq {
 130   my ($self, $dbh, $source, $col) = @_;
 131
 132   my $sql_maker = $self->sql_maker;
 133   my ($ql, $qr) = map { $_ ? (quotemeta $_) : '' } $sql_maker->_quote_chars;
 134
 135   my $source_name;
 136   if ( ref $source->name eq 'SCALAR' ) {
 137     $source_name = ${$source->name};
 138
 139     # the ALL_TRIGGERS match further on is case sensitive - thus uppercase
 140     # stuff unless it is already quoted
 141     $source_name = uc ($source_name) if $source_name !~ /\"/;
 142   }
 143   else {
 144     $source_name = $source->name;
 145     $source_name = uc($source_name) unless $ql;
 146   }
 147
 148   # trigger_body is a LONG
 149   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
 150
 151   # disable default bindtype
 152   local $sql_maker->{bindtype} = 'normal';
 153
 154   # look up the correct sequence automatically
 155   my ( $schema, $table ) = $source_name =~ /( (?:${ql})? \w+ (?:${qr})? ) \. ( (?:${ql})? \w+ (?:${qr})? )/x;
 156
 157   # if no explicit schema was requested - use the default schema (which in the case of Oracle is the db user)
 158   $schema ||= uc( ($self->_dbi_connect_info||[])->[1] || '');
 159
 160   my ($sql, @bind) = $sql_maker->select (
 161     'ALL_TRIGGERS',
 162     [qw/TRIGGER_BODY TABLE_OWNER TRIGGER_NAME/],
 163     {
 164       $schema ? (OWNER => $schema) : (),
 165       TABLE_NAME => $table || $source_name,
 166       TRIGGERING_EVENT => { -like => '%INSERT%' },  # this will also catch insert_or_update
 167       TRIGGER_TYPE => { -like => '%BEFORE%' },      # we care only about 'before' triggers
 168       STATUS => 'ENABLED',
 169      },
 170   );
 171
 172   # to find all the triggers that mention the column in question a simple
 173   # regex grep since the trigger_body above is a LONG and hence not searchable
 174   my @triggers = ( map
 175     { my %inf; @inf{qw/body schema name/} = @$_; \%inf }
 176     ( grep
 177       { $_->[0] =~ /\:new\.${ql}${col}${qr} | \:new\.$col/xi }
 178       @{ $dbh->selectall_arrayref( $sql, {}, @bind ) }
 179     )
 180   );
 181
 182   # extract all sequence names mentioned in each trigger
 183   for (@triggers) {
 184     $_->{sequences} = [ $_->{body} =~ / ( "? [\.\w\"\-]+ "? ) \. nextval /xig ];
 185   }
 186
 187   my $chosen_trigger;
 188
 189   # if only one trigger matched things are easy
 190   if (@triggers == 1) {
 191
 192     if ( @{$triggers[0]{sequences}} == 1 ) {
 193       $chosen_trigger = $triggers[0];
 194     }
 195     else {
 196       $self->throw_exception( sprintf (
 197         "Unable to introspect trigger '%s' for column %s.%s (references multiple sequences). "
 198       . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
 199         $triggers[0]{name},
 200         $source_name,
 201         $col,
 202         $col,
 203       ) );
 204     }
 205   }
 206   # got more than one matching trigger - see if we can narrow it down
 207   elsif (@triggers > 1) {
 208
 209     my @candidates = grep
 210       { $_->{body} =~ / into \s+ \:new\.$col /xi }
 211       @triggers
 212     ;
 213
 214     if (@candidates == 1 && @{$candidates[0]{sequences}} == 1) {
 215       $chosen_trigger = $candidates[0];
 216     }
 217     else {
 218       $self->throw_exception( sprintf (
 219         "Unable to reliably select a BEFORE INSERT trigger for column %s.%s (possibilities: %s). "
 220       . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
 221         $source_name,
 222         $col,
 223         ( join ', ', map { "'$_->{name}'" } @triggers ),
 224         $col,
 225       ) );
 226     }
 227   }
 228
 229   if ($chosen_trigger) {
 230     my $seq_name = $chosen_trigger->{sequences}[0];
 231
 232     $seq_name = "$chosen_trigger->{schema}.$seq_name"
 233       unless $seq_name =~ /\./;
 234
 235     return \$seq_name if $seq_name =~ /\"/; # may already be quoted in-trigger
 236     return $seq_name;
 237   }
 238
 239   $self->throw_exception( sprintf (
 240     "No suitable BEFORE INSERT triggers found for column %s.%s. "
 241   . "You need to specify the correct 'sequence' explicitly in '%s's column_info.",
 242     $source_name,
 243     $col,
 244     $col,
 245   ));
 246 }
 247
 248 sub _sequence_fetch {
 249   my ( $self, $type, $seq ) = @_;
 250
 251   # use the maker to leverage quoting settings
 252   my $sql_maker = $self->sql_maker;
 253   my ($id) = $self->_get_dbh->selectrow_array ($sql_maker->select('DUAL', [ ref $seq ? \"$$seq.$type" : "$seq.$type" ] ) );
 254   return $id;
 255 }
 256
 257 sub _ping {
 258   my $self = shift;
 259
 260   my $dbh = $self->_dbh or return 0;
 261
 262   local $dbh->{RaiseError} = 1;
 263   local $dbh->{PrintError} = 0;
 264
 265   return try {
 266     $dbh->do('select 1 from dual');
 267     1;
 268   } catch {
 269     0;
 270   };
 271 }
 272
 273 sub _dbh_execute {
 274   my $self = shift;
 275   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @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, $op, $extra_bind, $ident, $bind_attributes, @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         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 301         delete $dbh->{CachedKids}{$sql};
 302       }
 303       else {
 304         $self->throw_exception($_);
 305       }
 306     };
 307   } while (! $tried++);
 308
 309   return wantarray ? @res : $res[0];
 310 }
 311
 312 sub _dbh_execute_array {
 313   #my ($self, $sth, $tuple_status, @extra) = @_;
 314
 315   # DBD::Oracle warns loudly on partial execute_array failures
 316   local $_[1]->{PrintWarn} = 0;
 317
 318   shift->next::method(@_);
 319 }
 320
 321 =head2 get_autoinc_seq
 322
 323 Returns the sequence name for an autoincrement column
 324
 325 =cut
 326
 327 sub get_autoinc_seq {
 328   my ($self, $source, $col) = @_;
 329
 330   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 331 }
 332
 333 =head2 datetime_parser_type
 334
 335 This sets the proper DateTime::Format module for use with
 336 L<DBIx::Class::InflateColumn::DateTime>.
 337
 338 =cut
 339
 340 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 341
 342 =head2 connect_call_datetime_setup
 343
 344 Used as:
 345
 346     on_connect_call => 'datetime_setup'
 347
 348 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 349 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 350 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 351 is used by it.
 352
 353 Maximum allowable precision is used, unless the environment variables have
 354 already been set.
 355
 356 These are the defaults used:
 357
 358   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 359   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 360   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 361
 362 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 363 for your timestamps, use something like this:
 364
 365   use Time::HiRes 'time';
 366   my $ts = DateTime->from_epoch(epoch => time);
 367
 368 =cut
 369
 370 sub connect_call_datetime_setup {
 371   my $self = shift;
 372
 373   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 374   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 375     'YYYY-MM-DD HH24:MI:SS.FF';
 376   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 377     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 378
 379   $self->_do_query(
 380     "alter session set nls_date_format = '$date_format'"
 381   );
 382   $self->_do_query(
 383     "alter session set nls_timestamp_format = '$timestamp_format'"
 384   );
 385   $self->_do_query(
 386     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 387   );
 388 }
 389
 390 =head2 source_bind_attributes
 391
 392 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 393 with the driver assuming your input is the deprecated LONG type if you
 394 encode it as a hex string.  That ain't gonna fly at larger values, where
 395 you'll discover you have to do what this does.
 396
 397 This method had to be overridden because we need to set ora_field to the
 398 actual column, and that isn't passed to the call (provided by Storage) to
 399 bind_attribute_by_data_type.
 400
 401 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 402 adding it doesn't hurt, and will save your bacon if you're modifying a
 403 table with more than one LOB column.
 404
 405 =cut
 406
 407 sub source_bind_attributes
 408 {
 409   require DBD::Oracle;
 410   my $self = shift;
 411   my($source) = @_;
 412
 413   my %bind_attributes = %{ $self->next::method(@_) };
 414
 415   foreach my $column ($source->columns) {
 416     my %column_bind_attrs = %{ $bind_attributes{$column} || {} };
 417
 418     my $data_type = $source->column_info($column)->{data_type};
 419
 420     if ($self->_is_lob_type($data_type)) {
 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'} = $self->_is_text_lob_type($data_type)
 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;