#!/usr/local/bin/perl -w
use ExtUtils::testlib;
die "Use 'perl -Mblib test.pl' or 'make test' to run test.pl\n"
    unless "@INC" =~ /\bblib\b/;
# Copyright (c) 1995-2004, Tim Bunce
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.
# XXX
# XXX  PLEASE NOTE THAT THIS CODE IS A RANDOM HOTCH-POTCH OF TESTS AND
# XXX  TEST FRAMEWORKS AND IS IN *NO WAY* A TO BE USED AS A STYLE GUIDE!
# XXX
$| = 1;
use Getopt::Long;
use Config;
my $os = $Config{osname};
GetOptions(
        'm!'    => \my $opt_m,       # do mem leak test
        'n=i'   => \my $opt_n,       # num loops for some tests
        'c=i'   => \my $opt_c,       # RowCacheSize for some tests
        'f=i'   => \my $opt_f,       # fetch test
        'p!'    => \my $opt_p,       # perf test
) or die;
$opt_n ||= 10;
# skip this old set of half-baked oddities if ORACLE_DSN env var is set
exit 0 if $ENV{ORACLE_DSN};
$dbname = $ARGV[0] || '';       # if '' it'll use TWO_TASK/ORACLE_SID
$dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
use Oraperl;
exit test_extfetch_perf($opt_f) if $opt_f;
exit test_leak(10 * $opt_n) if $opt_m;
&ora_version;
my @data_sources = DBI->data_sources('Oracle');
print "Data sources:\n\t", join("\n\t",@data_sources),"\n";
print "Connecting\n",
      " to '$dbname' (from command line, else uses ORACLE_SID or TWO_TASK - recommended)\n";
