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 =head1 NAME
  11
  12 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
  13
  14 =head1 SYNOPSIS
  15
  16   # In your result (table) classes
  17   use base 'DBIx::Class::Core';
  18   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  19   __PACKAGE__->set_primary_key('id');
  20   __PACKAGE__->sequence('mysequence');
  21
  22   # Somewhere in your Code
  23   # add some data to a table with a hierarchical relationship
  24   $schema->resultset('Person')->create ({
  25         firstname => 'foo',
  26         lastname => 'bar',
  27         children => [
  28             {
  29                 firstname => 'child1',
  30                 lastname => 'bar',
  31                 children => [
  32                     {
  33                         firstname => 'grandchild',
  34                         lastname => 'bar',
  35                     }
  36                 ],
  37             },
  38             {
  39                 firstname => 'child2',
  40                 lastname => 'bar',
  41             },
  42         ],
  43     });
  44
  45   # select from the hierarchical relationship
  46   my $rs = $schema->resultset('Person')->search({},
  47     {
  48       'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
  49       'connect_by' => { 'parentid' => { '-prior' => \'persionid' },
  50       'order_siblings_by' => { -asc => 'name' },
  51     };
  52   );
  53
  54   # this will select the whole tree starting from person "foo bar", creating
  55   # following query:
  56   # SELECT
  57   #     me.persionid me.firstname, me.lastname, me.parentid
  58   # FROM
  59   #     person me
  60   # START WITH
  61   #     firstname = 'foo' and lastname = 'bar'
  62   # CONNECT BY
  63   #     parentid = prior persionid
  64   # ORDER SIBLINGS BY
  65   #     firstname ASC
  66
  67 =head1 DESCRIPTION
  68
  69 This class implements base Oracle support. The subclass
  70 L<DBIx::Class::Storage::DBI::Oracle::WhereJoins> is for C<(+)> joins in Oracle
  71 versions before 9.
  72
  73 =head1 METHODS
  74
  75 =cut
  76
  77 use base qw/DBIx::Class::Storage::DBI/;
  78 use mro 'c3';
  79
  80 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
  81
  82 sub deployment_statements {
  83   my $self = shift;;
  84   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;
  85
  86   $sqltargs ||= {};
  87   my $quote_char = $self->schema->storage->sql_maker->quote_char;
  88   $sqltargs->{quote_table_names} = $quote_char ? 1 : 0;
  89   $sqltargs->{quote_field_names} = $quote_char ? 1 : 0;
  90
  91   if (
  92     ! exists $sqltargs->{producer_args}{oracle_version}
  93       and
  94     my $dver = $self->_server_info->{dbms_version}
  95   ) {
  96     $sqltargs->{producer_args}{oracle_version} = $dver;
  97   }
  98
  99   $self->next::method($schema, $type, $version, $dir, $sqltargs, @rest);
 100 }
 101
 102 sub _dbh_last_insert_id {
 103   my ($self, $dbh, $source, @columns) = @_;
 104   my @ids = ();
 105   foreach my $col (@columns) {
 106     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
 107     my $id = $self->_sequence_fetch( 'currval', $seq );
 108     push @ids, $id;
 109   }
 110   return @ids;
 111 }
 112
 113 sub _dbh_get_autoinc_seq {
 114   my ($self, $dbh, $source, $col) = @_;
 115
 116   my $sql_maker = $self->sql_maker;
 117
 118   my $source_name;
 119   if ( ref $source->name eq 'SCALAR' ) {
 120     $source_name = ${$source->name};
 121   }
 122   else {
 123     $source_name = $source->name;
 124   }
 125   $source_name = uc($source_name) unless $sql_maker->quote_char;
 126
 127   # trigger_body is a LONG
 128   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
 129
 130   # disable default bindtype
 131   local $sql_maker->{bindtype} = 'normal';
 132
 133   # look up the correct sequence automatically
 134   my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/;
 135   my ($sql, @bind) = $sql_maker->select (
 136     'ALL_TRIGGERS',
 137     ['trigger_body', 'table_owner'],
 138     {
 139       $schema ? (owner => $schema) : (),
 140       table_name => $table || $source_name,
 141       triggering_event => { -like => '%INSERT%' },
 142       status => 'ENABLED',
 143      },
 144   );
 145   my $sth = $dbh->prepare($sql);
 146   $sth->execute (@bind);
 147
 148   while (my ($insert_trigger, $schema) = $sth->fetchrow_array) {
 149     my ($seq_name) = $insert_trigger =~ m!("?[.\w"]+"?)\.nextval!i;
 150
 151     next unless $seq_name;
 152
 153     if ($seq_name !~ /\./) {
 154       $seq_name = join '.' => $schema, $seq_name;
 155     }
 156
 157     return $seq_name;
 158   }
 159   $self->throw_exception("Unable to find a sequence %INSERT% trigger on table '$source_name'.");
 160 }
 161
 162 sub _sequence_fetch {
 163   my ( $self, $type, $seq ) = @_;
 164   my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
 165   return $id;
 166 }
 167
 168 sub _ping {
 169   my $self = shift;
 170
 171   my $dbh = $self->_dbh or return 0;
 172
 173   local $dbh->{RaiseError} = 1;
 174   local $dbh->{PrintError} = 0;
 175
 176   return try {
 177     $dbh->do('select 1 from dual');
 178     1;
 179   } catch {
 180     0;
 181   };
 182 }
 183
 184 sub _dbh_execute {
 185   my $self = shift;
 186   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 187
 188   my (@res, $tried);
 189   my $wantarray = wantarray();
 190   my $next = $self->next::can;
 191   do {
 192     try {
 193       my $exec = sub { $self->$next($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) };
 194
 195       if (!defined $wantarray) {
 196         $exec->();
 197       }
 198       elsif (! $wantarray) {
 199         $res[0] = $exec->();
 200       }
 201       else {
 202         @res = $exec->();
 203       }
 204
 205       $tried++;
 206     }
 207     catch {
 208       if (! $tried and $_ =~ /ORA-01003/) {
 209         # ORA-01003: no statement parsed (someone changed the table somehow,
 210         # invalidating your cursor.)
 211         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 212         delete $dbh->{CachedKids}{$sql};
 213       }
 214       else {
 215         $self->throw_exception($_);
 216       }
 217     };
 218   } while (! $tried++);
 219
 220   return $wantarray ? @res : $res[0];
 221 }
 222
 223 =head2 get_autoinc_seq
 224
 225 Returns the sequence name for an autoincrement column
 226
 227 =cut
 228
 229 sub get_autoinc_seq {
 230   my ($self, $source, $col) = @_;
 231
 232   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 233 }
 234
 235 =head2 datetime_parser_type
 236
 237 This sets the proper DateTime::Format module for use with
 238 L<DBIx::Class::InflateColumn::DateTime>.
 239
 240 =cut
 241
 242 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 243
 244 =head2 connect_call_datetime_setup
 245
 246 Used as:
 247
 248     on_connect_call => 'datetime_setup'
 249
 250 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set the session nls
 251 date, and timestamp values for use with L<DBIx::Class::InflateColumn::DateTime>
 252 and the necessary environment variables for L<DateTime::Format::Oracle>, which
 253 is used by it.
 254
 255 Maximum allowable precision is used, unless the environment variables have
 256 already been set.
 257
 258 These are the defaults used:
 259
 260   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 261   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 262   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 263
 264 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 265 for your timestamps, use something like this:
 266
 267   use Time::HiRes 'time';
 268   my $ts = DateTime->from_epoch(epoch => time);
 269
 270 =cut
 271
 272 sub connect_call_datetime_setup {
 273   my $self = shift;
 274
 275   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 276   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 277     'YYYY-MM-DD HH24:MI:SS.FF';
 278   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 279     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 280
 281   $self->_do_query(
 282     "alter session set nls_date_format = '$date_format'"
 283   );
 284   $self->_do_query(
 285     "alter session set nls_timestamp_format = '$timestamp_format'"
 286   );
 287   $self->_do_query(
 288     "alter session set nls_timestamp_tz_format='$timestamp_tz_format'"
 289   );
 290 }
 291
 292 =head2 source_bind_attributes
 293
 294 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 295 with the driver assuming your input is the deprecated LONG type if you
 296 encode it as a hex string.  That ain't gonna fly at larger values, where
 297 you'll discover you have to do what this does.
 298
 299 This method had to be overridden because we need to set ora_field to the
 300 actual column, and that isn't passed to the call (provided by Storage) to
 301 bind_attribute_by_data_type.
 302
 303 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 304 adding it doesn't hurt, and will save your bacon if you're modifying a
 305 table with more than one LOB column.
 306
 307 =cut
 308
 309 sub source_bind_attributes
 310 {
 311   require DBD::Oracle;
 312   my $self = shift;
 313   my($source) = @_;
 314
 315   my %bind_attributes;
 316
 317   foreach my $column ($source->columns) {
 318     my $data_type = $source->column_info($column)->{data_type} || '';
 319     next unless $data_type;
 320
 321     my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 322
 323     if ($data_type =~ /^[BC]LOB$/i) {
 324       if ($DBD::Oracle::VERSION eq '1.23') {
 325         $self->throw_exception(
 326 "BLOB/CLOB support in DBD::Oracle == 1.23 is broken, use an earlier or later ".
 327 "version.\n\nSee: https://rt.cpan.org/Public/Bug/Display.html?id=46016\n"
 328         );
 329       }
 330
 331       $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB'
 332         ? DBD::Oracle::ORA_CLOB()
 333         : DBD::Oracle::ORA_BLOB()
 334       ;
 335       $column_bind_attrs{'ora_field'} = $column;
 336     }
 337
 338     $bind_attributes{$column} = \%column_bind_attrs;
 339   }
 340
 341   return \%bind_attributes;
 342 }
 343
 344 sub _svp_begin {
 345   my ($self, $name) = @_;
 346   $self->_get_dbh->do("SAVEPOINT $name");
 347 }
 348
 349 # Oracle automatically releases a savepoint when you start another one with the
 350 # same name.
 351 sub _svp_release { 1 }
 352
 353 sub _svp_rollback {
 354   my ($self, $name) = @_;
 355   $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 356 }
 357
 358 =head2 relname_to_table_alias
 359
 360 L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
 361 queries.
 362
 363 Unfortunately, Oracle doesn't support identifiers over 30 chars in length, so
 364 the L<DBIx::Class::Relationship> name is shortened and appended with half of an
 365 MD5 hash.
 366
 367 See L<DBIx::Class::Storage/"relname_to_table_alias">.
 368
 369 =cut
 370
 371 sub relname_to_table_alias {
 372   my $self = shift;
 373   my ($relname, $join_count) = @_;
 374
 375   my $alias = $self->next::method(@_);
 376
 377   return $self->sql_maker->_shorten_identifier($alias, [$relname]);
 378 }
 379
 380 =head2 with_deferred_fk_checks
 381
 382 Runs a coderef between:
 383
 384   alter session set constraints = deferred
 385   ...
 386   alter session set constraints = immediate
 387
 388 to defer foreign key checks.
 389
 390 Constraints must be declared C<DEFERRABLE> for this to work.
 391
 392 =cut
 393
 394 sub with_deferred_fk_checks {
 395   my ($self, $sub) = @_;
 396
 397   my $txn_scope_guard = $self->txn_scope_guard;
 398
 399   $self->_do_query('alter session set constraints = deferred');
 400
 401   my $sg = Scope::Guard->new(sub {
 402     $self->_do_query('alter session set constraints = immediate');
 403   });
 404
 405   return
 406     preserve_context { $sub->() } after => sub { $txn_scope_guard->commit };
 407 }
 408
 409 =head1 ATTRIBUTES
 410
 411 Following additional attributes can be used in resultsets.
 412
 413 =head2 connect_by or connect_by_nocycle
 414
 415 =over 4
 416
 417 =item Value: \%connect_by
 418
 419 =back
 420
 421 A hashref of conditions used to specify the relationship between parent rows
 422 and child rows of the hierarchy.
 423
 424
 425   connect_by => { parentid => 'prior personid' }
 426
 427   # adds a connect by statement to the query:
 428   # SELECT
 429   #     me.persionid me.firstname, me.lastname, me.parentid
 430   # FROM
 431   #     person me
 432   # CONNECT BY
 433   #     parentid = prior persionid
 434
 435
 436   connect_by_nocycle => { parentid => 'prior personid' }
 437
 438   # adds a connect by statement to the query:
 439   # SELECT
 440   #     me.persionid me.firstname, me.lastname, me.parentid
 441   # FROM
 442   #     person me
 443   # CONNECT BY NOCYCLE
 444   #     parentid = prior persionid
 445
 446
 447 =head2 start_with
 448
 449 =over 4
 450
 451 =item Value: \%condition
 452
 453 =back
 454
 455 A hashref of conditions which specify the root row(s) of the hierarchy.
 456
 457 It uses the same syntax as L<DBIx::Class::ResultSet/search>
 458
 459   start_with => { firstname => 'Foo', lastname => 'Bar' }
 460
 461   # SELECT
 462   #     me.persionid me.firstname, me.lastname, me.parentid
 463   # FROM
 464   #     person me
 465   # START WITH
 466   #     firstname = 'foo' and lastname = 'bar'
 467   # CONNECT BY
 468   #     parentid = prior persionid
 469
 470 =head2 order_siblings_by
 471
 472 =over 4
 473
 474 =item Value: ($order_siblings_by | \@order_siblings_by)
 475
 476 =back
 477
 478 Which column(s) to order the siblings by.
 479
 480 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
 481
 482   'order_siblings_by' => 'firstname ASC'
 483
 484   # SELECT
 485   #     me.persionid me.firstname, me.lastname, me.parentid
 486   # FROM
 487   #     person me
 488   # CONNECT BY
 489   #     parentid = prior persionid
 490   # ORDER SIBLINGS BY
 491   #     firstname ASC
 492
 493 =head1 AUTHOR
 494
 495 See L<DBIx::Class/CONTRIBUTORS>.
 496
 497 =head1 LICENSE
 498
 499 You may distribute this code under the same terms as Perl itself.
 500
 501 =cut
 502
 503 1;