lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm

   1 package DBIx::Class::Storage::DBI::Oracle::Generic;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 DBIx::Class::Storage::DBI::Oracle::Generic - Oracle Support for DBIx::Class
   9
  10 =head1 SYNOPSIS
  11
  12   # In your table classes
  13   __PACKAGE__->load_components(qw/PK::Auto Core/);
  14   __PACKAGE__->add_columns({ id => { sequence => 'mysequence', auto_nextval => 1 } });
  15   __PACKAGE__->set_primary_key('id');
  16   __PACKAGE__->sequence('mysequence');
  17
  18   # Somewhere in your Code
  19   # add some data to a table with a hierarchical relationship
  20   $schema->resultset('Person')->create ({
  21         firstname => 'foo',
  22         lastname => 'bar',
  23         children => [
  24             {
  25                 firstname => 'child1',
  26                 lastname => 'bar',
  27                 children => [
  28                     {
  29                         firstname => 'grandchild',
  30                         lastname => 'bar',
  31                     }
  32                 ],
  33             },
  34             {
  35                 firstname => 'child2',
  36                 lastname => 'bar',
  37             },
  38         ],
  39     });
  40
  41   # select from the hierarchical relationship
  42   my $rs = $schema->resultset('Person')->search({},
  43     {
  44       'start_with' => { 'firstname' => 'foo', 'lastname' => 'bar' },
  45       'connect_by' => { 'parentid' => 'prior persionid'},
  46       'order_siblings_by' => 'firstname ASC',
  47     };
  48   );
  49
  50   # this will select the whole tree starting from person "foo bar", creating
  51   # following query:
  52   # SELECT
  53   #     me.persionid me.firstname, me.lastname, me.parentid
  54   # FROM
  55   #     person me
  56   # START WITH
  57   #     firstname = 'foo' and lastname = 'bar'
  58   # CONNECT BY
  59   #     parentid = prior persionid
  60   # ORDER SIBLINGS BY
  61   #     firstname ASC
  62
  63 =head1 DESCRIPTION
  64
  65 This class implements autoincrements for Oracle and adds support for Oracle
  66 specific hierarchical queries.
  67
  68 =head1 METHODS
  69
  70 =cut
  71
  72 use base qw/DBIx::Class::Storage::DBI/;
  73 use mro 'c3';
  74
  75 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::Oracle');
  76
  77 sub _dbh_last_insert_id {
  78   my ($self, $dbh, $source, @columns) = @_;
  79   my @ids = ();
  80   foreach my $col (@columns) {
  81     my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
  82     my $id = $self->_sequence_fetch( 'currval', $seq );
  83     push @ids, $id;
  84   }
  85   return @ids;
  86 }
  87
  88 sub _dbh_get_autoinc_seq {
  89   my ($self, $dbh, $source, $col) = @_;
  90
  91   # look up the correct sequence automatically
  92   my $sql = q{
  93     SELECT trigger_body FROM ALL_TRIGGERS t
  94     WHERE t.table_name = ?
  95     AND t.triggering_event = 'INSERT'
  96     AND t.status = 'ENABLED'
  97   };
  98
  99   # trigger_body is a LONG
 100   local $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024);
 101
 102   my $sth;
 103
 104   my $source_name;
 105   if ( ref $source->name ne 'SCALAR' ) {
 106       $source_name = $source->name;
 107   }
 108   else {
 109       $source_name = ${$source->name};
 110   }
 111
 112   # check for fully-qualified name (eg. SCHEMA.TABLENAME)
 113   if ( my ( $schema, $table ) = $source_name =~ /(\w+)\.(\w+)/ ) {
 114     $sql = q{
 115       SELECT trigger_body FROM ALL_TRIGGERS t
 116       WHERE t.owner = ? AND t.table_name = ?
 117       AND t.triggering_event = 'INSERT'
 118       AND t.status = 'ENABLED'
 119     };
 120     $sth = $dbh->prepare($sql);
 121     $sth->execute( uc($schema), uc($table) );
 122   }
 123   else {
 124     $sth = $dbh->prepare($sql);
 125     $sth->execute( uc( $source_name ) );
 126   }
 127   while (my ($insert_trigger) = $sth->fetchrow_array) {
 128     return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here???
 129   }
 130   $self->throw_exception("Unable to find a sequence INSERT trigger on table '" . $source->name . "'.");
 131 }
 132
 133 sub _sequence_fetch {
 134   my ( $self, $type, $seq ) = @_;
 135   my ($id) = $self->_get_dbh->selectrow_array("SELECT ${seq}.${type} FROM DUAL");
 136   return $id;
 137 }
 138
 139 sub _ping {
 140   my $self = shift;
 141
 142   my $dbh = $self->_dbh or return 0;
 143
 144   local $dbh->{RaiseError} = 1;
 145
 146   eval {
 147     $dbh->do("select 1 from dual");
 148   };
 149
 150   return $@ ? 0 : 1;
 151 }
 152
 153 sub _dbh_execute {
 154   my $self = shift;
 155   my ($dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
 156
 157   my $wantarray = wantarray;
 158
 159   my (@res, $exception, $retried);
 160
 161   RETRY: {
 162     do {
 163       eval {
 164         if ($wantarray) {
 165           @res    = $self->next::method(@_);
 166         } else {
 167           $res[0] = $self->next::method(@_);
 168         }
 169       };
 170       $exception = $@;
 171       if ($exception =~ /ORA-01003/) {
 172         # ORA-01003: no statement parsed (someone changed the table somehow,
 173         # invalidating your cursor.)
 174         my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
 175         delete $dbh->{CachedKids}{$sql};
 176       } else {
 177         last RETRY;
 178       }
 179     } while (not $retried++);
 180   }
 181
 182   $self->throw_exception($exception) if $exception;
 183
 184   wantarray ? @res : $res[0]
 185 }
 186
 187 =head2 get_autoinc_seq
 188
 189 Returns the sequence name for an autoincrement column
 190
 191 =cut
 192
 193 sub get_autoinc_seq {
 194   my ($self, $source, $col) = @_;
 195
 196   $self->dbh_do('_dbh_get_autoinc_seq', $source, $col);
 197 }
 198
 199 =head2 columns_info_for
 200
 201 This wraps the superclass version of this method to force table
 202 names to uppercase
 203
 204 =cut
 205
 206 sub columns_info_for {
 207   my ($self, $table) = @_;
 208
 209   $self->next::method(uc($table));
 210 }
 211
 212 =head2 datetime_parser_type
 213
 214 This sets the proper DateTime::Format module for use with
 215 L<DBIx::Class::InflateColumn::DateTime>.
 216
 217 =cut
 218
 219 sub datetime_parser_type { return "DateTime::Format::Oracle"; }
 220
 221 =head2 connect_call_datetime_setup
 222
 223 Used as:
 224
 225     on_connect_call => 'datetime_setup'
 226
 227 In L<DBIx::Class::Storage::DBI/connect_info> to set the session nls date, and
 228 timestamp values for use with L<DBIx::Class::InflateColumn::DateTime> and the
 229 necessary environment variables for L<DateTime::Format::Oracle>, which is used
 230 by it.
 231
 232 Maximum allowable precision is used, unless the environment variables have
 233 already been set.
 234
 235 These are the defaults used:
 236
 237   $ENV{NLS_DATE_FORMAT}         ||= 'YYYY-MM-DD HH24:MI:SS';
 238   $ENV{NLS_TIMESTAMP_FORMAT}    ||= 'YYYY-MM-DD HH24:MI:SS.FF';
 239   $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 240
 241 To get more than second precision with L<DBIx::Class::InflateColumn::DateTime>
 242 for your timestamps, use something like this:
 243
 244   use Time::HiRes 'time';
 245   my $ts = DateTime->from_epoch(epoch => time);
 246
 247 =cut
 248
 249 sub connect_call_datetime_setup {
 250   my $self = shift;
 251
 252   my $date_format = $ENV{NLS_DATE_FORMAT} ||= 'YYYY-MM-DD HH24:MI:SS';
 253   my $timestamp_format = $ENV{NLS_TIMESTAMP_FORMAT} ||=
 254     'YYYY-MM-DD HH24:MI:SS.FF';
 255   my $timestamp_tz_format = $ENV{NLS_TIMESTAMP_TZ_FORMAT} ||=
 256     'YYYY-MM-DD HH24:MI:SS.FF TZHTZM';
 257
 258   $self->_do_query("alter session set nls_date_format = '$date_format'");
 259   $self->_do_query(
 260 "alter session set nls_timestamp_format = '$timestamp_format'");
 261   $self->_do_query(
 262 "alter session set nls_timestamp_tz_format='$timestamp_tz_format'");
 263 }
 264
 265 =head2 source_bind_attributes
 266
 267 Handle LOB types in Oracle.  Under a certain size (4k?), you can get away
 268 with the driver assuming your input is the deprecated LONG type if you
 269 encode it as a hex string.  That ain't gonna fly at larger values, where
 270 you'll discover you have to do what this does.
 271
 272 This method had to be overridden because we need to set ora_field to the
 273 actual column, and that isn't passed to the call (provided by Storage) to
 274 bind_attribute_by_data_type.
 275
 276 According to L<DBD::Oracle>, the ora_field isn't always necessary, but
 277 adding it doesn't hurt, and will save your bacon if you're modifying a
 278 table with more than one LOB column.
 279
 280 =cut
 281
 282 sub source_bind_attributes
 283 {
 284         require DBD::Oracle;
 285         my $self = shift;
 286         my($source) = @_;
 287
 288         my %bind_attributes;
 289
 290         foreach my $column ($source->columns) {
 291                 my $data_type = $source->column_info($column)->{data_type} || '';
 292                 next unless $data_type;
 293
 294                 my %column_bind_attrs = $self->bind_attribute_by_data_type($data_type);
 295
 296                 if ($data_type =~ /^[BC]LOB$/i) {
 297                         $column_bind_attrs{'ora_type'} = uc($data_type) eq 'CLOB' ?
 298                                 DBD::Oracle::ORA_CLOB() :
 299                                 DBD::Oracle::ORA_BLOB();
 300                         $column_bind_attrs{'ora_field'} = $column;
 301                 }
 302
 303                 $bind_attributes{$column} = \%column_bind_attrs;
 304         }
 305
 306         return \%bind_attributes;
 307 }
 308
 309 sub _svp_begin {
 310     my ($self, $name) = @_;
 311
 312     $self->_get_dbh->do("SAVEPOINT $name");
 313 }
 314
 315 # Oracle automatically releases a savepoint when you start another one with the
 316 # same name.
 317 sub _svp_release { 1 }
 318
 319 sub _svp_rollback {
 320     my ($self, $name) = @_;
 321
 322     $self->_get_dbh->do("ROLLBACK TO SAVEPOINT $name")
 323 }
 324
 325 sub _select_args {
 326     my ($self, $ident, $select, $where, $attrs) = @_;
 327
 328     my $connect_by_args = {};
 329     if ( $attrs->{connect_by} || $attrs->{start_with} || $attrs->{order_siblings_by} ) {
 330         $connect_by_args = {
 331             connect_by => $attrs->{connect_by},
 332             start_with => $attrs->{start_with},
 333             order_siblings_by => $attrs->{order_siblings_by},
 334         }
 335     }
 336
 337     my @rv = $self->next::method($ident, $select, $where, $attrs);
 338
 339     return (@rv, $connect_by_args);
 340 }
 341
 342 =head1 ATTRIBUTES
 343
 344 Following additional attributes can be used in resultsets.
 345
 346 =head2 connect_by
 347
 348 =over 4
 349
 350 =item Value: \%connect_by
 351
 352 =back
 353
 354 A hashref of conditions used to specify the relationship between parent rows
 355 and child rows of the hierarchy.
 356
 357   connect_by => { parentid => 'prior personid' }
 358
 359   # adds a connect by statement to the query:
 360   # SELECT
 361   #     me.persionid me.firstname, me.lastname, me.parentid
 362   # FROM
 363   #     person me
 364   # CONNECT BY
 365   #     parentid = prior persionid
 366
 367 =head2 start_with
 368
 369 =over 4
 370
 371 =item Value: \%condition
 372
 373 =back
 374
 375 A hashref of conditions which specify the root row(s) of the hierarchy.
 376
 377 It uses the same syntax as L<DBIx::Class::ResultSet/search>
 378
 379   start_with => { firstname => 'Foo', lastname => 'Bar' }
 380
 381   # SELECT
 382   #     me.persionid me.firstname, me.lastname, me.parentid
 383   # FROM
 384   #     person me
 385   # START WITH
 386   #     firstname = 'foo' and lastname = 'bar'
 387   # CONNECT BY
 388   #     parentid = prior persionid
 389
 390 =head2 order_siblings_by
 391
 392 =over 4
 393
 394 =item Value: ($order_siblings_by | \@order_siblings_by)
 395
 396 =back
 397
 398 Which column(s) to order the siblings by.
 399
 400 It uses the same syntax as L<DBIx::Class::ResultSet/order_by>
 401
 402   'order_siblings_by' => 'firstname ASC'
 403
 404   # SELECT
 405   #     me.persionid me.firstname, me.lastname, me.parentid
 406   # FROM
 407   #     person me
 408   # CONNECT BY
 409   #     parentid = prior persionid
 410   # ORDER SIBLINGS BY
 411   #     firstname ASC
 412
 413 =head1 AUTHOR
 414
 415 See L<DBIx::Class/CONTRIBUTORS>.
 416
 417 =head1 LICENSE
 418
 419 You may distribute this code under the same terms as Perl itself.
 420
 421 =cut
 422
 423 1;