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