1package Rose::DB::Oracle; 2 3use strict; 4 5use Carp(); 6use SQL::ReservedWords::Oracle(); 7 8use Rose::DB; 9 10our $Debug = 0; 11 12our $VERSION = '0.767'; 13 14use Rose::Class::MakeMethods::Generic 15( 16 inheritable_scalar => '_default_post_connect_sql', 17); 18 19__PACKAGE__->_default_post_connect_sql 20( 21 [ 22 q(ALTER SESSION SET NLS_DATE_FORMAT = ') . 23 ($ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS') . q('), 24 q(ALTER SESSION SET NLS_TIMESTAMP_FORMAT = ') . 25 ($ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF') . q('), 26 q(ALTER SESSION SET NLS_TIMESTAMP_TZ_FORMAT = ') . 27 ($ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM') . q('), 28 ] 29); 30 31sub default_post_connect_sql 32{ 33 my($class) = shift; 34 35 if(@_) 36 { 37 if(@_ == 1 && ref $_[0] eq 'ARRAY') 38 { 39 $class->_default_post_connect_sql(@_); 40 } 41 else 42 { 43 $class->_default_post_connect_sql([ @_ ]); 44 } 45 } 46 47 return $class->_default_post_connect_sql; 48} 49 50sub post_connect_sql 51{ 52 my($self) = shift; 53 54 unless(@_) 55 { 56 return wantarray ? 57 ( @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ) : 58 [ @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ]; 59 } 60 61 if(@_ == 1 && ref $_[0] eq 'ARRAY') 62 { 63 $self->{'post_connect_sql'} = $_[0]; 64 } 65 else 66 { 67 $self->{'post_connect_sql'} = [ @_ ]; 68 } 69 70 return wantarray ? 71 ( @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ) : 72 [ @{ $self->default_post_connect_sql || [] }, @{$self->{'post_connect_sql'} || [] } ]; 73} 74 75sub schema 76{ 77 my($self) = shift; 78 $self->{'schema'} = shift if(@_); 79 return $self->{'schema'} || $self->username; 80} 81 82sub use_auto_sequence_name { 1 } 83 84sub auto_sequence_name 85{ 86 my($self, %args) = @_; 87 88 my($table) = $args{'table'}; 89 Carp::croak 'Missing table argument' unless(defined $table); 90 91 my($column) = $args{'column'}; 92 Carp::croak 'Missing column argument' unless(defined $column); 93 94 return uc "${table}_${column}_SEQ"; 95} 96 97sub build_dsn 98{ 99 my($self_or_class, %args) = @_; 100 101 my $database = $args{'db'} || $args{'database'}; 102 103 if($args{'host'} || $args{'port'}) 104 { 105 $args{'sid'} = $database; 106 107 return 'dbi:Oracle:' . 108 join(';', map { "$_=$args{$_}" } grep { $args{$_} } qw(sid host port)); 109 } 110 111 return "dbi:Oracle:$database"; 112} 113 114sub init_date_handler { Rose::DB::Oracle::DateHandler->new } 115 116sub database_version 117{ 118 my($self) = shift; 119 120 return $self->{'database_version'} if (defined $self->{'database_version'}); 121 122 my($version) = $self->dbh->get_info(18); # SQL_DBMS_VER. 123 124 # Convert to an integer, e.g., 10.02.0100 -> 100020100 125 126 if($version =~ /^(\d+)\.(\d+)(?:\.(\d+))?/) 127 { 128 $version = sprintf('%d%03d%04d', $1, $2, $3); 129 } 130 131 return $self->{'database_version'} = $version; 132} 133 134sub dbi_driver { 'Oracle' } 135 136sub likes_uppercase_table_names { 1 } 137sub likes_uppercase_schema_names { 1 } 138sub likes_uppercase_catalog_names { 1 } 139sub likes_uppercase_sequence_names { 1 } 140 141sub insertid_param { '' } 142 143sub list_tables 144{ 145 my($self, %args) = @_; 146 147 my $types = $args{'include_views'} ? "'TABLE','VIEW'" : 'TABLE'; 148 149 my($error, @tables); 150 151 TRY: 152 { 153 local $@; 154 155 eval 156 { 157 my($dbh) = $self->dbh or die $self->error; 158 159 local $dbh->{'RaiseError'} = 1; 160 local $dbh->{'FetchHashKeyName'} = 'NAME'; 161 162 my $sth = $dbh->table_info($self->catalog, uc $self->schema, '%', $types); 163 my $info = $sth->fetchall_arrayref({}); # The {} are mandatory. 164 165 for my $table (@$info) 166 { 167 push @tables, $$table{'TABLE_NAME'} if ($$table{'TABLE_NAME'} !~ /^BIN\$.+\$.+/); 168 } 169 }; 170 171 $error = $@; 172 } 173 174 if($error) 175 { 176 Carp::croak 'Could not list tables from ', $self->dsn, " - $error"; 177 } 178 179 return wantarray ? @tables : \@tables; 180} 181 182sub next_value_in_sequence 183{ 184 my($self, $sequence_name) = @_; 185 186 my $dbh = $self->dbh or return undef; 187 188 my($error, $value); 189 190 TRY: 191 { 192 local $@; 193 194 eval 195 { 196 local $dbh->{'PrintError'} = 0; 197 local $dbh->{'RaiseError'} = 1; 198 my $sth = $dbh->prepare("SELECT $sequence_name.NEXTVAL FROM DUAL"); 199 $sth->execute; 200 $value = ${$sth->fetch}[0]; 201 $sth->finish; 202 }; 203 204 $error = $@; 205 } 206 207 if($error) 208 { 209 $self->error("Could not get the next value in the sequence $sequence_name - $error"); 210 return undef; 211 } 212 213 return $value; 214} 215 216# Tried to execute a CURRVAL command on a sequence before the 217# NEXTVAL command was executed at least once. 218use constant ORA_08002 => 8002; 219 220sub current_value_in_sequence 221{ 222 my($self, $sequence_name) = @_; 223 224 my $dbh = $self->dbh or return undef; 225 226 my($error, $value); 227 228 TRY: 229 { 230 local $@; 231 232 eval 233 { 234 local $dbh->{'PrintError'} = 0; 235 local $dbh->{'RaiseError'} = 1; 236 my $sth = $dbh->prepare("SELECT $sequence_name.CURRVAL FROM DUAL"); 237 238 $sth->execute; 239 240 $value = ${$sth->fetch}[0]; 241 242 $sth->finish; 243 }; 244 245 $error = $@; 246 } 247 248 if($error) 249 { 250 if(DBI->err == ORA_08002) 251 { 252 if(defined $self->next_value_in_sequence($sequence_name)) 253 { 254 return $self->current_value_in_sequence($sequence_name); 255 } 256 } 257 258 $self->error("Could not get the current value in the sequence $sequence_name - $error"); 259 return undef; 260 } 261 262 return $value; 263} 264 265# Sequence does not exist, or the user does not have the required 266# privilege to perform this operation. 267use constant ORA_02289 => 2289; 268 269sub sequence_exists 270{ 271 my($self, $sequence_name) = @_; 272 273 my $dbh = $self->dbh or return undef; 274 275 my $error; 276 277 TRY: 278 { 279 local $@; 280 281 eval 282 { 283 local $dbh->{'PrintError'} = 0; 284 local $dbh->{'RaiseError'} = 1; 285 my $sth = $dbh->prepare("SELECT $sequence_name.CURRVAL FROM DUAL"); 286 $sth->execute; 287 $sth->fetch; 288 $sth->finish; 289 }; 290 291 $error = $@; 292 } 293 294 if($error) 295 { 296 my $dbi_error = DBI->err; 297 298 if($dbi_error == ORA_08002) 299 { 300 if(defined $self->next_value_in_sequence($sequence_name)) 301 { 302 return $self->sequence_exists($sequence_name); 303 } 304 } 305 elsif($dbi_error == ORA_02289) 306 { 307 return 0; 308 } 309 310 $self->error("Could not check if sequence $sequence_name exists - $error"); 311 return undef; 312 } 313 314 return 1; 315} 316 317sub parse_dbi_column_info_default 318{ 319 my($self, $default, $col_info) = @_; 320 321 # For some reason, given a default value like this: 322 # 323 # MYCOLUMN VARCHAR(128) DEFAULT 'foo' NOT NULL 324 # 325 # DBD::Oracle hands back a COLUMN_DEF value of: 326 # 327 # $col_info->{'COLUMN_DEF'} = "'foo' "; # WTF? 328 # 329 # I have no idea why. Anyway, we just want the value beteen the quotes. 330 331 return undef unless (defined $default); 332 333 $default =~ s/^\s*'(.+)'\s*$/$1/; 334 335 return $default; 336} 337 338*is_reserved_word = \&SQL::ReservedWords::Oracle::is_reserved; 339 340sub quote_identifier_for_sequence 341{ 342 my($self, $catalog, $schema, $table) = @_; 343 return join('.', map { uc } grep { defined } ($schema, $table)); 344} 345 346# sub auto_quote_column_name 347# { 348# my($self, $name) = @_; 349# 350# if($name =~ /[^\w#]/ || $self->is_reserved_word($name)) 351# { 352# return $self->quote_column_name($name, @_); 353# } 354# 355# return $name; 356# } 357 358sub supports_schema { 1 } 359 360sub max_column_name_length { 30 } 361sub max_column_alias_length { 30 } 362 363sub quote_column_name 364{ 365 my $name = uc $_[1]; 366 $name =~ s/"/""/g; 367 return qq("$name"); 368} 369 370sub quote_table_name 371{ 372 my $name = uc $_[1]; 373 $name =~ s/"/""/g; 374 return qq("$name"); 375} 376 377sub quote_identifier { 378 my($self) = shift; 379 my $method = ref($self)->parent_class . '::quote_identifier'; 380 no strict 'refs'; 381 return uc $self->$method(@_); 382} 383 384sub primary_key_column_names 385{ 386 my($self) = shift; 387 388 my %args = @_ == 1 ? (table => @_) : @_; 389 390 my $table = $args{'table'} or Carp::croak "Missing table name parameter"; 391 my $schema = $args{'schema'} || $self->schema; 392 my $catalog = $args{'catalog'} || $self->catalog; 393 394 no warnings 'uninitialized'; 395 $table = uc $table; 396 $schema = uc $schema; 397 $catalog = uc $catalog; 398 399 my $table_unquoted = $self->unquote_table_name($table); 400 401 my($error, $columns); 402 403 TRY: 404 { 405 local $@; 406 407 eval 408 { 409 $columns = 410 $self->_get_primary_key_column_names($catalog, $schema, $table_unquoted); 411 }; 412 413 $error = $@; 414 } 415 416 if($error || !$columns) 417 { 418 no warnings 'uninitialized'; # undef strings okay 419 $error = 'no primary key columns found' unless(defined $error); 420 Carp::croak "Could not get primary key columns for catalog '" . 421 $catalog . "' schema '" . $schema . "' table '" . 422 $table_unquoted . "' - " . $error; 423 } 424 425 return wantarray ? @$columns : $columns; 426} 427 428sub format_limit_with_offset 429{ 430 my($self, $limit, $offset, $args) = @_; 431 432 delete $args->{'limit'}; 433 delete $args->{'offset'}; 434 435 if($offset) 436 { 437 # http://www.oracle.com/technology/oramag/oracle/06-sep/o56asktom.html 438 # select * 439 # from ( select /*+ FIRST_ROWS(n) */ 440 # a.*, ROWNUM rnum 441 # from ( your_query_goes_here, 442 # with order by ) a 443 # where ROWNUM <= 444 # :MAX_ROW_TO_FETCH ) 445 # where rnum >= :MIN_ROW_TO_FETCH; 446 447 my $size = $limit; 448 my $start = $offset + 1; 449 my $end = $start + $size - 1; 450 my $n = $offset + $limit; 451 452 $args->{'limit_prefix'} = 453 "SELECT * FROM (SELECT /*+ FIRST_ROWS($n) */\na.*, ROWNUM oracle_rownum FROM ("; 454 #"SELECT * FROM (SELECT a.*, ROWNUM oracle_rownum FROM ("; 455 456 $args->{'limit_suffix'} = 457 ") a WHERE ROWNUM <= $end) WHERE oracle_rownum >= $start"; 458 } 459 else 460 { 461 $args->{'limit_prefix'} = "SELECT /*+ FIRST_ROWS($limit) */ a.* FROM ("; 462 #$args->{'limit_prefix'} = "SELECT a.* FROM ("; 463 $args->{'limit_suffix'} = ") a WHERE ROWNUM <= $limit"; 464 } 465} 466 467sub format_select_lock 468{ 469 my($self, $class, $lock, $tables) = @_; 470 471 $lock = { type => $lock } unless(ref $lock); 472 473 $lock->{'type'} ||= 'for update' if($lock->{'for_update'}); 474 475 unless($lock->{'type'} eq 'for update') 476 { 477 Carp::croak "Invalid lock type: $lock->{'type'}"; 478 } 479 480 my $sql = 'FOR UPDATE'; 481 482 my @columns; 483 484 if(my $on = $lock->{'on'}) 485 { 486 @columns = map { $self->column_sql_from_lock_on_value($class, $_, $tables) } @$on; 487 } 488 elsif(my $columns = $lock->{'columns'}) 489 { 490 my %map; 491 492 if($tables) 493 { 494 my $tn = 1; 495 496 foreach my $table (@$tables) 497 { 498 (my $table_key = $table) =~ s/^(["']?)[^.]+\1\.//; 499 $map{$table_key} = 't' . $tn++; 500 } 501 } 502 503 @columns = map 504 { 505 ref $_ eq 'SCALAR' ? $$_ : 506 /^([^.]+)\.([^.]+)$/ ? 507 $self->auto_quote_column_with_table($2, defined $map{$1} ? $map{$1} : $1) : 508 $self->auto_quote_column_name($_) 509 } 510 @$columns; 511 } 512 513 if(@columns) 514 { 515 $sql .= ' OF ' . join(', ', @columns); 516 } 517 518 if($lock->{'nowait'}) 519 { 520 $sql .= ' NOWAIT'; 521 } 522 elsif(my $wait = $lock->{'wait'}) 523 { 524 $sql .= " WAIT $wait"; 525 } 526 527 if($lock->{'skip_locked'}) 528 { 529 $sql .= ' SKIP LOCKED'; 530 } 531 532 return $sql; 533} 534 535sub format_boolean { $_[1] ? 't' : 'f' } 536 537# 538# Date/time keywords and inlining 539# 540 541sub validate_date_keyword 542{ 543 no warnings; 544 $_[1] =~ /^(?:CURRENT_|SYS|LOCAL)(?:TIMESTAMP|DATE)$/i || 545 ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/); 546} 547 548*validate_time_keyword = \&validate_date_keyword; 549*validate_timestamp_keyword = \&validate_date_keyword; 550*validate_datetime_keyword = \&validate_date_keyword; 551 552sub should_inline_date_keyword { 1 } 553sub should_inline_datetime_keyword { 1 } 554sub should_inline_time_keyword { 1 } 555sub should_inline_timestamp_keyword { 1 } 556 557package Rose::DB::Oracle::DateHandler; 558 559use Rose::Object; 560our @ISA = qw(Rose::Object); 561 562use DateTime::Format::Oracle; 563 564sub parse_date 565{ 566 my($self, $value) = @_; 567 568 local $DateTime::Format::Oracle::nls_date_format = $ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS'; 569 570 # Add or extend the time to appease DateTime::Format::Oracle 571 if($value =~ /\d\d:/) 572 { 573 $value =~ s/( \d\d:\d\d)([^:]|$)/$1:00$2/; 574 } 575 else 576 { 577 $value .= ' 00:00:00'; 578 } 579 580 return DateTime::Format::Oracle->parse_date($value); 581} 582 583*parse_datetime = \&parse_date; 584 585sub parse_timestamp 586{ 587 my($self, $value) = @_; 588 589 local $DateTime::Format::Oracle::nls_timestamp_format = 590 $ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF'; 591 592 # Add, extend, or truncate fractional seconds to appease DateTime::Format::Oracle 593 for($value) 594 { 595 s/( \d\d:\d\d:\d\d)(?!\.)/$1.000000/ || 596 s/( \d\d:\d\d:\d\d\.)(\d{1,5})(\D|$)/ "$1$2" . ('0' x (6 - length($2))) . $3/e || 597 s/( \d\d:\d\d:\d\d\.\d{6})\d+/$1/; 598 } 599 600 return DateTime::Format::Oracle->parse_timestamp($value); 601} 602 603sub parse_timestamp_with_time_zone 604{ 605 my($self, $value) = @_; 606 607 local $DateTime::Format::Oracle::nls_timestamp_tz_format = 608 $ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'; 609 610 # Add, extend, or truncate fractional seconds to appease DateTime::Format::Oracle 611 for($value) 612 { 613 s/( \d\d:\d\d:\d\d)(?!\.)/$1.000000/ || 614 s/( \d\d:\d\d:\d\d\.)(\d{1,5})(\D|$)/ "$1$2" . ('0' x (6 - length($2))) . $3/e || 615 s/( \d\d:\d\d:\d\d\.\d{6})\d+/$1/; 616 } 617 618 return DateTime::Format::Oracle->parse_timestamp_with_time_zone($value); 619} 620 621sub format_date 622{ 623 my($self) = shift; 624 625 local $DateTime::Format::Oracle::nls_date_format = 626 $ENV{'NLS_DATE_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS'; 627 628 return DateTime::Format::Oracle->format_date(@_); 629} 630 631*format_datetime = \&format_date; 632 633sub format_timestamp 634{ 635 my($self) = shift; 636 637 local $DateTime::Format::Oracle::nls_timestamp_format = 638 $ENV{'NLS_TIMESTAMP_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF'; 639 640 return DateTime::Format::Oracle->format_timestamp(@_); 641} 642 643sub format_timestamp_with_time_zone 644{ 645 my($self) = shift; 646 647 local $DateTime::Format::Oracle::nls_timestamp_tz_format = 648 $ENV{'NLS_TIMESTAMP_TZ_FORMAT'} || 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM'; 649 650 return DateTime::Format::Oracle->format_timestamp_with_time_zone(@_); 651} 652 6531; 654 655__END__ 656 657=head1 NAME 658 659Rose::DB::Oracle - Oracle driver class for Rose::DB. 660 661=head1 SYNOPSIS 662 663 use Rose::DB; 664 665 Rose::DB->register_db 666 ( 667 domain => 'development', 668 type => 'main', 669 driver => 'Oracle', 670 database => 'dev_db', 671 host => 'localhost', 672 username => 'devuser', 673 password => 'mysecret', 674 ); 675 676 Rose::DB->default_domain('development'); 677 Rose::DB->default_type('main'); 678 ... 679 680 $db = Rose::DB->new; # $db is really a Rose::DB::Oracle-derived object 681 ... 682 683=head1 DESCRIPTION 684 685L<Rose::DB> blesses objects into a class derived from L<Rose::DB::Oracle> when the L<driver|Rose::DB/driver> is "oracle". This mapping of driver names to class names is configurable. See the documentation for L<Rose::DB>'s L<new()|Rose::DB/new> and L<driver_class()|Rose::DB/driver_class> methods for more information. 686 687This class cannot be used directly. You must use L<Rose::DB> and let its L<new()|Rose::DB/new> method return an object blessed into the appropriate class for you, according to its L<driver_class()|Rose::DB/driver_class> mappings. 688 689Only the methods that are new or have different behaviors than those in L<Rose::DB> are documented here. See the L<Rose::DB> documentation for the full list of methods. 690 691B<Oracle 9 or later is required.> 692 693B<Note:> This class is a work in progress. Support for Oracle databases is not yet complete. If you would like to help, please contact John Siracusa at siracusa@gmail.com or post to the L<mailing list|Rose::DB/SUPPORT>. 694 695=head1 CLASS METHODS 696 697=over 4 698 699=item B<default_post_connect_sql [STATEMENTS]> 700 701Get or set the default list of SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to the array of SQL statements in scalar context, or a list of SQL statements in list context. 702 703The L<default_post_connect_sql|/default_post_connect_sql> statements will be run before any statements set using the L<post_connect_sql|/post_connect_sql> method. The default list contains the following: 704 705 ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS' 706 ALTER SESSION SET NLS_TIMESTAMP_FORMAT = 'YYYY-MM-DD HH24:MI:SS.FF' 707 ALTER SESSION SET NLS_TIMESTAMP_TZ_FORMAT = 'YYYY-MM-DD HH24:MI:SS.FF TZHTZM' 708 709If one or more C<NLS_*_FORMAT> environment variables are set, the format strings above are replaced by the values that these environment variables have I<at the time this module is loaded>. 710 711=back 712 713=head1 OBJECT METHODS 714 715=over 4 716 717=item B<post_connect_sql [STATEMENTS]> 718 719Get or set the SQL statements that will be run immediately after connecting to the database. STATEMENTS should be a list or reference to an array of SQL statements. Returns a reference to an array (in scalar) or a list of the L<default_post_connect_sql|/default_post_connect_sql> statements and the L<post_connect_sql|/post_connect_sql> statements. Example: 720 721 $db->post_connect_sql('UPDATE mytable SET num = num + 1'); 722 723 print join("\n", $db->post_connect_sql); 724 725 ALTER SESSION SET NLS_DATE_FORMAT='YYYY-MM-DD HH24:MI:SS' 726 ALTER SESSION SET NLS_TIMESTAMP_FORMAT='YYYY-MM-DD HH24:MI:SSxFF' 727 UPDATE mytable SET num = num + 1 728 729=item B<schema [SCHEMA]> 730 731Get or set the database schema name. In Oracle, every user has a corresponding schema. The schema is comprised of all objects that user owns, and has the same name as that user. Therefore, this attribute defaults to the L<username|Rose::DB/username> if it is not set explicitly. 732 733=back 734 735=head2 Value Parsing and Formatting 736 737=over 4 738 739=item B<validate_date_keyword STRING> 740 741Returns true if STRING is a valid keyword for the PostgreSQL "date" data type. Valid (case-insensitive) date keywords are: 742 743 current_date 744 current_timestamp 745 localtimestamp 746 months_between 747 sysdate 748 systimestamp 749 750The keywords are case sensitive. Any string that looks like a function call (matches C</^\w+\(.*\)$/>) is also considered a valid date keyword if L<keyword_function_calls|Rose::DB/keyword_function_calls> is true. 751 752=item B<validate_timestamp_keyword STRING> 753 754Returns true if STRING is a valid keyword for the Oracle "timestamp" data type, false otherwise. Valid timestamp keywords are: 755 756 current_date 757 current_timestamp 758 localtimestamp 759 months_between 760 sysdate 761 systimestamp 762 763The keywords are case sensitive. Any string that looks like a function call (matches C</^\w+\(.*\)$/>) is also considered a valid timestamp keyword if L<keyword_function_calls|Rose::DB/keyword_function_calls> is true. 764 765=back 766 767=head1 AUTHORS 768 769John C. Siracusa (siracusa@gmail.com), Ron Savage (ron@savage.net.au) 770 771=head1 LICENSE 772 773Copyright (c) 2008 by John Siracusa and Ron Savage. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 774