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