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