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;
 414
 415   foreach my $column ($source->columns) {
 416     my $data_type = $source->column_info($column)->{data_type}
 417       or next;
 418
 419     my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 420
 421     if ($data_type =~ /^[BC]LOB$/i) {
 422       if ($DBD::Oracle::VERSION eq '1.23') {
 423         $self->throw_exception(
 424 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 425 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 426         );
 427       }
 428
 429       $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
 430         ? DBD::Oracle::ORA_CLOB()
 431         : DBD::Oracle::ORA_BLOB()
 432       ;
 433       $column_bind_attrs{'ora_field'} = $column;
 434     }
 435
 436     $bind_attributes{$column} = \%column_bind_attrs;
 437   }
 438
 439   return \%bind_attributes;
 440 }
 441
 442 sub _svp_begin {
 443   my ($self, $name) = @_;
 444   $self->_get_dbh->do("SAVEPOINT $name");
 445 }
 446
 447 # Oracle automatically releases a savepoint when you start another one with the
 448 # same name.
 449 sub _svp_release { 1 }
 450
 451 sub _svp_rollback {
 452   my ($self, $name) = @_;
 453   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 454 }
 455
 456 =head2 relname_to_table_alias
 457
 458 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 459 queries.
 460
 461 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 462 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 463 MD5 hash.
 464
 465 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 466
 467 =cut
 468
 469 sub relname_to_table_alias {
 470   my $self = shift;
 471   my ($relname, $join_count) = @_;
 472
 473   my $alias = $self->next::method(@_);
 474
 475   return $self->sql_maker->_shorten_identifier($alias, [$relname]);
 476 }
 477
 478 =head2 with_deferred_fk_checks
 479
 480 Runs a coderef between:
 481
 482   alter session set constraints = deferred
 483   ...
 484   alter session set constraints = immediate
 485
 486 to defer foreign key checks.
 487
 488 Constraints must be declared C<DEFERRABLE> for this to work.
 489
 490 =cut
 491
 492 sub with_deferred_fk_checks {
 493   my ($self, $sub) = @_;
 494
 495   my $txn_scope_guard = $self->txn_scope_guard;
 496
 497   $self->_do_query('alter session set constraints = deferred');
 498
 499   my $sg = Scope::Guard->new(sub {
 500     $self->_do_query('alter session set constraints = immediate');
 501   });
 502
 503   return
 504     preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
 505 }
 506
 507 =head1 ATTRIBUTES
 508
 509 Following additional attributes can be used in resultsets.
 510
 511 =head2 connect_by or connect_by_nocycle
 512
 513 =over 4
 514
 515 =item Value: \%connect_by
 516
 517 =back
 518
 519 A hashref of conditions used to specify the relationship between parent rows
 520 and child rows of the hierarchy.
 521
 522
 523   connect_by => { parentid => 'prior personid' }
 524
 525   # adds a connect by statement to the query:
 526   # SELECT
 527   #     me.persionid me.firstname, me.lastname, me.parentid
 528   # FROM
 529   #     person me
 530   # CONNECT BY
 531   #     parentid = prior persionid
 532
 533
 534   connect_by_nocycle => { parentid => 'prior personid' }
 535
 536   # adds a connect by statement to the query:
 537   # SELECT
 538   #     me.persionid me.firstname, me.lastname, me.parentid
 539   # FROM
 540   #     person me
 541   # CONNECT BY NOCYCLE
 542   #     parentid = prior persionid
 543
 544
 545 =head2 start_with
 546
 547 =over 4
 548
 549 =item Value: \%condition
 550
 551 =back
 552
 553 A hashref of conditions which specify the root row(s) of the hierarchy.
 554
 555 It uses the same syntax as L<DBIx::Class::ResultSet/search>
 556
 557   start_with => { firstname => 'Foo', lastname => 'Bar' }
 558
 559   # SELECT
 560   #     me.persionid me.firstname, me.lastname, me.parentid
 561   # FROM
 562   #     person me
 563   # START WITH
 564   #     firstname = 'foo' and lastname = 'bar'
 565   # CONNECT BY
 566   #     parentid = prior persionid
 567
 568 =head2 order_siblings_by
 569
 570 =over 4
 571
 572 =item Value: ($order_siblings_by | \@order_siblings_by)
 573
 574 =back
 575
 576 Which column(s) to order the siblings by.
 577
 578 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
 579
 580   'order_siblings_by' => 'firstname ASC'
 581
 582   # SELECT
 583   #     me.persionid me.firstname, me.lastname, me.parentid
 584   # FROM
 585   #     person me
 586   # CONNECT BY
 587   #     parentid = prior persionid
 588   # ORDER SIBLINGS BY
 589   #     firstname ASC
 590
 591 =head1 AUTHOR
 592
 593 See L<DBIx::Class/CONTRIBUTORS>.
 594
 595 =head1 LICENSE
 596
 597 You may distribute this code under the same terms as Perl itself.
 598
 599 =cut
 600
 601 1;