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