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