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