print " as '$dbuser' (via ORACLE_USERID env var or default - recommend name/passwd\@dbname)\n";
printf("(ORACLE_SID='%s', TWO_TASK='%s')\n", $ENV{ORACLE_SID}||'', $ENV{TWO_TASK}||'');
printf("(LOCAL='%s', REMOTE='%s')\n", $ENV{LOCAL}||'', $ENV{REMOTE}||'') if $os eq 'MSWin32';
{       # test connect works first
    local($l) = &ora_login($dbname, $dbuser, '');
    unless($l) {
        $ora_errno = 0 unless defined $ora_errno;
        $ora_errstr = '' unless defined $ora_errstr;
        warn "ora_login: $ora_errno: $ora_errstr\n";
        # Try to help dumb users who don't know how to connect to oracle...
        warn "\nHave you set the environment variable ORACLE_USERID ?\n"
                    if ($ora_errno == 1017);    # ORA-01017: invalid username/password
        warn "\nHave you included your password in ORACLE_USERID ? (e.g., 'user/passwd')\n"
                    if ($ora_errno == 1017 and $dbuser !~ m:/:);
        warn "\nHave you set the environment variable ORACLE_SID or TWO_TASK?\n"
                    if ($ora_errno == 2700);    # error translating ORACLE_SID
        warn "\nORACLE_SID or TWO_TASK possibly not right, or server not running.\n"
                    if ($ora_errno == 1034);    # ORA-01034: ORACLE not available
        warn "\nTWO_TASK possibly not set correctly right.\n"
                    if ($ora_errno == 12545);
        warn "\n";
        warn "Generally set TWO_TASK or ORACLE_SID but not both at the same time.\n";
        warn "Try to connect to the database using an oracle tool like sqlplus\n";
        warn "only if that works should you suspect problems with DBD::Oracle.\n";
        warn "Try leaving dbname value empty and set dbuser to name/passwd\@dbname.\n";
        die "\nTest aborted.\n";
    }
    if ($os ne 'MSWin32' and $os ne 'VMS') {
        my $backtick = `sleep 1; echo Backticks OK`;
        unless ($backtick) {     # $! == Interrupted system call
            print "Warning: Oracle's SIGCHLD signal handler breaks perl ",
                  "`backticks` commands: $!\n(d_sigaction=$Config{d_sigaction})\n";
        }
    }
    #test_bind_csr($l);
    #test_auto_reprepare($l);
    &ora_logoff($l) || warn "ora_logoff($l): $ora_errno: $ora_errstr\n";
}
&test_intfetch_perf() if $opt_p;
&test1();
print "\nRepetitive connect/open/close/disconnect:\n";
#print "If this test hangs then read the README.help.txt file.\n";
#print "Expect sequence of digits, no other messages:\n";
# likely to fail with: ORA-12516: TNS:listener could not find available handler with matching protocol stack (DBD ERROR: OCIServerAttach)
# in default configurations if the number of iterations is high (>~20)
my $connect_loop_start = DBI::dbi_time();
foreach(1..$opt_n) { print "$_ "; &test2(); }
my $dur = DBI::dbi_time() - $connect_loop_start;
printf "(~%.3f seconds each)\n", $dur / $opt_n;
print "test.pl complete.\n\n";
exit 0;
sub test1 {
    local($lda) = &ora_login($dbname, $dbuser, '')
                        || die "ora_login: $ora_errno: $ora_errstr\n";
    &ora_commit($lda)   || warn "ora_commit($lda): $ora_errno: $ora_errstr\n";
    &ora_rollback($lda) || warn "ora_rollback($lda): $ora_errno: $ora_errstr\n";
    &ora_autocommit($lda, 1);
    &ora_autocommit($lda, 0);
    # Test ora_do with harmless non-select statement
    &ora_do($lda, "set transaction read only ")
                        || warn "ora_do: $ora_errno: $ora_errstr";
    # DBI::dump_results($lda->tables());
    # $lda->debug(2);
    {
        #$lda->trace(2);
        local($csr) = &ora_open($lda,
            "select to_number('7.2', '9D9',
                        'NLS_NUMERIC_CHARACTERS =''.,'''
                    )                   num_t,
                    SYSDATE             date_t,
                    USER                char_t,
                    ROWID               rowid_t,
                    HEXTORAW('7D')      raw_t,
                    NULL                null_t
            from dual") || die "ora_open: $ora_errno: $ora_errstr\n";
        $csr->{RaiseError} = 1;
        print "Fields:    ",scalar(&ora_fetch($csr)),"\n";
        die "ora_fetch in scalar context error" unless &ora_fetch($csr)==6;
        print "Names:     \t",join("\t", &ora_titles($csr)),"\n";
        print "Lengths:   \t",DBI::neat_list([&ora_lengths($csr)],0,"\t"),"\n";
        print "OraTypes:  \t",DBI::neat_list([&ora_types($csr)],    0,"\t"),"\n";
        print "SQLTypes:  \t",DBI::neat_list($csr->{TYPE},           0,"\t"),"\n";
        print "Scale:     \t",DBI::neat_list($csr->{SCALE},          0,"\t"),"\n";
        print "Precision: \t",DBI::neat_list($csr->{PRECISION},      0,"\t"),"\n";
        print "Nullable:  \t",DBI::neat_list($csr->{NULLABLE},       0,"\t"),"\n";
        print "Est row width:\t$csr->{ora_est_row_width}\n";
        print "Prefetch cache:   $csr->{RowsInCache}\n" if $csr->{RowsInCache};
        print "Data rows:\n";
        #$csr->debug(2);
        while(@fields = $csr->fetchrow_array) {
            die "ora_fetch returned ".@fields." fields instead of 6!"
                    if @fields != 6;
            die "Perl list/scalar context error" if @fields==1;
            print "    fetch: ", DBI::neat_list(\@fields),"\n";
        }
        &ora_close($csr) || warn "ora_close($csr): $ora_errno: $ora_errstr\n";
    }
    &ora_logoff($lda)   || warn "ora_logoff($lda): $ora_errno: $ora_errstr\n";
}
sub test2 {             # also used by test_leak()
    my $execute_sth = shift;
    my $dbh = DBI->connect("dbi:Oracle:$dbname", $dbuser, '', { RaiseError=>1 });
    if ($execute_sth) {
        my $sth = $dbh->prepare("select 42,'foo',sysdate from dual where ? >= 1");
        while ($execute_sth-- > 0) {
            $sth->execute(1);
            my @row = $sth->fetchrow_array;
            $sth->finish;
        }
    }
    $dbh->disconnect;
}
sub test_leak {
    local($count) = @_;
    local($ps) = (-d '/proc') ? "ps -lp " : "ps -l";
    local($i) = 0;
    my $execute_sth = 100;
    print "\nMemory leak test: (execute $execute_sth):\n";
    while(++$i <= $count) {
        &test2($execute_sth);
        system("echo $i; $ps$$") if (($i % 10) == 1);
    }
    system("echo $i; $ps$$");
    print "Done.\n\n";
}
sub count_fetch {
    local($csr) = @_;
    local($rows) = 0;
   # while((@row) = &ora_fetch($csr)) {
    while((@row) = $csr->fetchrow_array) {
       ++$rows;
    }
    die "count_fetch $ora_errstr" if $ora_errno;
    return $rows;
}
sub test_intfetch_perf {
    print "\nTesting internal row fetch overhead.\n";
    local($lda) = &ora_login($dbname, $dbuser, '')
                    || die "ora_login: $ora_errno: $ora_errstr\n";
    DBI->trace(0);
    $lda->trace(0);
    local($csr) = &ora_open($lda,"select 0,1,2,3,4,5,6,7,8,9 from dual");
    local($max) = 50000;
    $csr->{ora_fetchtest} = $max;
    require Benchmark;
    $t0 = new Benchmark;
    1 while $csr->fetchrow_arrayref;
    $td = Benchmark::timediff((new Benchmark), $t0);
    $csr->{ora_fetchtest} = 0;
    printf("$max fetches: ".Benchmark::timestr($td)."\n");
    printf("%d per clock second, %d per cpu second\n\n",
            $max/($td->real  ? $td->real  : 1),
            $max/($td->cpu_a ? $td->cpu_a : 1));
}
sub test_extfetch_perf {
    my $max = shift;
    print "\nTesting external row fetch overhead.\n";
    my $rows = 0;
    my $dbh = DBI->connect("dbi:Oracle:$dbname", $dbuser, '', { RaiseError => 1 });
    #$dbh->trace(2);
    $dbh->{RowCacheSize} = $::opt_c if defined  $::opt_c;
    my $fields = (0) ? "*" : "object_name, status, object_type";
    my $sth = $dbh->prepare(q{
        select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        union all select all * from all_objects o1
        --, all_objects o2
        --where o1.object_id <= 400 and o2.object_id <= 400
    }, { ora_check_sql => 1 });
    require Benchmark;
    $t0 = new Benchmark;
    $sth->execute;
    $sth->trace(0);
    $sth->fetchrow_arrayref; # fetch one before starting timer
    $td = Benchmark::timediff((new Benchmark), $t0);
    printf("Execute: ".Benchmark::timestr($td)."\n");
    print "Fetching data with RowCacheSize $dbh->{RowCacheSize}...\n";
    $t1 = new Benchmark;
    1 while $sth->fetchrow_arrayref && ++$rows < $max;
    $td = Benchmark::timediff((new Benchmark), $t1);
    printf("$rows fetches: ".Benchmark::timestr($td)."\n");
    printf("%d per clock second, %d per cpu second\n",
            $rows/($td->real  ? $td->real  : 1),
            $rows/($td->cpu_a ? $td->cpu_a : 1));
    my $ps = (-d '/proc') ? "ps -lp " : "ps -l";
    system("echo Process memory size; $ps$$");
    print "\n";
    $sth->finish;
    $dbh->disconnect;
    exit 1;
}
sub test_bind_csr {
    local($lda) = @_;
$lda->{RaiseError} =1;
$lda->trace(2);
my $out_csr = $lda->prepare(q{select 42 from dual}); # sacrificial csr XXX
$csr = $lda->prepare(q{
    begin
    OPEN :csr_var FOR select * from all_tables;
    end;
});
$csr->bind_param_inout(':csr_var', \$out_csr, 100, { ora_type => 102 });
$csr->execute();
# at this point $out_csr should be a handle on a new oracle cursor
@row = $out_csr->fetchrow_array;
    exit 1;
}
sub test_auto_reprepare {
    local($dbh) = @_;
    $dbh->do(q{drop table timbo});
    $dbh->{RaiseError} =1;
    #$dbh->trace(2);
    $dbh->do(q{create table timbo ( foo integer)});
    $dbh->do(q{insert into timbo values (91)});
    $dbh->do(q{insert into timbo values (92)});
    $dbh->do(q{insert into timbo values (93)});
    $dbh->commit;
        $Oraperl::ora_cache = $Oraperl::ora_cache = 1;
    my $sth = $dbh->prepare(q{select * from timbo for update});
    $sth->execute; $sth->dump_results;
    $sth->execute;
    print $sth->fetchrow_array,"\n";
    $dbh->commit;
    print $sth->fetchrow_array,"\n";
    $dbh->do(q{drop table timbo});
    exit 1;
}
# end.