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