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 =head1 ATTRIBUTES
 421
 422 Following additional attributes can be used in resultsets.
 423
 424 =head2 connect_by
 425
 426 =over 4
 427
 428 =item Value: \%connect_by
 429
 430 =back
 431
 432 A hashref of conditions used to specify the relationship between parent rows
 433 and child rows of the hierarchy.
 434
 435   connect_by => { parentid => 'prior personid' }
 436
 437   # adds a connect by statement to the query:
 438   # SELECT
 439   #     me.persionid me.firstname, me.lastname, me.parentid
 440   # FROM
 441   #     person me
 442   # CONNECT BY
 443   #     parentid = prior persionid
 444
 445 =head2 nocycle
 446
 447 =over 4
 448
 449 =item Value: [1|0]
 450
 451 =back
 452
 453 If you want to use NOCYCLE set to 1.
 454
 455     connect_by => { parentid => 'prior personid' },
 456     nocycle    => 1
 457
 458     # adds a connect by statement to the query:
 459     # SELECT
 460     #     me.persionid me.firstname, me.lastname, me.parentid
 461     # FROM
 462     #     person me
 463     # CONNECT BY NOCYCLE
 464     #     parentid = prior persionid
 465
 466
 467 =head2 start_with
 468
 469 =over 4
 470
 471 =item Value: \%condition
 472
 473 =back
 474
 475 A hashref of conditions which specify the root row(s) of the hierarchy.
 476
 477 It uses the same syntax as L<DBIx::Class::ResultSet/search>
 478
 479   start_with => { firstname => 'Foo', lastname => 'Bar' }
 480
 481   # SELECT
 482   #     me.persionid me.firstname, me.lastname, me.parentid
 483   # FROM
 484   #     person me
 485   # START WITH
 486   #     firstname = 'foo' and lastname = 'bar'
 487   # CONNECT BY
 488   #     parentid = prior persionid
 489
 490 =head2 order_siblings_by
 491
 492 =over 4
 493
 494 =item Value: ($order_siblings_by | \@order_siblings_by)
 495
 496 =back
 497
 498 Which column(s) to order the siblings by.
 499
 500 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
 501
 502   'order_siblings_by' => 'firstname ASC'
 503
 504   # SELECT
 505   #     me.persionid me.firstname, me.lastname, me.parentid
 506   # FROM
 507   #     person me
 508   # CONNECT BY
 509   #     parentid = prior persionid
 510   # ORDER SIBLINGS BY
 511   #     firstname ASC
 512
 513 =head1 AUTHOR
 514
 515 See L<DBIx::Class/CONTRIBUTORS>.
 516
 517 =head1 LICENSE
 518
 519 You may distribute this code under the same terms as Perl itself.
 520
 521 =cut
 522
 523 1;