1package App::Sqitch::Engine::oracle; 2 3use 5.010; 4use Moo; 5use utf8; 6use Path::Class; 7use DBI; 8use Try::Tiny; 9use App::Sqitch::X qw(hurl); 10use Locale::TextDomain qw(App-Sqitch); 11use App::Sqitch::Plan::Change; 12use List::Util qw(first); 13use App::Sqitch::Types qw(DBH Dir ArrayRef); 14use namespace::autoclean; 15 16extends 'App::Sqitch::Engine'; 17 18our $VERSION = '0.9994'; 19 20BEGIN { 21 # We tell the Oracle connector which encoding to use. The last part of the 22 # environment variable NLS_LANG is relevant concerning data encoding. 23 $ENV{NLS_LANG} = 'AMERICAN_AMERICA.AL32UTF8'; 24 25 # Disable SQLPATH so that no start scripts run. 26 $ENV{SQLPATH} = ''; 27} 28 29sub destination { 30 my $self = shift; 31 32 # Just use the target name if it doesn't look like a URI or if the URI 33 # includes the database name. 34 return $self->target->name if $self->target->name !~ /:/ 35 || $self->target->uri->dbname; 36 37 # Use the URI sans password, and with the database name added. 38 my $uri = $self->target->uri->clone; 39 $uri->password(undef) if $uri->password; 40 $uri->dbname( 41 $ENV{TWO_TASK} 42 || ( $^O eq 'MSWin32' ? $ENV{LOCAL} : undef ) 43 || $ENV{ORACLE_SID} 44 || $self->username 45 || $self->sqitch->sysuser 46 ); 47 return $uri->as_string; 48} 49 50has _sqlplus => ( 51 is => 'ro', 52 isa => ArrayRef, 53 lazy => 1, 54 default => sub { 55 my $self = shift; 56 [ $self->client, qw(-S -L /nolog) ]; 57 }, 58); 59 60sub sqlplus { @{ shift->_sqlplus } } 61 62has tmpdir => ( 63 is => 'ro', 64 isa => Dir, 65 lazy => 1, 66 default => sub { 67 require File::Temp; 68 dir File::Temp::tempdir( CLEANUP => 1 ); 69 }, 70); 71 72sub key { 'oracle' } 73sub name { 'Oracle' } 74sub driver { 'DBD::Oracle 1.23' } 75sub default_registry { '' } 76 77sub default_client { 78 file( ($ENV{ORACLE_HOME} || ()), 'sqlplus' )->stringify 79} 80 81has dbh => ( 82 is => 'rw', 83 isa => DBH, 84 lazy => 1, 85 default => sub { 86 my $self = shift; 87 $self->use_driver; 88 89 my $uri = $self->uri; 90 DBI->connect($uri->dbi_dsn, $self->username, $self->password, { 91 PrintError => 0, 92 RaiseError => 0, 93 AutoCommit => 1, 94 FetchHashKeyName => 'NAME_lc', 95 HandleError => sub { 96 my ($err, $dbh) = @_; 97 $@ = $err; 98 @_ = ($dbh->state || 'DEV' => $dbh->errstr); 99 goto &hurl; 100 }, 101 Callbacks => { 102 connected => sub { 103 my $dbh = shift; 104 $dbh->do("ALTER SESSION SET $_='YYYY-MM-DD HH24:MI:SS TZR'") for qw( 105 nls_date_format 106 nls_timestamp_format 107 nls_timestamp_tz_format 108 ); 109 if (my $schema = $self->registry) { 110 try { 111 $dbh->do("ALTER SESSION SET CURRENT_SCHEMA = $schema"); 112 # http://www.nntp.perl.org/group/perl.dbi.dev/2013/11/msg7622.html 113 $dbh->set_err(undef, undef) if $dbh->err; 114 }; 115 } 116 return; 117 }, 118 }, 119 }); 120 } 121); 122 123# Need to wait until dbh is defined. 124with 'App::Sqitch::Role::DBIEngine'; 125 126sub _log_tags_param { 127 [ map { $_->format_name } $_[1]->tags ]; 128} 129 130sub _log_requires_param { 131 [ map { $_->as_string } $_[1]->requires ]; 132} 133 134sub _log_conflicts_param { 135 [ map { $_->as_string } $_[1]->conflicts ]; 136} 137 138sub _ts2char_format { 139 q{to_char(%1$s AT TIME ZONE 'UTC', '"year":YYYY:"month":MM:"day":DD') || to_char(%1$s AT TIME ZONE 'UTC', ':"hour":HH24:"minute":MI:"second":SS:"time_zone":"UTC"')} 140} 141 142sub _ts_default { 'current_timestamp' } 143 144sub _can_limit { 0 } 145 146sub _char2ts { 147 my $dt = $_[1]; 148 join ' ', $dt->ymd('-'), $dt->hms(':'), $dt->time_zone->name; 149} 150 151sub _listagg_format { 152 # http://stackoverflow.com/q/16313631/79202 153 return q{CAST(COLLECT(CAST(%s AS VARCHAR2(512))) AS sqitch_array)}; 154} 155 156sub _regex_op { 'REGEXP_LIKE(%s, ?)' } 157 158sub _simple_from { ' FROM dual' } 159 160sub _multi_values { 161 my ($self, $count, $expr) = @_; 162 return join "\nUNION ALL ", ("SELECT $expr FROM dual") x $count; 163} 164 165sub _dt($) { 166 require App::Sqitch::DateTime; 167 return App::Sqitch::DateTime->new(split /:/ => shift); 168} 169 170sub _cid { 171 my ( $self, $ord, $offset, $project ) = @_; 172 173 return try { 174 return $self->dbh->selectcol_arrayref(qq{ 175 SELECT change_id FROM ( 176 SELECT change_id, rownum as rnum FROM ( 177 SELECT change_id 178 FROM changes 179 WHERE project = ? 180 ORDER BY committed_at $ord 181 ) 182 ) WHERE rnum = ? 183 }, undef, $project || $self->plan->project, ($offset // 0) + 1)->[0]; 184 } catch { 185 return if $self->_no_table_error; 186 die $_; 187 }; 188} 189 190sub _cid_head { 191 my ($self, $project, $change) = @_; 192 return $self->dbh->selectcol_arrayref(qq{ 193 SELECT change_id FROM ( 194 SELECT change_id 195 FROM changes 196 WHERE project = ? 197 AND change = ? 198 ORDER BY committed_at DESC 199 ) WHERE rownum = 1 200 }, undef, $project, $change)->[0]; 201} 202 203sub _select_state { 204 my ( $self, $project, $with_hash ) = @_; 205 my $cdtcol = sprintf $self->_ts2char_format, 'c.committed_at'; 206 my $pdtcol = sprintf $self->_ts2char_format, 'c.planned_at'; 207 my $tagcol = sprintf $self->_listagg_format, 't.tag'; 208 my $hshcol = $with_hash ? "c.script_hash\n , " : ''; 209 my $dbh = $self->dbh; 210 return $dbh->selectrow_hashref(qq{ 211 SELECT * FROM ( 212 SELECT c.change_id 213 , ${hshcol}c.change 214 , c.project 215 , c.note 216 , c.committer_name 217 , c.committer_email 218 , $cdtcol AS committed_at 219 , c.planner_name 220 , c.planner_email 221 , $pdtcol AS planned_at 222 , $tagcol AS tags 223 FROM changes c 224 LEFT JOIN tags t ON c.change_id = t.change_id 225 WHERE c.project = ? 226 GROUP BY c.change_id 227 , ${hshcol}c.change 228 , c.project 229 , c.note 230 , c.committer_name 231 , c.committer_email 232 , c.committed_at 233 , c.planner_name 234 , c.planner_email 235 , c.planned_at 236 ORDER BY c.committed_at DESC 237 ) WHERE rownum = 1 238 }, undef, $project // $self->plan->project); 239} 240 241sub is_deployed_change { 242 my ( $self, $change ) = @_; 243 $self->dbh->selectcol_arrayref( 244 'SELECT 1 FROM changes WHERE change_id = ?', 245 undef, $change->id 246 )->[0]; 247} 248 249sub initialized { 250 my $self = shift; 251 return $self->dbh->selectcol_arrayref(q{ 252 SELECT 1 253 FROM all_tables 254 WHERE owner = UPPER(?) 255 AND table_name = 'CHANGES' 256 }, undef, $self->registry || $self->username)->[0]; 257} 258 259sub _log_event { 260 my ( $self, $event, $change, $tags, $requires, $conflicts) = @_; 261 my $dbh = $self->dbh; 262 my $sqitch = $self->sqitch; 263 264 $tags ||= $self->_log_tags_param($change); 265 $requires ||= $self->_log_requires_param($change); 266 $conflicts ||= $self->_log_conflicts_param($change); 267 268 # Use the sqitch_array() constructor to insert arrays of values. 269 my $tag_ph = 'sqitch_array('. join(', ', ('?') x @{ $tags }) . ')'; 270 my $req_ph = 'sqitch_array('. join(', ', ('?') x @{ $requires }) . ')'; 271 my $con_ph = 'sqitch_array('. join(', ', ('?') x @{ $conflicts }) . ')'; 272 my $ts = $self->_ts_default; 273 274 $dbh->do(qq{ 275 INSERT INTO events ( 276 event 277 , change_id 278 , change 279 , project 280 , note 281 , tags 282 , requires 283 , conflicts 284 , committer_name 285 , committer_email 286 , planned_at 287 , planner_name 288 , planner_email 289 , committed_at 290 ) 291 VALUES (?, ?, ?, ?, ?, $tag_ph, $req_ph, $con_ph, ?, ?, ?, ?, ?, $ts) 292 }, undef, 293 $event, 294 $change->id, 295 $change->name, 296 $change->project, 297 $change->note, 298 @{ $tags }, 299 @{ $requires }, 300 @{ $conflicts }, 301 $sqitch->user_name, 302 $sqitch->user_email, 303 $self->_char2ts( $change->timestamp ), 304 $change->planner_name, 305 $change->planner_email, 306 ); 307 308 return $self; 309} 310 311sub changes_requiring_change { 312 my ( $self, $change ) = @_; 313 # Why CTE: https://forums.oracle.com/forums/thread.jspa?threadID=1005221 314 return @{ $self->dbh->selectall_arrayref(q{ 315 WITH tag AS ( 316 SELECT tag, committed_at, project, 317 ROW_NUMBER() OVER (partition by project ORDER BY committed_at) AS rnk 318 FROM tags 319 ) 320 SELECT c.change_id, c.project, c.change, t.tag AS asof_tag 321 FROM dependencies d 322 JOIN changes c ON c.change_id = d.change_id 323 LEFT JOIN tag t ON t.project = c.project AND t.committed_at >= c.committed_at 324 WHERE d.dependency_id = ? 325 AND (t.rnk IS NULL OR t.rnk = 1) 326 }, { Slice => {} }, $change->id) }; 327} 328 329sub name_for_change_id { 330 my ( $self, $change_id ) = @_; 331 # Why CTE: https://forums.oracle.com/forums/thread.jspa?threadID=1005221 332 return $self->dbh->selectcol_arrayref(q{ 333 WITH tag AS ( 334 SELECT tag, committed_at, project, 335 ROW_NUMBER() OVER (partition by project ORDER BY committed_at) AS rnk 336 FROM tags 337 ) 338 SELECT change || COALESCE(t.tag, '') 339 FROM changes c 340 LEFT JOIN tag t ON c.project = t.project AND t.committed_at >= c.committed_at 341 WHERE change_id = ? 342 AND (t.rnk IS NULL OR t.rnk = 1) 343 }, undef, $change_id)->[0]; 344} 345 346sub change_id_offset_from_id { 347 my ( $self, $change_id, $offset ) = @_; 348 349 # Just return the ID if there is no offset. 350 return $change_id unless $offset; 351 352 # Are we offset forwards or backwards? 353 my ( $dir, $op ) = $offset > 0 ? ( 'ASC', '>' ) : ( 'DESC' , '<' ); 354 return $self->dbh->selectcol_arrayref(qq{ 355 SELECT id FROM ( 356 SELECT id, rownum AS rnum FROM ( 357 SELECT change_id AS id 358 FROM changes 359 WHERE project = ? 360 AND committed_at $op ( 361 SELECT committed_at FROM changes WHERE change_id = ? 362 ) 363 ORDER BY committed_at $dir 364 ) 365 ) WHERE rnum = ? 366 }, undef, $self->plan->project, $change_id, abs $offset)->[0]; 367} 368 369sub change_offset_from_id { 370 my ( $self, $change_id, $offset ) = @_; 371 372 # Just return the object if there is no offset. 373 return $self->load_change($change_id) unless $offset; 374 375 # Are we offset forwards or backwards? 376 my ( $dir, $op ) = $offset > 0 ? ( 'ASC', '>' ) : ( 'DESC' , '<' ); 377 my $tscol = sprintf $self->_ts2char_format, 'c.planned_at'; 378 my $tagcol = sprintf $self->_listagg_format, 't.tag'; 379 380 my $change = $self->dbh->selectrow_hashref(qq{ 381 SELECT id, name, project, note, timestamp, planner_name, planner_email, tags 382 FROM ( 383 SELECT id, name, project, note, timestamp, planner_name, planner_email, tags, rownum AS rnum 384 FROM ( 385 SELECT c.change_id AS id, c.change AS name, c.project, c.note, 386 $tscol AS timestamp, c.planner_name, c.planner_email, 387 $tagcol AS tags 388 FROM changes c 389 LEFT JOIN tags t ON c.change_id = t.change_id 390 WHERE c.project = ? 391 AND c.committed_at $op ( 392 SELECT committed_at FROM changes WHERE change_id = ? 393 ) 394 GROUP BY c.change_id, c.change, c.project, c.note, c.planned_at, 395 c.planner_name, c.planner_email, c.committed_at 396 ORDER BY c.committed_at $dir 397 ) 398 ) WHERE rnum = ? 399 }, undef, $self->plan->project, $change_id, abs $offset) || return undef; 400 $change->{timestamp} = _dt $change->{timestamp}; 401 return $change; 402} 403 404sub is_deployed_tag { 405 my ( $self, $tag ) = @_; 406 return $self->dbh->selectcol_arrayref( 407 'SELECT 1 FROM tags WHERE tag_id = ?', 408 undef, $tag->id 409 )->[0]; 410} 411 412sub are_deployed_changes { 413 my $self = shift; 414 my @qs; 415 my $i = @_; 416 while ($i > 250) { 417 push @qs => 'change_id IN (' . join(', ' => ('?') x 250) . ')'; 418 $i -= 250; 419 } 420 push @qs => 'change_id IN (' . join(', ' => ('?') x @_) . ')'; 421 my $expr = join ' OR ', @qs; 422 @{ $self->dbh->selectcol_arrayref( 423 "SELECT change_id FROM changes WHERE $expr", 424 undef, 425 map { $_->id } @_, 426 ) }; 427} 428 429sub _registry_variable { 430 my $self = shift; 431 my $schema = $self->registry; 432 return $schema ? ("DEFINE registry=$schema") : ( 433 # Select the current schema into ®istry. 434 # http://www.orafaq.com/node/515 435 'COLUMN sname for a30 new_value registry', 436 q{SELECT SYS_CONTEXT('USERENV', 'SESSION_SCHEMA') AS sname FROM DUAL;}, 437 ); 438} 439 440sub initialize { 441 my $self = shift; 442 my $schema = $self->registry; 443 hurl engine => __ 'Sqitch already initialized' if $self->initialized; 444 445 # Load up our database. 446 (my $file = file(__FILE__)->dir->file('oracle.sql')) =~ s/"/""/g; 447 $self->_run_with_verbosity($file); 448 $self->dbh->do("ALTER SESSION SET CURRENT_SCHEMA = $schema") if $schema; 449 $self->_register_release; 450} 451 452# Override for special handling of regular the expression operator and 453# LIMIT/OFFSET. 454sub search_events { 455 my ( $self, %p ) = @_; 456 457 # Determine order direction. 458 my $dir = 'DESC'; 459 if (my $d = delete $p{direction}) { 460 $dir = $d =~ /^ASC/i ? 'ASC' 461 : $d =~ /^DESC/i ? 'DESC' 462 : hurl 'Search direction must be either "ASC" or "DESC"'; 463 } 464 465 # Limit with regular expressions? 466 my (@wheres, @params); 467 for my $spec ( 468 [ committer => 'committer_name' ], 469 [ planner => 'planner_name' ], 470 [ change => 'change' ], 471 [ project => 'project' ], 472 ) { 473 my $regex = delete $p{ $spec->[0] } // next; 474 push @wheres => "REGEXP_LIKE($spec->[1], ?)"; 475 push @params => $regex; 476 } 477 478 # Match events? 479 if (my $e = delete $p{event} ) { 480 my ($in, @vals) = $self->_in_expr( $e ); 481 push @wheres => "event $in"; 482 push @params => @vals; 483 } 484 485 # Assemble the where clause. 486 my $where = @wheres 487 ? "\n WHERE " . join( "\n ", @wheres ) 488 : ''; 489 490 # Handle remaining parameters. 491 my ($lim, $off) = (delete $p{limit}, delete $p{offset}); 492 493 hurl 'Invalid parameters passed to search_events(): ' 494 . join ', ', sort keys %p if %p; 495 496 # Prepare, execute, and return. 497 my $cdtcol = sprintf $self->_ts2char_format, 'committed_at'; 498 my $pdtcol = sprintf $self->_ts2char_format, 'planned_at'; 499 my $sql = qq{ 500 SELECT event 501 , project 502 , change_id 503 , change 504 , note 505 , requires 506 , conflicts 507 , tags 508 , committer_name 509 , committer_email 510 , $cdtcol AS committed_at 511 , planner_name 512 , planner_email 513 , $pdtcol AS planned_at 514 FROM events$where 515 ORDER BY events.committed_at $dir 516 }; 517 518 if ($lim || $off) { 519 my @limits; 520 if ($lim) { 521 $off //= 0; 522 push @params => $lim + $off; 523 push @limits => 'rnum <= ?'; 524 } 525 if ($off) { 526 push @params => $off; 527 push @limits => 'rnum > ?'; 528 } 529 530 $sql = "SELECT * FROM ( SELECT ROWNUM AS rnum, i.* FROM ($sql) i ) WHERE " 531 . join ' AND ', @limits; 532 } 533 534 my $sth = $self->dbh->prepare($sql); 535 $sth->execute(@params); 536 return sub { 537 my $row = $sth->fetchrow_hashref or return; 538 delete $row->{rnum}; 539 $row->{committed_at} = _dt $row->{committed_at}; 540 $row->{planned_at} = _dt $row->{planned_at}; 541 return $row; 542 }; 543} 544 545# Override to lock the changes table. This ensures that only one instance of 546# Sqitch runs at one time. 547sub begin_work { 548 my $self = shift; 549 my $dbh = $self->dbh; 550 551 # Start transaction and lock changes to allow only one change at a time. 552 $dbh->begin_work; 553 $dbh->do('LOCK TABLE changes IN EXCLUSIVE MODE'); 554 return $self; 555} 556 557sub _file_for_script { 558 my ($self, $file) = @_; 559 560 # Just use the file if no special character. 561 if ($file !~ /[@?%\$]/) { 562 $file =~ s/"/""/g; 563 return $file; 564 } 565 566 # Alias or copy the file to a temporary directory that's removed on exit. 567 (my $alias = $file->basename) =~ s/[@?%\$]/_/g; 568 $alias = $self->tmpdir->file($alias); 569 570 # Remove existing file. 571 if (-e $alias) { 572 $alias->remove or hurl oracle => __x( 573 'Cannot remove {file}: {error}', 574 file => $alias, 575 error => $! 576 ); 577 } 578 579 if ($^O eq 'MSWin32') { 580 # Copy it. 581 $file->copy_to($alias) or hurl oracle => __x( 582 'Cannot copy {file} to {alias}: {error}', 583 file => $file, 584 alias => $alias, 585 error => $! 586 ); 587 } else { 588 # Symlink it. 589 $alias->remove; 590 symlink $file->absolute, $alias or hurl oracle => __x( 591 'Cannot symlink {file} to {alias}: {error}', 592 file => $file, 593 alias => $alias, 594 error => $! 595 ); 596 } 597 598 # Return the alias. 599 $alias =~ s/"/""/g; 600 return $alias; 601} 602 603sub run_file { 604 my $self = shift; 605 my $file = $self->_file_for_script(shift); 606 $self->_run(qq{\@"$file"}); 607} 608 609sub _run_with_verbosity { 610 my $self = shift; 611 my $file = $self->_file_for_script(shift); 612 # Suppress STDOUT unless we want extra verbosity. 613 my $meth = $self->can($self->sqitch->verbosity > 1 ? '_run' : '_capture'); 614 $self->$meth(qq{\@"$file"}); 615} 616 617sub run_upgrade { shift->_run_with_verbosity(@_) } 618sub run_verify { shift->_run_with_verbosity(@_) } 619 620sub run_handle { 621 my ($self, $fh) = @_; 622 my $conn = $self->_script; 623 open my $tfh, '<:utf8_strict', \$conn; 624 $self->sqitch->spool( [$tfh, $fh], $self->sqlplus ); 625} 626 627# Override to take advantage of the RETURNING expression, and to save tags as 628# an array rather than a space-delimited string. 629sub log_revert_change { 630 my ($self, $change) = @_; 631 my $dbh = $self->dbh; 632 my $cid = $change->id; 633 634 # Delete tags. 635 my $sth = $dbh->prepare( 636 'DELETE FROM tags WHERE change_id = ? RETURNING tag INTO ?', 637 ); 638 $sth->bind_param(1, $cid); 639 $sth->bind_param_inout_array(2, my $del_tags = [], 0, { 640 ora_type => DBD::Oracle::ORA_VARCHAR2() 641 }); 642 $sth->execute; 643 644 # Retrieve dependencies. 645 my $depcol = sprintf $self->_listagg_format, 'dependency'; 646 my ($req, $conf) = $dbh->selectrow_array(qq{ 647 SELECT ( 648 SELECT $depcol 649 FROM dependencies 650 WHERE change_id = ? 651 AND type = 'require' 652 ), 653 ( 654 SELECT $depcol 655 FROM dependencies 656 WHERE change_id = ? 657 AND type = 'conflict' 658 ) FROM dual 659 }, undef, $cid, $cid); 660 661 # Delete the change record. 662 $dbh->do( 663 'DELETE FROM changes where change_id = ?', 664 undef, $change->id, 665 ); 666 667 # Log it. 668 return $self->_log_event( revert => $change, $del_tags, $req, $conf ); 669} 670 671sub _ts2char($) { 672 my $col = shift; 673 return qq{to_char($col AT TIME ZONE 'UTC', 'YYYY:MM:DD:HH24:MI:SS')}; 674} 675 676sub _no_table_error { 677 return $DBI::err && $DBI::err == 942; # ORA-00942: table or view does not exist 678} 679 680sub _no_column_error { 681 return $DBI::err && $DBI::err == 904; # ORA-00904: invalid identifier 682} 683 684sub _script { 685 my $self = shift; 686 my $uri = $self->uri; 687 my $conn = ''; 688 my ($user, $pass, $host, $port) = ( 689 $self->username, $self->password, $uri->host, $uri->_port 690 ); 691 if ($user || $pass || $host || $port) { 692 $conn = $user // ''; 693 if ($pass) { 694 $pass =~ s/"/""/g; 695 $conn .= qq{/"$pass"}; 696 } 697 if (my $db = $uri->dbname) { 698 $conn .= '@'; 699 $db =~ s/"/""/g; 700 if ($host || $port) { 701 $conn .= '//' . ($host || ''); 702 if ($port) { 703 $conn .= ":$port"; 704 } 705 $conn .= qq{/"$db"}; 706 } else { 707 $conn .= qq{"$db"}; 708 } 709 } 710 } else { 711 # OS authentication or Oracle wallet (no username or password). 712 if (my $db = $uri->dbname) { 713 $db =~ s/"/""/g; 714 $conn = qq{/@"$db"}; 715 } 716 } 717 my %vars = $self->variables; 718 719 return join "\n" => ( 720 'SET ECHO OFF NEWP 0 SPA 0 PAGES 0 FEED OFF HEAD OFF TRIMS ON TAB OFF', 721 'WHENEVER OSERROR EXIT 9;', 722 'WHENEVER SQLERROR EXIT SQL.SQLCODE;', 723 (map {; (my $v = $vars{$_}) =~ s/"/""/g; qq{DEFINE $_="$v"} } sort keys %vars), 724 "connect $conn", 725 $self->_registry_variable, 726 @_ 727 ); 728} 729 730sub _run { 731 my $self = shift; 732 my $script = $self->_script(@_); 733 open my $fh, '<:utf8_strict', \$script; 734 return $self->sqitch->spool( $fh, $self->sqlplus ); 735} 736 737sub _capture { 738 my $self = shift; 739 my $conn = $self->_script(@_); 740 my @out; 741 742 require IPC::Run3; 743 IPC::Run3::run3( 744 [$self->sqlplus], \$conn, \@out, @out, 745 { return_if_system_error => 1 }, 746 ); 747 if (my $err = $?) { 748 # Ugh, send everything to STDERR. 749 $self->sqitch->vent(@out); 750 hurl io => __x( 751 '{command} unexpectedly returned exit value {exitval}', 752 command => $self->client, 753 exitval => ($err >> 8), 754 ); 755 } 756 757 return wantarray ? @out : \@out; 758} 759 7601; 761 762__END__ 763 764=head1 Name 765 766App::Sqitch::Engine::oracle - Sqitch Oracle Engine 767 768=head1 Synopsis 769 770 my $oracle = App::Sqitch::Engine->load( engine => 'oracle' ); 771 772=head1 Description 773 774App::Sqitch::Engine::oracle provides the Oracle storage engine for Sqitch. It 775supports Oracle 10g and higher. 776 777=head1 Interface 778 779=head2 Instance Methods 780 781=head3 C<initialized> 782 783 $oracle->initialize unless $oracle->initialized; 784 785Returns true if the database has been initialized for Sqitch, and false if it 786has not. 787 788=head3 C<initialize> 789 790 $oracle->initialize; 791 792Initializes a database for Sqitch by installing the Sqitch registry schema. 793 794=head3 C<sqlplus> 795 796Returns a list containing the C<sqlplus> client and options to be passed to it. 797Used internally when executing scripts. 798 799=head1 Author 800 801David E. Wheeler <david@justatheory.com> 802 803=head1 License 804 805Copyright (c) 2012-2015 iovation Inc. 806 807Permission is hereby granted, free of charge, to any person obtaining a copy 808of this software and associated documentation files (the "Software"), to deal 809in the Software without restriction, including without limitation the rights 810to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 811copies of the Software, and to permit persons to whom the Software is 812furnished to do so, subject to the following conditions: 813 814The above copyright notice and this permission notice shall be included in all 815copies or substantial portions of the Software. 816 817THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 818IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 819FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 820AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 821LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 822OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 823SOFTWARE. 824 825=cut 826