view release on metacpan or  search on metacpan

t/DAT-TimTen.t  view on Meta::CPAN

use Config;
use Data::Dumper;
use Test::More 0.84;
use Getopt::Long;

use DBI qw(dbi_time);

if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity
    plan skip_all => "transport+policy tests skipped with non-gofer DBI_AUTOPROXY"
        if $ap !~ /^dbi:Gofer/i;
    plan skip_all => "transport+policy tests skipped with non-pedantic policy in DBI_AUTOPROXY"
        if $ap !~ /policy=pedantic\b/i;
}

do "t/lib.pl";


GetOptions(
    'c|count=i' => \(my $opt_count = (-t STDOUT ? 100 : 0)),
    'dbm=s'     => \my $opt_dbm,
    'v|verbose!' => \my $opt_verbose,
    't|transport=s' => \my $opt_transport,
    'p|policy=s'    => \my $opt_policy,
) or exit 1;


# so users can try others from the command line
if (!$opt_dbm) {
    # pick first available, starting with SDBM_File
    for (qw( SDBM_File GDBM_File DB_File BerkeleyDB )) {
        if (eval { local $^W; require "$_.pm" }) {
            $opt_dbm = ($_);
            last;
        }
    }
    plan skip_all => 'No DBM modules available' if !$opt_dbm;
}

my @remote_dsns = DBI->data_sources( "dbi:DBM:", {
    dbm_type => $opt_dbm,
    f_lock => 0,
    f_dir => test_dir() } );
my $remote_dsn = $remote_dsns[0];
( my $remote_driver_dsn = $remote_dsn ) =~ s/dbi:dbm://i;
# Long timeout for slow/overloaded systems (incl virtual machines with low priority)
my $timeout = 240;

if ($ENV{DBI_AUTOPROXY}) {
    # this means we have DAT::TimTen => DAT::TimTen => DBD::DBM!
    # rather than disable it we let it run because we're twisted
    # and because it helps find more bugs (though debugging can be painful)
    warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n"
        unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t
}

# ensure subprocess (for pipeone and stream transport) will use the same modules as us, ie ./blib
local $ENV{PERL5LIB} = join $Config{path_sep}, @INC;

my %durations;
my $getcwd = getcwd();
my $username = eval { getpwuid($>) } || ''; # fails on windows
my $can_ssh = ($username && $username eq 'timbo' && -d '.svn'
            && system("sh -c 'echo > /dev/tcp/localhost/22' 2>/dev/null")==0
);
my $perl = "$^X  -Mblib=$getcwd/blib"; # ensure sameperl and our blib (note two spaces)

my %trials = (
    null       => {},
    pipeone    => { perl=>$perl, timeout=>$timeout },
    stream     => { perl=>$perl, timeout=>$timeout },
    stream_ssh => ($can_ssh)
                ? { perl=>$perl, timeout=>$timeout, url => "ssh:$username\@localhost" }
                : undef,
    #http       => { url => "http://localhost:8001/gofer" },
);

# too dependent on local config to make a standard test
delete $trials{http} unless $username eq 'timbo' && -d '.svn';

my @transports = ($opt_transport) ? ($opt_transport) : (sort keys %trials);
note("Transports: @transports");
my @policies = ($opt_policy) ? ($opt_policy) : qw(pedantic classic rush);
note("Policies: @policies");
note("Count: $opt_count");

for my $trial (@transports) {
    (my $transport = $trial) =~ s/_.*//;
    my $trans_attr = $trials{$trial}
        or next;

    # XXX temporary restrictions, hopefully
    if ( ($^O eq 'MSWin32') || ($^O eq 'VMS') ) {
       # stream needs Fcntl macro F_GETFL for non-blocking
       # and pipe seems to hang on some windows systems
        next if $transport eq 'stream' or $transport eq 'pipeone';
    }

    for my $policy_name (@policies) {

        eval { run_tests($transport, $trans_attr, $policy_name) };
        ($@) ? fail("$trial: $@") : pass();

    }
}

# to get baseline for comparisons if doing performance testing
run_tests('no', {}, 'pedantic') if $opt_count;

while ( my ($activity, $stats_hash) = each %durations ) {
    note("");
    $stats_hash->{'~baseline~'} = delete $stats_hash->{"no+pedantic"};
    for my $perf_tag (reverse sort keys %$stats_hash) {
        my $dur = $stats_hash->{$perf_tag} || 0.0000001;
        note sprintf "  %6s %-16s: %.6fsec (%5d/sec)",
            $activity, $perf_tag, $dur/$opt_count, $opt_count/$dur;
        my $baseline_dur = $stats_hash->{'~baseline~'};
        note sprintf " %+5.1fms", (($dur-$baseline_dur)/$opt_count)*1000
            unless $perf_tag eq '~baseline~';
        note "";
    }
}