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