view release on metacpan or  search on metacpan

t/Pool/Pool.pm  view on Meta::CPAN

    my $stamp = check_cloned($db);
    $stamp += $delta;

    open(my $fh, '>', $db->dir . "/cloned") or die "$!";
    print $fh $stamp, "\n";
    1;
}

# Compare result rows by their test_val column (in order) without asserting the
# absolute test_id values. A PostgreSQL crash recovery -- e.g. after a slow host
# blew the watcher's shutdown grace period and the server was SIGKILLed --
# advances a SERIAL sequence by up to SEQ_LOG_VALS (32), so test_id is not
# deterministic across runs. We still require the ids to be present, positive,
# and strictly increasing in the requested order.
sub check_rows {
    my ($got, $expect_vals, $name) = @_;

    my @vals = map { $_->{test_val} } @$got;
    my $vals_ok = is(\@vals, $expect_vals, $name);

    my $ids_ok = 1;
    my $prev;
    for my $row (@$got) {
        my $id = $row->{test_id};
        unless (defined($id) && $id =~ /^\d+$/ && $id > 0 && (!defined($prev) || $id > $prev)) {
            $ids_ok = 0;
            last;
        }
        $prev = $id;
    }
    ok($ids_ok, "$name (test_ids present, positive, strictly increasing)")
        or diag("test_ids: " . join(', ', map { defined $_->{test_id} ? $_->{test_id} : 'undef' } @$got));

    return $vals_ok && $ids_ok;
}

# Diagnostics for the intermittent freebsd/PostgreSQL-9.3 failure where a clone
# that started fine is dead by the time we connect to it. Dumps everything we
# can about a db -- socket/pid liveness and, crucially, the server's own log --
# to STDERR so it shows up in CPAN smoke reports. Best-effort; never dies.
sub qdb_diag {
    my ($db, $label) = @_;
    return unless $db;

    my @out = ("==== QDB-DIAG [$label] pid=$$ ====");

    my $dir  = eval { $db->dir };
    push @out, "  dir: " . (defined $dir ? $dir : '?');

    my $sock = eval { $db->socket };
    push @out, "  socket: " . (defined $sock ? $sock : '?')
        . " exists=" . (defined $sock && -e $sock ? 1 : 0)
        . " is_socket=" . (defined $sock && -S $sock ? 1 : 0);

    push @out, "  started(): " . (eval { $db->started } ? 1 : 0);

    my $w = $db->{ +DBIx::QuickDB::Driver::WATCHER() };
    if ($w) {
        my $spid = eval { $w->server_pid };
        push @out, "  server_pid: " . (defined $spid ? $spid : '?')
            . " alive=" . (defined $spid && kill(0, $spid) ? 1 : 0);
    }
    else {
        push @out, "  watcher: none (object thinks it is stopped)";
    }

    my $log = eval { $db->error_log };
    if ($log && -f $log) {
        open(my $fh, '<', $log) or push(@out, "  error.log: open failed: $!");
        if ($fh) {
            my @l = <$fh>;
            close($fh);
            @l = @l[-25 .. -1] if @l > 25;
            push @out, "  --- $log (last " . scalar(@l) . " lines) ---";
            for my $line (@l) { chomp $line; push @out, "    | $line" }
        }
    }
    else {
        push @out, "  error.log: " . (defined $log ? "$log (missing)" : 'n/a');
    }

    my $ipcs = eval { `ipcs -m 2>/dev/null | wc -l` };
    my $ipss = eval { `ipcs -s 2>/dev/null | wc -l` };
    chomp($ipcs) if defined $ipcs;
    chomp($ipss) if defined $ipss;
    push @out, "  ipcs shmem-lines=" . (defined $ipcs ? $ipcs : '?')
        . " sem-lines=" . (defined $ipss ? $ipss : '?');

    print STDERR join("\n", @out), "\n";
    return;
}

# Wrap a connect; on failure dump diagnostics for the db, its sibling, and the
# sources it was cloned from, then rethrow so the test still fails.
sub diag_connect {
    my ($db, $label, @others) = @_;
    my $dbh;
    return $dbh if eval { $dbh = $db->connect(); 1 };
    my $err = $@;
    print STDERR "==== QDB-DIAG connect FAILED for [$label]: $err\n";
    qdb_diag($db, $label);
    qdb_diag($_->[1], $_->[0]) for @others;

    # Global snapshot: which postgres processes are alive (orphans?), and the
    # System V IPC objects in play -- the prime suspect for this 9.3 race.
    my $ps = eval { `ps -axww 2>/dev/null | grep '[p]ostgres'` };
    print STDERR "==== QDB-DIAG postgres processes ====\n", (length($ps // '') ? $ps : "  (none)\n");
    my $ipcs = eval { `ipcs -a 2>/dev/null` };
    print STDERR "==== QDB-DIAG ipcs -a ====\n", (length($ipcs // '') ? $ipcs : "  (none)\n");

    die $err;
}

ok($driver, "Got a driver ($driver)") or die "Cannot continue without a driver";

use Test2::Tools::QuickDB qw/skipall_on_resource_error/;
use DBIx::QuickDB::Pool cache_dir => tempdir(CLEANUP => 1), verbose => 0;

# db() that builds/clones a new server can fail on a host out of System V IPC at
# any point in the run, not just the very first build. Wrap the new-server
# allocations so such a host skips (environment limit) instead of failing; any
# other error is rethrown.
sub db_or_skip {
    my @out;
    my $ok = eval { @out = db(@_); 1 };
    return wantarray ? @out : $out[0] if $ok;
    my $err = $@;
    skipall_on_resource_error($err);
    die $err;
}
is(\@Test::Pool::EXPORT_OK, ['db'], "Added db to export_ok");

isa_ok(QDB_POOL(), [$CLASS], "We have access to the $CLASS instance");
can_ok(
    QDB_POOL(),
    [qw/library verbose set_verbose update_checksums set_update_checksums purge_old set_purge_old/],
    "Accessors are as expected"
);
is(QDB_POOL()->library, __PACKAGE__, "Set the library");

driver $driver => (
    driver_args => { $caller && $caller->can('DBD_DRIVER') ? (dbd_driver => $caller->DBD_DRIVER) : () },
    build => sub {
        my $class = shift;
        my ($db) = @_;

        $db->load_sql(quickdb => lc("t/schema/$driver.sql"));

        my $dbh = $db->connect;
        isa_ok($dbh, ['DBI::db'], "Connected");

        ok($dbh->do("INSERT INTO quick_test(test_val) VALUES('base')"), "Insert success");

        my $sth = $dbh->prepare('SELECT * FROM quick_test WHERE test_val = ?');
        $sth->execute('base');
        my $all = $sth->fetchall_arrayref({});
        check_rows($all, ['base'], "Got the inserted row");
    },
);

my $start = time();
# This is the first server built from scratch (initdb + start). On a smoke host
# already out of System V semaphores/shared memory it fails right here; treat
# that as a skip (environment limit), not a failure. Any other error is real.