script/bench-sql-functions
Rama main · réplica de lectura del repositorio original.
#!/usr/bin/env perl
# SPDX-FileCopyrightText: 2026 GPForum Contributors
# SPDX-License-Identifier: BSD-3-Clause
package main;
use v5.40;
use Carp qw(croak);
use Const::Fast;
use Config qw(%Config);
use DBI;
use English qw(-no_match_vars);
use FindBin qw($Bin);
use Getopt::Long qw(GetOptionsFromArray);
use IO::Select;
use IO::Socket::IP;
use IO::Socket::UNIX;
use File::Temp qw(tempdir);
use JSON::MaybeXS qw(encode_json);
use MIME::Base64 qw(encode_base64url);
use POSIX qw(_exit clock setsid strftime);
use Time::HiRes qw(sleep time);
use lib "$Bin/../lib";
use lib "$Bin/../t/lib";
use lib 't/lib';
use GPForum::Test::PgSchema;
use GPForum::Benchmark::BucketProfile;
use GPForum::Benchmark::SeedDataset qw(seed_id);
use GPForum::Command::Migrate;
use GPForum::Command::PerformanceSeed;
use GPForum::Config;
use GPForum::Infrastructure::Id;
use GPForum::Infrastructure::SqlFunction;
use GPForum::Schema;
use GPForum::Service::Admin::PermissionGate;
use GPForum::Service::Forum::ViewerResolver;
use GPForum::Service::Identity::SessionStore;
use GPForum::Service::Moderation::SuspensionStore;
use GPForum::Service::Operations::RateLimiter::PostgreSQLStore;
use GPForum::Service::Forum::ThreadReader;
use GPForum::Service::Forum::HomePageReader;
use GPForum::Service::Forum::Readability;
use GPForum::Service::Forum::ReadState;
use GPForum::Service::Forum::ReadWorkflow;
use GPForum::Service::Search::Indexer;
use GPForum::Service::Search::Searcher;
use GPForum::Service::Search::PermissionEngine;
use GPForum::Service::Notification::Dispatcher;
use GPForum::Service::Community::MentionStore;
use GPForum::Service::Forum::CategoryReader;
use GPForum::Service::Forum::PostComposer;
use GPForum::Service::Forum::PostReader;
use GPForum::Service::Forum::PostStore;
use GPForum::Service::Forum::PostingWorkflow;
use GPForum::Service::Forum::ThreadComposer;
use GPForum::Service::Forum::ThreadDetailReader;
use GPForum::Service::Forum::ThreadStore;
use GPForum::Service::Forum::Viewer;
use GPForum::Service::Operations::CommandIdempotency;
our $VERSION = '0.001';
# ADR 0126: what an operation costs on the path DBIx::Class builds and on
# the PostgreSQL function that replaces it, on the same seeded database. Per
# operation and path: the Perl CPU, the share of it spent in DBIx::Class
# (SQL::Abstract building the SQL, resultsets, storage, row inflation,
# accessors) against the time spent waiting on DBI, the wall time's median
# and 95th percentile with the database on this host and through a proxy
# that delays each direction (a database on another host), and the
# statements and round trips. A maintainer's tool: it makes a database of
# its own, seeds it as t/integration/postgres-query-plan-depth.t does, and
# drops it.
const my %DEFAULT => (
'delay-ms' => 0.5,
'read-iterations' => 200,
'warmup' => 15,
'write-iterations' => 100,
);
const my $THREAD_POSTS => 3_000;
const my $SEEDED_POSTS => 8;
const my $CATEGORY_THREADS => 1_500;
const my $NOTIFICATIONS => 30;
const my $HALFWAY => 1_500;
const my $MILLISECONDS => 1_000;
const my $CLOCKS_PER_SECOND => 1_000_000;
const my $PERCENTILE => 0.95;
const my $SELECT_ONE_RUNS => 2_000;
const my $LISTEN_QUEUE => 16;
const my $CHUNK => 65_536;
const my @PATHS => qw(dbic function);
const my @MODES => qw(direct proxy);
const my @ROUND_TRIPS => qw(
begin_work commit rollback pg_savepoint pg_release pg_rollback_to
);
# The configuration benchmark explicitly loads this workload as a library.
# Other callers (including failure-injection drills using do) still run it.
our $LOAD_AS_LIBRARY;
exit main(@ARGV) if !$LOAD_AS_LIBRARY;
sub main (@arguments) {
my %option = %DEFAULT;
GetOptionsFromArray( \@arguments, \%option, 'delay-ms=f', 'json',
'read-iterations=i', 'warmup=i', 'write-iterations=i', 'help' )
or return _usage(2);
return _usage(0) if $option{help};
return _usage(2) if @arguments || !_valid_options( \%option );
my $admin_dsn = $ENV{GPFORUM_DATABASE_DSN}
// croak 'set GPFORUM_DATABASE_DSN to a database the user may CREATE in';
my $name = "gpforum_bench_sqlfn_$PROCESS_ID";
my $admin = _connect($admin_dsn);
my $proxy;
my $report;
$admin->do("CREATE DATABASE $name");
try {
local $SIG{TERM} =
sub { die "SQL function benchmark interrupted by TERM\n"; };
local $SIG{INT} =
sub { die "SQL function benchmark interrupted by INT\n"; };
( my $dsn = $admin_dsn ) =~ s/dbname=[^;]+/dbname=$name/msx;
_seed($dsn);
$proxy = _proxy( $dsn, $option{'delay-ms'} / $MILLISECONDS );
$report = _measure( $dsn, $proxy, \%option );
$report->{benchmark} = {
database_name => $name,
generated_at => strftime( '%Y-%m-%dT%H:%M:%SZ', gmtime ),
perl_version => "$PERL_VERSION",
architecture => $Config{archname},
postgres_version =>
scalar $admin->selectrow_array('SHOW server_version'),
read_iterations => $option{'read-iterations'},
write_iterations => $option{'write-iterations'},
warmup => $option{warmup},
scope =>
'service operations; excludes HTTP dispatch and template rendering',
workload =>
'small performance seed plus 3000 posts with bodies, 1500 indexed threads and 30 notifications',
};
}
catch ($error) {
_stop($proxy);
$admin->do("DROP DATABASE IF EXISTS $name WITH (FORCE)");
croak $error;
};
_stop($proxy);
$admin->do("DROP DATABASE IF EXISTS $name WITH (FORCE)");
$admin->disconnect;
print $option{json} ? encode_json($report) . "\n" : _text($report)
or croak 'cannot write the report';
return 0;
}
sub _valid_options ($option) {
return
$option->{'read-iterations'} >= 1
&& $option->{'write-iterations'} >= 1
&& $option->{warmup} >= 0
&& $option->{'delay-ms'} >= 0;
}
sub _usage ($status) {
print 'Usage: script/bench-sql-functions [--read-iterations N]'
. " [--write-iterations N] [--warmup N] [--delay-ms MS] [--json]\n"
or croak 'cannot write the usage';
return $status;
}
sub _connect ($dsn) {
return DBI->connect(
$dsn,
$ENV{GPFORUM_DATABASE_USER},
$ENV{GPFORUM_DATABASE_PASSWORD},
{ AutoCommit => 1, PrintError => 0, RaiseError => 1 },
);
}
# The plan tests' seed, and what t/integration/postgres-query-plan-depth.t
# adds -- 3,000 posts in the first thread and 1,500 threads in the first
# category -- the posts with bodies, so a page renders full posts.
sub _seed ($dsn) {
local $ENV{GPFORUM_DATABASE_DSN} = $dsn;
my $quiet = sub ($code) {
my $output = q{};
open my $sink, '>', \$output or croak "capture: $OS_ERROR";
my $status;
{
local *STDOUT = $sink;
$status = $code->();
}
close $sink or croak "capture: $OS_ERROR";
return $status;
};
croak 'migrations failed'
if $quiet->( sub { GPForum::Command::Migrate->new->run('--apply') } );
croak 'seed failed'
if $quiet->(
sub {
GPForum::Command::PerformanceSeed->new->run( '--profile', 'small' );
}
);
my $dbh = _connect($dsn);
my ( $thread, $category, $author ) = (
seed_id( thread => 1 ),
seed_id( category => 1 ),
seed_id( user => 2 ),
);
$dbh->do(
q{INSERT INTO posts (post_id, thread_id, author_user_id, position)}
. q{ SELECT gen_random_uuid(), ?, ?, n}
. q{ FROM generate_series(?::bigint, ?::bigint) AS n},
undef,
$thread,
$author,
$SEEDED_POSTS + 1,
$SEEDED_POSTS + $THREAD_POSTS
);
$dbh->do(
q{WITH b AS (INSERT INTO post_bodies (body_id, post_id, body_format,}
. q{ body_source, body_rendered_safe, source_hash)}
. q{ SELECT gen_random_uuid(), p.post_id, 'markdown',}
. q{ 'Reply number ' || p.position || ' with a little text.',}
. q{ '<p>Reply number ' || p.position || ' with a little text.</p>',}
. q{ md5(p.post_id::text) FROM posts p WHERE p.thread_id = ?}
. q{ AND p.current_body_id IS NULL RETURNING body_id, post_id)}
. q{ UPDATE posts p SET current_body_id = b.body_id FROM b}
. q{ WHERE b.post_id = p.post_id},
undef, $thread
);
$dbh->do(
q{INSERT INTO threads (thread_id, category_id, author_user_id, title,}
. q{ slug, last_activity_at) SELECT gen_random_uuid(), ?, ?,}
. q{ 'Depth ' || n, 'depth-' || n, timestamptz '2026-01-01'}
. q{ + n * interval '1 minute' FROM generate_series(1, ?) AS n},
undef, $category, $author, $CATEGORY_THREADS
);
my $index_schema = _schema($dsn);
my $indexer =
GPForum::Service::Search::Indexer->new( schema => $index_schema );
for my $id (
@{
$dbh->selectcol_arrayref(
q{SELECT thread_id FROM threads WHERE category_id = ? AND slug LIKE 'depth-%'},
undef, $category
)
}
)
{
$indexer->index_thread($id);
}
$index_schema->storage->disconnect;
$dbh->do('ANALYZE');
$dbh->disconnect;
return;
}
# A Unix socket proxy that holds each chunk for the delay before passing it on, in
# both directions: a database on another host, as far as round trips go.
# One process listens; one per connection forwards.
sub _proxy ( $dsn, $delay ) {
my $connection = _connect($dsn);
my ( $host, $port ) = @{$connection}{qw(pg_host pg_port)};
$connection->disconnect;
croak 'The SQL benchmark needs a host in the DSN: a socket directory'
. ' or a TCP host'
if !defined $host || !length $host;
# The proxy listens on a Unix socket either way; it reaches PostgreSQL
# the way the DSN does, so a TCP database is measured too.
my $upstream =
$host =~ m{\A /}msx
? { Peer => "$host/.s.PGSQL.$port" }
: { PeerHost => $host, PeerPort => $port };
my $directory =
tempdir( 'gpforum-sql-proxy-XXXXXX', DIR => '/tmp', CLEANUP => 1 );
my $socket = "$directory/.s.PGSQL.$port";
my $listener = IO::Socket::UNIX->new(
Listen => $LISTEN_QUEUE,
Local => $socket,
) or croak "proxy listen: $OS_ERROR";
my $pid = fork // croak "fork: $OS_ERROR";
if ( $pid == 0 ) {
# Only the measuring parent owns the temporary database. Proxy
# children must terminate directly instead of unwinding its cleanup.
local $SIG{TERM} = 'DEFAULT';
local $SIG{INT} = 'DEFAULT';
local $SIG{CHLD} = 'IGNORE';
setsid() >= 0 or _exit(1);
while ( my $client = $listener->accept ) {
my $child = fork // croak "fork: $OS_ERROR";
if ( $child == 0 ) {
close $listener or _exit(1);
_forward( $client, $upstream, $delay );
_exit(0);
}
close $client or croak "close: $OS_ERROR";
}
_exit(0);
}
close $listener or croak "close: $OS_ERROR";
( my $through = $dsn ) =~ s/(?: ; )? (?: host | port ) = [^;]*//gmsx;
$through .= ";host=$directory;port=$port";
return {
dsn => $through,
pid => $pid,
directory => $directory,
socket => $socket
};
}
sub _forward ( $client, $upstream, $delay ) {
my $server = (
exists $upstream->{Peer}
? IO::Socket::UNIX->new( %{$upstream} )
: IO::Socket::IP->new( %{$upstream} )
) or _exit(1);
my %peer = ( $client => $server, $server => $client );
my $select = IO::Select->new( $client, $server );
while ( my @ready = $select->can_read ) {
for my $from (@ready) {
my $chunk;
my $read = sysread $from, $chunk, $CHUNK;
return if !$read;
sleep $delay;
my $to = $peer{$from};
my $written = 0;
while ( $written < length $chunk ) {
my $sent = syswrite $to, $chunk, length($chunk) - $written,
$written;
return if !$sent;
$written += $sent;
}
}
}
return;
}
sub _stop ($proxy) {
return if !$proxy;
kill 'TERM', -$proxy->{pid};
waitpid $proxy->{pid}, 0;
unlink $proxy->{socket} or croak "remove proxy socket: $OS_ERROR";
rmdir $proxy->{directory} or croak "remove proxy directory: $OS_ERROR";
return;
}
sub _schema ($dsn) {
local $ENV{GPFORUM_DATABASE_DSN} = $dsn;
return GPForum::Test::PgSchema->connect_from_config(
GPForum::Config->from_environment );
}
# Every operation on each path, at the database and through the proxy,
# then the profile of each at the database.
sub _measure ( $dsn, $proxy, $option ) {
my %report = (
delay_ms => $option->{'delay-ms'},
round_trip_ms => {
direct => _select_one($dsn),
proxy => _select_one( $proxy->{dsn} ),
},
);
for my $mode (@MODES) {
my $schema = _schema( $mode eq 'direct' ? $dsn : $proxy->{dsn} );
my $counts = _counted( $schema->storage->dbh );
for my $path (@PATHS) {
my $ops = _operations( $schema, $path );
for my $op ( sort keys %{$ops} ) {
$report{operations}{$op}{$path}{$mode} =
_timed( $ops->{$op}, $counts, $option );
}
}
$schema->storage->disconnect;
}
my $schema = _schema($dsn);
for my $path (@PATHS) {
my $ops = _operations( $schema, $path );
for my $op ( sort keys %{$ops} ) {
$report{operations}{$op}{$path}{profile} =
_profiled( $ops->{$op}, $option );
}
}
$schema->storage->disconnect;
return \%report;
}
sub _select_one ($dsn) {
my $dbh = _connect($dsn);
my $one = $dbh->prepare('SELECT 1');
my @runs;
for ( 1 .. $SELECT_ONE_RUNS ) {
my $started = time;
$one->execute;
$one->fetchall_arrayref;
push @runs, time - $started;
}
$dbh->disconnect;
return _ms( _median(@runs) );
}
# The operations, each a code reference that runs one of them, built as
# Bootstrap::Forum builds the services. The dbic path is the one a schema
# without the function layer takes; the function path the one PostgreSQL
# takes now.
sub _operation_path ( $path, $context ) {
return ( functions => undef ) if $path eq 'dbic';
return ( functions => $context->{functions} ) if $context->{functions};
return ();
}
sub _operations ( $schema, $path, $context = {} ) {
my %perl = _operation_path( $path, $context );
# The services with one body per operation (ADR 0177) have no DBIx path:
# both paths measure their functions, the call layer built here, before
# the dbic path hides the function routing.
my %one = ( functions => $context->{functions}
// GPForum::Infrastructure::SqlFunction->for_schema($schema) );
my $thread = seed_id( thread => 1 );
my $member = GPForum::Service::Forum::Viewer->new(
member => 1,
user_id => seed_id( user => 2 ),
);
my $posts =
GPForum::Service::Forum::PostReader->new( schema => $schema, %one );
my $threads = GPForum::Service::Forum::ThreadDetailReader->new(
post_reader => $posts,
schema => $schema,
%one,
);
my $workflow = GPForum::Service::Forum::PostingWorkflow->new(
category_reader => GPForum::Service::Forum::CategoryReader->new(
schema => $schema,
%one
),
command_idempotency =>
GPForum::Service::Operations::CommandIdempotency->new(
schema => $schema
),
mention_store =>
GPForum::Service::Community::MentionStore->new( schema => $schema ),
post_composer => GPForum::Service::Forum::PostComposer->new,
post_store =>
GPForum::Service::Forum::PostStore->new( schema => $schema, %one ),
thread_composer => GPForum::Service::Forum::ThreadComposer->new,
thread_detail_reader => $threads,
thread_store =>
GPForum::Service::Forum::ThreadStore->new( schema => $schema, %one ),
);
my $ids = GPForum::Infrastructure::Id->new;
my ($halfway) =
$schema->storage->dbh->selectrow_array(
'SELECT post_id FROM posts WHERE thread_id = ? AND position = ?',
undef, $thread, $HALFWAY );
my $deep = encode_base64url("$HALFWAY|$halfway");
my $categories = GPForum::Service::Forum::CategoryReader->new(
schema => $schema,
%one
);
my $lists = GPForum::Service::Forum::ThreadReader->new(
schema => $schema,
%one
);
my $home = GPForum::Service::Forum::HomePageReader->new(
category_reader => $categories,
thread_reader => $lists
);
my $category = seed_id( category => 1 );
my $scope = $member->within( $category, seed_id( space => 1 ) );
my $sessions = GPForum::Service::Identity::SessionStore->new(
schema => $schema,
%perl,
);
my $session = $sessions->create_session(
{ id => $member->user_id },
{
request_address => '198.51.100.19',
user_agent => 'SQL function benchmark'
}
);
my $session_request = {
session_id => $session->{session}->get_column('session_id'),
session_token => $session->{session_token},
user_id => $member->user_id,
};
my $viewer_resolver = GPForum::Service::Forum::ViewerResolver->new(
schema => $schema,
%one,
);
my $participation = GPForum::Service::Moderation::SuspensionStore->new(
schema => $schema,
%one,
);
my $permission = GPForum::Service::Admin::PermissionGate->new(
schema => $schema,
%perl,
);
my $rate_limit =
GPForum::Service::Operations::RateLimiter::PostgreSQLStore->new(
schema => $schema,
%perl,
);
$schema->storage->dbh->do( 'DELETE FROM rate_limit_buckets WHERE scope = ?',
undef, 'sql_fn_bench' );
my $rate_request = {
scope => 'sql_fn_bench',
action => 'read',
actor_id => $member->user_id,
limit => 100_000_000,
};
my $notifications = GPForum::Service::Notification::Dispatcher->new(
schema => $schema,
%one,
readability => GPForum::Service::Forum::Readability->new(
schema => $schema,
viewer_resolver => $viewer_resolver,
%one
)
);
if ( !$schema->resultset('NotificationInbox')
->search( { recipient_user_id => $member->user_id } )
->count )
{
for my $index ( 1 .. $NOTIFICATIONS ) {
$notifications->create_notification(
{
recipient_user_id => $member->user_id,
notification_id => $ids->uuid,
source_type => 'thread',
source_id => $thread,
notification_type => 'reply',
payload => { index => $index }
}
);
}
}
my $searcher = GPForum::Service::Search::Searcher->new(
schema => $schema,
%one,
permission_engine => GPForum::Service::Search::PermissionEngine->new,
);
my $read_state =
GPForum::Service::Forum::ReadState->new( schema => $schema, %one );
my $read_marks = GPForum::Service::Forum::ReadWorkflow->new(
command_idempotency =>
GPForum::Service::Operations::CommandIdempotency->new(
schema => $schema
),
read_state => $read_state,
);
my $operations = {
%{
_write_operations(
$workflow, $read_marks,
$rate_limit, $rate_request,
$member, $thread,
$halfway, $category,
$ids, $context->{edit_counter}
)
},
search_ranked => {
kind => 'read',
run => sub {
my $result = $searcher->ranked_search( { viewer => $member },
'Depth', { limit => 20 } );
@{ $result->{results} }
or croak 'benchmark search found no documents';
return $result;
}
},
search_autocomplete => {
kind => 'read',
run => sub {
my $result = $searcher->autocomplete( { viewer => $member },
'Dep', { limit => 10 } );
@{$result} or croak 'benchmark autocomplete found no documents';
return $result;
}
},
category_index_member => {
kind => 'read',
run =>
sub { $categories->list_categories( { viewer => $member } ); },
},
category_threads_member => {
kind => 'read',
run => sub {
$lists->list_category_threads(
{
category_id => $category,
viewer_scope => $scope,
viewer_user_id => $member->user_id,
limit => 25,
}
);
},
},
latest_threads_member => {
kind => 'read',
run => sub {
$lists->list_public_threads(
{ viewer => $member, limit => 25 } );
},
},
home_page_member => {
kind => 'read',
run => sub { $home->home_page( { viewer => $member } ); },
},
session_validate => {
kind => 'read',
run => sub {
$sessions->validate_session($session_request)->{ok}
or croak 'benchmark session was refused';
},
},
viewer_resolve => {
kind => 'read',
run => sub {
$viewer_resolver->resolve( $member->user_id )->member
or croak 'benchmark viewer is not a member';
},
},
participation => {
kind => 'read',
run => sub {
$participation->can_participate( $member->user_id )->{ok}
or croak 'benchmark member cannot participate';
},
},
permission_check => {
kind => 'read',
run => sub {
$permission->allowed( $member->user_id,
{ resource_type => 'category', action => 'read' } );
},
},
notification_inbox => {
kind => 'read',
run => sub {
$notifications->list_page_for_user( $member->user_id,
{ limit => 25, viewer => $member } );
}
},
notification_badge => {
kind => 'read',
run => sub {
$notifications->unread_count_for_user( $member->user_id,
$member );
}
},
thread_page_anonymous => {
kind => 'read',
run => sub {
$threads->thread_page( { thread_id => $thread } )->{ok}
or croak 'no thread page';
},
},
thread_page_member_deep => {
kind => 'read',
run => sub {
$threads->thread_page(
{
after => $deep,
thread_id => $thread,
viewer => $member,
viewer_user_id => $member->user_id,
}
)->{ok} or croak 'no thread page';
},
},
thread_page_member => {
kind => 'read',
run => sub {
$threads->thread_page(
{
thread_id => $thread,
viewer => $member,
viewer_user_id => $member->user_id,
}
)->{ok} or croak 'no thread page';
},
},
};
return _with_path( $operations, $path );
}
sub _write_operations (
$workflow, $read_marks, $rate_limit, $rate_request,
$member, $thread, $halfway, $category,
$ids, $edit_counter = undef
)
{
my $marked_position =
$read_marks->read_state->state_for_thread( $member->user_id, $thread )
->{last_read_position};
my $edit_number = 0;
$edit_counter //= \$edit_number;
return {
mark_read => {
kind => 'write',
run => sub {
my $result = $read_marks->mark_thread_read(
{
command_id => $ids->uuid,
user_id => $member->user_id,
thread_id => $thread,
last_read_position => ++$marked_position
}
);
$result->{ok} or croak 'benchmark mark read failed';
}
},
post_edit => {
kind => 'write',
run => sub {
my $result = $workflow->edit_post(
{
author_user_id => $member->user_id,
post_id => $halfway,
command_id => $ids->uuid,
body_source => 'Bench edit ' . ++${$edit_counter},
viewer => $member
}
);
$result->{ok} or croak 'benchmark post edit failed';
return $result;
}
},
rate_limit => {
kind => 'write',
run => sub {
$rate_limit->check($rate_request)->{ok}
or croak 'benchmark rate limiter refused';
},
},
new_thread => {
kind => 'write',
run => sub {
my $result = $workflow->create_thread(
{
author_user_id => $member->user_id,
body_source => 'An opening post from the bench.',
category_id => $category,
command_id => $ids->uuid,
title => 'A thread from the bench.',
viewer => $member
}
);
croak "new thread: $result->{status}" if !$result->{ok};
}
},
reply => {
kind => 'write',
run => sub {
my $result = $workflow->create_reply(
{
author_user_id => $member->user_id,
body_source => 'A reply from the bench.',
command_id => $ids->uuid,
thread_id => $thread,
viewer => $member,
}
);
croak "reply: $result->{status}" if !$result->{ok};
},
},
};
}
sub _with_path ( $operations, $path ) {
if ( $path eq 'dbic' ) {
for my $operation ( values %{$operations} ) {
my $run = $operation->{run};
$operation->{run} = sub {
## no critic (TestingAndDebugging::ProhibitNoWarnings) -- local replacement makes all nested readers use the legacy benchmark path
no warnings 'redefine';
local *GPForum::Infrastructure::SqlFunction::for_schema =
sub { return undef; };
return $run->();
};
}
}
return $operations;
}
# The statements and round trips a handle sends, through DBI's callbacks.
sub _counted ($dbh) {
my %count;
$dbh->{Callbacks} = {
ChildCallbacks => {
execute => sub { $count{statements}++; return; },
},
do => sub { $count{statements}++; return; },
map {
( $_ => sub { $count{transaction}++; return; } )
} @ROUND_TRIPS,
};
return \%count;
}
sub _iterations ( $operation, $option ) {
return $operation->{kind} eq 'write'
? $option->{'write-iterations'}
: $option->{'read-iterations'};
}
sub _timed ( $operation, $counts, $option ) {
for ( 1 .. $option->{warmup} ) {
$operation->{run}->();
}
my $iterations = _iterations( $operation, $option );
%{$counts} = ();
my @runs;
my $processor = clock();
for ( 1 .. $iterations ) {
my $started = time;
$operation->{run}->();
push @runs, time - $started;
}
my $processed = ( clock() - $processor ) / $CLOCKS_PER_SECOND;
my $statements = ( $counts->{statements} // 0 ) / $iterations;
return {
cpu_ms => _ms( $processed / $iterations ),
median_ms => _ms( _median(@runs) ),
p95_ms => _ms( _percentile( \@runs, $PERCENTILE ) ),
round_trips => $statements +
( $counts->{transaction} // 0 ) / $iterations,
statements => $statements,
};
}
# Exclusive time charged to DBIx::Class, to DBI and to the rest, per call,
# with every method of both wrapped while the operation runs.
sub _profiled ( $operation, $option ) {
my $profile = GPForum::Benchmark::BucketProfile->new->wrap;
my $iterations = _iterations( $operation, $option );
for ( 1 .. $option->{warmup} ) {
$operation->{run}->();
}
my %total;
for ( 1 .. $iterations ) {
my $spent = $profile->measure( $operation->{run} );
for my $bucket ( keys %{$spent} ) {
$total{$bucket} += $spent->{$bucket};
}
}
$profile->unwrap;
return {
map { ( "${_}_ms" => _ms( $total{$_} / $iterations ) ) }
keys %total
};
}
sub _median (@values) {
return _percentile( \@values, 1 / 2 );
}
sub _percentile ( $values, $share ) {
my @sorted = sort { $a <=> $b } @{$values};
return 0 if !@sorted;
return $sorted[ int( $share * $#sorted + 1 / 2 ) ];
}
sub _ms ($seconds) {
return 0 + sprintf '%.3f', $seconds * $MILLISECONDS;
}
sub _text ($report) {
my $text = sprintf 'SELECT 1: %.3f ms at the database, %.3f ms through'
. " the proxy (%.2f ms each way)\n\n",
@{ $report->{round_trip_ms} }{qw(direct proxy)}, $report->{delay_ms};
$text .= sprintf "%-22s %-9s %8s %8s %8s %8s %8s %8s %8s %6s %6s\n",
qw(operation path cpu dbic dbi med p95 med_px p95_px stmts rtrips);
for my $op ( sort keys %{ $report->{operations} } ) {
for my $path (@PATHS) {
my $row = $report->{operations}{$op}{$path};
$text .= sprintf
"%-22s %-9s %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f %8.3f %6.1f %6.1f\n",
$op, $path, $row->{direct}{cpu_ms},
$row->{profile}{dbic_ms} // 0,
$row->{profile}{dbi_ms} // 0,
@{ $row->{direct} }{qw(median_ms p95_ms)},
@{ $row->{proxy} }{qw(median_ms p95_ms)},
@{ $row->{direct} }{qw(statements round_trips)};
}
}
return $text;
}
1;