package Benchmark::DKbench;

use strict;
use warnings;

use Digest;
use Digest::MD5 qw(md5_hex);
use Encode;
use File::Spec::Functions;
use List::Util qw(min max sum);
use Time::HiRes;
use Time::Piece;

use Astro::Coord::Constellations 'constellation_for_eq';
use Astro::Coord::Precession 'precess';
use Crypt::JWT qw(encode_jwt decode_jwt);
use CSS::Inliner;
use DateTime;
use DBI;
use File::ShareDir 'dist_dir';
use HTML::FormatText;
use HTML::TreeBuilder;
use Imager;
use Imager::Filter::Mandelbrot;
use Image::PHash;
use JSON::XS;
use Math::DCT ':all';
use Math::MatrixReal;
use MCE::Loop;
use SQL::Abstract::Classic;
use SQL::Inserter;
use System::Info;
use Text::Fuzzy;
use Text::Levenshtein::Damerau::XS;

use Exporter 'import';
our @EXPORT = qw(system_identity suite_run calc_scalability);
our $datadir = dist_dir("Benchmark-DKbench");

our $VERSION = '2.0_005';

=head1 NAME

Benchmark::DKbench - Perl CPU Benchmark

=head1 SYNOPSIS

 # Run the suite single-threaded and then multi-threaded on multi-core systems
 # Will print scores for the two runs and multi/single thread scalability
 dkbench

 # A dual-thread run with times instead of scores
 dkbench -j 2 -t

 # If BioPerl is installed, enable the BioPerl benchmarks by downloading Genbank data
 dkbench --setup

 # Force install the reference versions of all CPAN modules
 setup_dkbench --force

=head1 DESCRIPTION

A Perl benchmark suite for general compute, created to evaluate the comparative
performance of systems when running computationally intensive Perl (both pure Perl
and C/XS) workloads. It is a good overall indicator for real world generic CPU
performance. It runs single and multi-threaded (easily scaling to hundreds of CPUs)
and can be fully customized to run the benchmarks that better suit your own scenario.

=head1 INSTALLATION

The only non-CPAN software required to install/run the suite is a build environment
(i.e. C compiler, make etc.) for the C/XS modules. On some well known Linux package
managers you can do:

 # Debian/Ubuntu etc
 sudo apt install build-essential

 # CentOS/Redhat
 sudo yum install gcc gcc-c++ kernel-devel make

After that, you can use L<App::cpanminus> to install the benchmark suite:

 cpanm -n Benchmark::DKbench

See the C<setup_dkbench> script below for more on the installation of a couple of
optional benchmarks and standardizing your benchmarking environment.

=head1 SCRIPTS

You should only ever need the main script C<dkbench> for the benchmark suite, and,
perhaps C<setup_dkbench> can help with setup or standardizing/normalizing your
benchmarking environment.

=head2 C<dkbench>

The main script that runs the DKbench benchmark suite. If L<BioPerl> is installed,
you may want to start with C<dkbench --setup>. But beyond that, there are many
options to control number of threads, iterations, which benchmarks to run etc:

 dkbench [options]

 Options:
 --threads <i>, -j <i> : Number of benchmark threads (default is 1).
 --multi,       -m     : Multi-threaded using all your CPU cores/threads.
 --iter <i>,    -i <i> : Number of suite iterations (with min/max/avg at the end).
 --include <regex>     : Run only benchmarks that match regex.
 --exclude <regex>     : Do not run benchmarks that match regex.
 --time,        -t     : Report time (sec) instead of score.
 --quick,       -q     : Quick benchmark run (implies -t).
 --no_mce              : Do not run under MCE::Loop (implies -j 1).
 --skip_bio            : Skip BioPerl benchmarks.
 --skip_timep          : Skip Time::Piece benchmark (see benchmark details).
 --skip_prove          : Skip Moose prove benchmark.
 --bio_codons          : Run optional BioPerl Codons benchmark (does not scale well).
 --sleep <i>           : Sleep for <i> secs after each benchmark.
 --setup               : Download the Genbank data to enable the BioPerl tests.
 --datapath <path>     : Override the path where the expected benchmark data is found.
 --ver <num>           : Skip benchmarks added after the specified version.

The default run (no options) will run all the benchmarks both single-threaded and
multi-threaded (using all detected CPU cores/hyperthreads) and show you scores and
multi vs single threaded scalability.

The scores are such that a reference CPU (Intel Xeon Platinum 8481C - Sapphire Rapids)
would get 1000 on a single core benchmark run using the default software configuration
(Linux/Perl 5.36.0/ref CPAN modules).

The multi-thread scalability should approach 100% if each thread runs on a full core
(i.e. no SMT), and the core can maintain the clock speed it had on the single-thread
runs. Note that the overall scalability is an average of the benchmarks that drops
non-scaling outliers (over 2*stdev less than the mean).

The suite will report a Pass/Fail per benchmark. A failure may be caused if you have
different CPAN module version installed - this is normal, and you will be warned.

The suite uses L<MCE::Loop> to run on the desired number of parallel threads, although
there is an option to disable it, which forces a single-thread run.

=head2 C<setup_dkbench>

Simple installer to check/get the reference versions of CPAN modules and download
the Genbank data file required for the BioPerl benchmarks of the DKbench suite.

It assumes that you have some software already installed (see INSTALLATION above),
try C<setup_dkbench --help> will give you more details.

 setup_dkbench [--force --sudo --test --data=s --help]

 Options:
 --sudo   : Will use sudo for cpanm calls.
 --force  : Will install reference CPAN module versions and re-download the genbank data.
 --test   : Will run the test suites for the CPAN module (default behaviour is to skip).
 --data=s : Data dir path to copy files from. Should not need if you installed DKbench.
 --help   : Print this help text and exit.

Running it without any options will fetch the data for the BioPerl tests (similar to
C<dkbench --setup>) and use C<cpanm> to install any missing libraries.

Using it with C<--force> will install the reference CPAN module versions, including
BioPerl which is not a requirement for DKbench, but enables the BioPerl benchmarks.

The reference CPAN versions are suggested if you want a fair comparison between
systems and also for the benchmark Pass/Fail results to be reliable.

=head1 BENCHMARKS

The suite consists of 19 benchmarks. With a successful installation of the DKbench
package, 18 will run by default, although the C<BioPerl Monomers> requires BioPerl
to be installed and Genbank data to be downloaded (C<dkbench --setup> can do the
latter).

On MacOS only, the C<Time::Piece> benchmark will be skipped, unless you try a single
thread run without MCE (C<--skip_mce>).

=over 4

=item * C<Astro> : Calculates precession between random epochs and finds the
constellation for random equatorial coordinates using L<Astro::Coord::Precession>
and L<Astro::Coord::Constellations> respectively.

=item * C<BioPerl Codons> : Counts codons on a sample bacterial sequence. Requires
L<BioPerl> to be installed.
This test does not scale well on multiple threads, so is disabled by default (use
C<--bio_codons>) option. Requires data fetched using the C<--setup> option.

=item * C<BioPerl Monomers> : Counts monomers on 500 sample bacterial sequences using
L<BioPerl> (which needs to be installed). Requires data fetched using the C<--setup>
option.

=item * C<CSS::Inliner> : Inlines CSS on 2 sample wiki pages using L<CSS::Inliner>.

=item * C<Crypt::JWT> : Creates large JSON Web Tokens with RSA and EC crypto keys
using L<Crypt::JWT>.

=item * C<DateTime> : Creates and manipulates L<DateTime> objects.

=item * C<DBI/SQL> : Creates a mock L<DBI> connection (using L<DBD::Mock>) and passes
it insert/select statements using L<SQL::Inserter> and L<SQL::Abstract::Classic>.
The latter is quite slow at creating the statements, but it is widely used.

=item * C<Digest> : Creates MD5, SH1 and SHA-512 digests of a large string.

=item * C<Encode> : Encodes/decodes large strings from/to UTF-8/16, cp-1252.

=item * C<HTML::FormatText> : Converts HTML to text for 2 sample wiki pages using
L<HTML::FormatText>.

=item * C<Imager> : Loads a sample image and performs edits/manipulations with
L<Imager>, including filters like gaussian, unsharp mask, mandelbrot.

=item * C<JSON::XS> : Encodes/decodes random data structures to/from JSON using
L<JSON::XS>.

=item * C<Math::DCT> : Does 8x8, 18x18 and 32x32 DCT transforms with L<Math::DCT>.

=item * C<Math::MatrixReal> : Performs various manipulations on L<Math::MatrixReal>
matrices.

=item * C<Moose> : Creates L<Moose> objects.

=item * C<Moose prove> : Runs 110 tests from the Moose 2.2201 test suite. The least
CPU-intensive test (which is why there is the option C<--no_prove> to disable it),
most of the time will be spent loading the interpreter and the Moose module for each
test, which is behaviour representative of how a Perl test suite runs by default.

=item * C<Primes> : Calculates all primes up to 7.5 million. Small number with
repeat was chosen to keep low memory (this is a pure Perl function no Math libraries).

=item * C<Regex/Subst> : Concatenates 3 wiki pages into a byte string then matches
3 typical regexes (for names, emails, URIs), replaces html tags with their contents
(starting with the innermost) and does calls subst a few times.

=item * C<Regex/Subst utf8> : Exactly the same as C<Regex/Subst>, but reads into
a utf8 string. Perl version can make a big difference, as Unicode behaviour has
changed (old Perl versions are faster but less strict in general).

=item * C<Text::Fuzzy> : The edit distance for strings of various lengths (up to 1000)
are calculated using L<Text::Fuzzy> and L<Text::Levenshtein::Damerau::XS> (the latter
is faster for Levenshtein-Damerau over long strings.

=item * C<Time::Piece> : Creates and manipulates/converts Time::Piece objects. It
is disabled by default on MacOS (unless C<--no_mce> is specified), as it runs
extremely slow when forked on this platform. In general you may want to skip this
benchmark (C<--skip_timep>) if you are comparing different OS platforms.

=back

=head1 EXPORTED FUNCTIONS

You will normally not use the Benchmark::DKbench module itself, but here are the
exported functions that the C<dkbench> script uses for reference:

=head2 C<system_identity>

 my $cores = system_identity();

Prints out software/hardware configuration and returns then number of cores detected.

=head2 C<suite_run>

 my %stats = suite_run(\%options);

Runs the benchmark suite given the C<%options> and prints results. Returns a hash
with run stats.

=head2 C<calc_scalability>

 calc_scalability(\%options, \%stat_single, \%stat_multi);

Given the C<%stat_single> results of a single-threaded C<suite_run> and C<%stat_multi>
results of a multi-threaded run, will calculate and print the multi-thread scalability.

=head1 NOTES

The benchmark suite was created to compare the performance of various cloud offerings.
You can see the L<original perl blog post|http://blogs.perl.org/users/dimitrios_kechagias/2022/03/cloud-provider-performance-comparison-gcp-aws-azure-perl.html>
as well as the L<2023 follow-up|https://dev.to/dkechag/cloud-vm-performance-value-comparison-2023-perl-more-1kpp>.

The benchmarks for the first version were more tuned to what I would expect to run
on the servers I was testing, to choose the optimal types for the company I was
working for. The second version has expanded a bit over that and is friendlier to
use.

=head1 AUTHOR

Dimitrios Kechagias, C<< <dkechag at cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests either on L<GitHub|https://github.com/dkechag/Benchmark-DKbench> (preferred), or on RT (via the email
C<bug-Benchmark-DKbench at rt.cpan.org> or L<web interface|https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Benchmark-DKbench>).

I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

=head1 GIT

L<https://github.com/dkechag/Benchmark-DKbench>

=head1 LICENSE AND COPYRIGHT

This software is copyright (c) 2021-2023 by Dimitrios Kechagias.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

sub benchmark_list {
    return {               # idx : 0 = result, 1 = ref time, 2 = func, 3 = quick test, 4 = normal test, 5 = ver
        'Astro'            => ['e71c7ae08f16fe26aea7cfdb72785873', 5.674, \&bench_astro, 20000, 80000],
        'BioPerl Codons'   => ['97c443c099886ca60e99f7ab9df689b5', 8.752, \&bench_bioperl_codons, 3, 5, 1],
        'BioPerl Monomers' => ['d29ed0a5c205c803c112be1338d1f060', 5.241, \&bench_bioperl_mono, 6, 20],
        'Crypt::JWT'       => ['d41d8cd98f00b204e9800998ecf8427e', 6.451, \&bench_jwt, 250, 900],
        'CSS::Inliner'     => ['82c1b6de9ca0500a48f8a8df0998df3c', 4.603, \&bench_css, 2, 5],
        'DBI/SQL'          => ['2b8252daad9568a5b39038c696df4be3', 5.700, \&bench_dbi, 5000, 15000, 2.1],
        'DateTime'         => ['b08d2eeb994083b7422f6c9d86fed2c6', 6.198, \&bench_datetime, 5000, 15000],
        'Digest'           => ['4b69f6cf0f53cbf6c3444f2f767dd21d', 4.513, \&bench_digest, 50, 250],
        'Encode'           => ['PASS 1025',                        5.725, \&bench_encode, 40, 120],
        'HTML::FormatText' => ['8c2589f0a5276252805e11301fc2ab56', 4.756, \&bench_formattext, 4, 10],
        'Imager'           => ['8829cb3703e884054eb025496f336c63', 6.792, \&bench_imager, 4, 16],
        'JSON::XS'         => ['PASS',                             5.388, \&bench_json, 600, 2200],
        'Math::DCT'        => ['766e3bfd7a2276f452bb3d1bd21939bc', 7.147, \&bench_dct, 25000, 100_000],
        'Math::MatrixReal' => ['4606231b1309fb21ae1223fa0043fd76', 4.293, \&bench_matrixreal, 200, 650],
        'Moose'            => ['d1cb92c513f6378506dfa11f694cffac', 4.968, \&bench_moose, 10_000, 30_000],
        'Moose prove'      => ['PASS',                             7.974, \&bench_moose_prv, 0.5, 1],
        'Primes'           => ['4266f70a7a9efb3484cf5d98eba32244', 3.680, \&bench_primes_m, 2, 5],
        'Regex/Subst'      => ['30ce365b25f3d597578b3bdb14aa3f57', 4.652, \&bench_regex_asc, 8, 24],
        'Regex/Subst utf8' => ['857eb4e63a4d174ca4a16fe678f7626f', 5.703, \&bench_regex_utf8, 3, 10],
        'Text::Fuzzy'      => ['a71709068d1051ec5c2e05df82638dbe', 5.816, \&bench_textfuzzy, 12, 42, 2.1],
        'Time::Piece'      => ['2d4b149fe7f873a27109fc376d69211b', 5.907, \&bench_timepiece, 75_000, 275_000],
    };
}

sub system_identity {
    my $info  = System::Info->sysinfo_hash;
    my $model = $info->{cpu};
    my $cores = $info->{cpu_cores} || 1;
    my $arch  = $info->{cpu_type} || '';
    my $osn   = $info->{distro} || $info->{os} || $^O;
    $arch = " ($arch)" if $arch;
    if ($^O =~ /darwin/ && $model =~ /^Mac|nknown/) {
        my $brand = `sysctl -a |grep brand`;
        if ($brand =~ /brand_string: (.*)/) {
            $model = $1;
        }
    }
    print "------------ Software ------------\nDKbench v$VERSION\n";
    print "Perl $^V\n";
    print "OS: $osn\n------------ Hardware ------------\n";
    print "CPU type: $model$arch\n";
    print "Cores: $cores\n".("-"x34)."\n";

    return $cores;
};

sub suite_run {
    my $opt = shift;
    $datadir = $opt->{datapath} if $opt->{datapath};
    $opt->{threads} //= 1;
    $opt->{repeat} //= 1;
    $opt->{f} = $opt->{time} ? '%.3f' : '%5.0f';
    my %stats = (threads => $opt->{threads});

    MCE::Loop::init {
        max_workers => $opt->{threads},
        chunk_size  => 1,
    } unless $opt->{no_mce};

    foreach (1..$opt->{iter}) {
        print "Iteration $_ of $opt->{iter}...\n" if $opt->{iter} > 1;
        run_iteration($opt, \%stats);
    }

    total_stats($opt, \%stats) if $opt->{iter} > 1;

    return %stats;
}

sub calc_scalability {
    my ($opt, $stats1, $stats2) = @_;
    my $benchmarks = benchmark_list();
    my $threads = $stats2->{threads}/$stats1->{threads};
    my $display = $opt->{time} ? 'times' : 'scores';
    $opt->{f} = $opt->{time} ? '%.3f' : '%5.0f';
    my (@perf, @scal);
    print "Multi thread Scalability:\n".pad_to("Benchmark",24).pad_to("Multi perf xSingle",24).pad_to("Multi scalability %",24);
    print "\n";
    foreach my $bench (sort keys %$benchmarks) {
        next unless $stats1->{$bench}->{times} && $stats2->{$bench}->{times};
        my @res1 = min_max_avg($stats1->{$bench}->{times});
        my @res2 = min_max_avg($stats2->{$bench}->{times});
        push @perf, $res1[2]/$res2[2]*$threads if $res2[2];
        push @scal, $res1[2]/$res2[2]*100 if $res2[2];
        print pad_to("$bench:",24).pad_to(sprintf("%.2f",$perf[-1]),24).pad_to(sprintf("%2.0f",$scal[-1]),24)."\n";
    }
    print (("-"x34)."\n");
    my ($avg1) = min_max_avg($stats1->{total}->{$display});
    my ($avg2) = min_max_avg($stats2->{total}->{$display});
    print "DKbench summary:\n";
    print pad_to("Single:").sprintf($opt->{f}, $avg1)."\n";
    print pad_to("Multi:").sprintf($opt->{f}, $avg2)."\n";
    my @newperf = Benchmark::DKbench::drop_outliers(\@perf, -1);
    my @newscal = Benchmark::DKbench::drop_outliers(\@scal, -1);
    @perf = min_max_avg(\@newperf);
    @scal = min_max_avg(\@newscal);
    print pad_to("Multi/Single perf:").sprintf("%.2fx\t(%.2f - %.2f)", $perf[2], $perf[0], $perf[1])."\n";
    print pad_to("Multi scalability:").sprintf("%2.1f%% \t(%.0f%% - %.0f%%)", $scal[2], $scal[0], $scal[1])."\n";
}

sub run_iteration {
    my ($opt, $stats) = @_;
    my $benchmarks = benchmark_list();
    my $title = $opt->{time} ? 'Time (sec)' : 'Score';
    print pad_to("Benchmark").pad_to($title);
    print "Pass/Fail" unless $opt->{time};
    print "\n";
    my ($total_score, $total_time, $i) = (0, 0, 0);
    foreach my $bench (sort keys %$benchmarks) {
        next if $opt->{skip_bio} && $bench =~ /Monomers/;
        next if $opt->{skip_prove} && $bench =~ /prove/;
        next if !$opt->{bio_codons} && $bench =~ /Codons/;
        next if $opt->{skip_timep} && $bench =~ /Time::Piece/;
        next if $opt->{ver} && $benchmarks->{$bench}->[5] && $opt->{ver} < $benchmarks->{$bench}->[5];
        next if $opt->{exclude} && $bench =~ /$opt->{exclude}/;
        next if $opt->{include} && $bench !~ /$opt->{include}/;
        if ($bench =~ /Bio/) {
            require Bio::SeqIO;
            require Bio::Tools::SeqStats;
         }
        my ($time, $res) = mce_bench_run($opt, $benchmarks->{$bench});
        my $score = int(1000*$opt->{threads}*$benchmarks->{$bench}->[1]/($time || 1)+0.5);
        $total_score += $score;
        $total_time += $time;
        $i++;
        push @{$stats->{$bench}->{times}}, $time;
        push @{$stats->{$bench}->{scores}}, $score;
        my $d = $stats->{$bench}->{$opt->{time} ? 'times' : 'scores'}->[-1];
        $stats->{$bench}->{fail}++ if $res ne 'Pass';
        print pad_to("$bench:").pad_to(sprintf($opt->{f}, $d));
        print "$res" unless $opt->{time};
        print "\n";
        sleep $opt->{sleep} if $opt->{sleep};
    }
    die "No tests to run\n" unless $i;
    my $s = int($total_score/$i+0.5);
    print pad_to("Overall $title: ").sprintf($opt->{f}."\n", $opt->{time} ? $total_time : $s);
    push @{$stats->{total}->{times}}, $total_time;
    push @{$stats->{total}->{scores}}, $s;
}

sub mce_bench_run {
    my $opt       = shift;
    my $benchmark = shift;
    $benchmark->[3] = $benchmark->[4] unless $opt->{quick};
    return bench_run($benchmark) if $opt->{no_mce};

    my @stats = mce_loop {
        my ($mce, $chunk_ref, $chunk_id) = @_;
        for (@{$chunk_ref}) {
            my ($time, $res) = bench_run($benchmark);
            MCE->gather([$time, $res]);
        }
    }
    (1 .. $opt->{threads} * $opt->{repeat});

    my ($res, $time) = ('Pass', 0);
    foreach (@stats) {
        $time += $_->[0];
        $res = $_->[1] if $_->[1] ne 'Pass';
    }

    return $time/($opt->{threads}*$opt->{repeat} || 1), $res;
}

sub bench_run {
    my ($benchmark, $srand) = @_;
    $srand //= 1;
    srand($srand); # For repeatability
    my $t0   = Time::HiRes::time();
    my $out  = $benchmark->[2]->($benchmark->[3]);
    my $time = sprintf("%.3f", Time::HiRes::time()-$t0);
    my $r    = $out eq $benchmark->[0] ? 'Pass' : "Fail ($out)";
    return $time, $r;
}

sub bench_astro {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $precessed = precess([rand(24), rand(180)-90], rand(200)+1900, rand(200)+1900)
        for (1..$iter*10);
    my $constellation_abbrev;
    $d->add(constellation_for_eq(rand(24), rand(180)-90, rand(200)+1900))
        for (1..$iter);
    return $d->hexdigest;
}

sub bench_bioperl_codons {
    my $skip = shift;
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $file = catfile($datadir, "gbbct5.seq");
    foreach (1..$iter) {
        my $in = Bio::SeqIO->new(-file => $file, -format => "genbank");
        $in->next_seq for (1..$skip);
        my $seq = $in->next_seq;
        my $seq_stats = Bio::Tools::SeqStats->new($seq);
        my $codon_ref = $seq_stats->count_codons();
        $d->add($_, $codon_ref->{$_}) for sort keys %$codon_ref;
    }
    return $d->hexdigest;
}

sub bench_bioperl_mono {
    my $iter = shift;
    my $file = catfile($datadir, "gbbct5.seq");
    my $in   = Bio::SeqIO->new(-file => $file, -format => "genbank");
    my $d    = Digest->new("MD5");
    my $builder = $in->sequence_builder();
    $builder->want_none();
    $builder->add_wanted_slot('display_id','seq');
    for (1..$iter) {
        my $seq = $in->next_seq;
        my $seq_stats = Bio::Tools::SeqStats->new($seq);
        my $weight = $seq_stats->get_mol_wt();
        $d->add(int($weight->[0]));
        my $monomer_ref = $seq_stats->count_monomers();
        $d->add($_, $monomer_ref->{$_}) for sort keys %$monomer_ref;
    }
    return $d->hexdigest;
}

sub bench_css {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $file;
    my $html;
    for (1..$iter) {
        my $inliner = new CSS::Inliner();
        my $i = $_ % 2 + 1;
        $file = catfile($datadir, "wiki$i.html");
        $inliner->read_file({ filename => $file });
        $html = $inliner->inlinify();
        $d->add(Encode::encode_utf8($html));
    }
    return $d->hexdigest;
}

sub bench_datetime {
    my $iter = shift;
    my @tz   = map {DateTime::TimeZone->new( name => $_ )} qw(UTC Europe/London America/New_York);
    my $d    = Digest->new("MD5");
    my $str;

    for (1..$iter) {
        my $dt  = DateTime->now();
        my $dt1 = DateTime->from_epoch(
            epoch => 946684800 + rand(100000000),
        );
        my $dt2 = DateTime->from_epoch(
            epoch => 946684800 + rand(100000000),
        );
        $str = $dt2->strftime('%FT%T')."\n";
        $d->add($str);
        eval {$dt2->set_time_zone($tz[int(rand(3))])};
        my $dur = $dt2->subtract_datetime($dt1);
        eval {$dt2->add_duration($dur)};
        eval {$dt2->subtract(days => int(rand(1000)+1))};
        $dt->week;
        $dt->epoch;
        $d->add($dt2->strftime('%FT%T'));
        eval {$dt2->set( year => int(rand(2030)))};
        $d->add($dt2->ymd('/'));
    }
    return $d->hexdigest;
}

sub bench_dbi {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $dbh  = DBI->connect( 'DBI:Mock:', '', '' );
    my ($data, $cols) = _db_data();

    foreach (1..$iter) {
        my $inserter = SQL::Inserter->new(
            dbh    => $dbh,
            table  => 'table',
            cols   => $cols,
            buffer => 2
        );
        $inserter->insert($data->[int(rand(20))]) for 1..2;
        $d->add($dbh->last_insert_id);
        my $sql = SQL::Abstract::Classic->new();
        my ($stmt, @bind) = $sql->insert('table', $data->[int(rand(20))]);
        $d->add($dbh->quote($stmt));
        ($stmt, @bind) = $sql->select('table', $cols->[int(rand(20))], [map {_rand_where()} 1..int(rand(3)+1)]);
        $d->add($dbh->quote($stmt._random_str(5)));
        my $dbh2 = DBI->connect( 'DBI:Mock:', '', '' );
    }
    return $d->hexdigest;
}

sub bench_dct {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    $d->add(bench_dct_sz(@$_)) foreach [$iter, 32], [$iter, 18], [$iter*8,8];

    return $d->hexdigest;
}

sub bench_dct_sz {
    my $iter = shift;
    my $sz   = shift;
    my $d    = Digest->new("MD5");
    my @arrays;
    push @arrays, [map { rand(256) } ( 1..$sz*$sz )] foreach 1..10;
    foreach (1..$iter) {
        my $dct = dct2d($arrays[$iter % 10], $sz);
        $d->add($dct->[0]) if $_ % 10 == 1;
    }
    return $d->hexdigest;
}

sub bench_digest {
    my $iter = shift;
    my $str  = _read_wiki_files();
    my $d    = Digest->new("MD5");
    my $hex;
    foreach (1..$iter) {
        my $d2 = Digest->new("MD5");
        $d2->add($str);
        $hex = $d2->hexdigest;
        $d->add($hex);
        $d2 = Digest->new("SHA-512");
        $d2->add($str);
        $hex = $d2->hexdigest;
        $d->add($hex);
        $d2 = Digest->new("SHA-1");
        $d2->add($str);
        $hex = $d2->hexdigest;
        $d->add($hex);
    }
    return $d->hexdigest;
}

sub bench_encode {
    my $iter    = shift;
    my $str     = _read_wiki_files('utf8');
    my $UTF8    = Encode::find_encoding('UTF-8');
    my $UTF16   = Encode::find_encoding('UTF-16');
    our $cp1252 = Encode::find_encoding('cp-1252');
    my $res   = 'PASS';
    my $unenc = 0;

    foreach (1..$iter) {
        my $bytes = encode_utf8($str);
        $res = 'Fail' unless length($bytes) > length($str);
        my $cp = decode_utf8($bytes);
        my $enc = rand(1) > 0.25 ? $UTF8 : $UTF16;
        $bytes = $enc->encode($cp);
        $cp = $enc->decode($bytes);
        $res = 'Fail' unless $cp eq $str;
        my $str2 = $cp1252->encode($cp);
        $enc->encode($cp1252->decode($str2));
        $unenc = () = $str2 =~ /\?/g; # Non-encodable
    }
    return "$res $unenc";
}

sub bench_imager {
    my $iter = shift;
    my $d    = Digest->new("MD5");

    my $data;
    open (my $fh, '<:raw', catfile($datadir,'M31.bmp')) or die $!;
    read($fh, $data, -s $fh);
    close($fh);

    foreach (1..$iter) {
        my $img = Imager->new(data=>$data, type=>'bmp') or die Imager->errstr();
        my $thumb = $img->scale(scalefactor=>.3);
        my $newimg = $img->scale(scalefactor=>1.15);
        $newimg->filter(type=>'autolevels');
        $newimg->filter(type=>"gaussian", stddev=>0.5);
        $newimg->paste(left=>40,top=>20,img=>$thumb);
        $newimg->rubthrough(src=>$thumb,tx=>30, ty=>50);
        $newimg->compose(src => $thumb, tx => 30, ty => 20, combine => 'color');
        $newimg->flip(dir=>"h");
        $newimg->flip(dir=>"vh");
        $d->add(scalar(Image::PHash->new($newimg)->pHash));
        $newimg = $img->crop(left=>50, right=>100, top=>10, bottom=>100);
        $newimg = $img->crop(left=>50, top=>10, width=>50, height=>90);
        $newimg = $img->copy();
        $newimg->filter(type=>"unsharpmask", stddev=>1, scale=>0.5);
        $newimg = $img->rotate(degrees=>20);
        $newimg->filter(type=>"contrast", intensity=>1.4);
        $newimg = $img->convert(matrix => [[0, 1, 0], [1, 0, 0], [0, 0, 1]]);
        $newimg = $img->convert(preset=>'grey');
        $d->add(scalar(Image::PHash->new($newimg)->pHash));
        $img->filter(type=>'mandelbrot');
    }
    return $d->hexdigest;
}

sub bench_json {
    my $iter = shift;
    my $res  = 'PASS';
    for (1..$iter) {
        my $len = int(rand(40)) + 1;
        my $obj = rand_hash($len);
        my $str = encode_json($obj);
        foreach (1..100) {
            $obj = decode_json($str);
            $str = encode_json($obj);
        }
        my $obj2 = decode_json($str);
        $res = 'FAIL' unless compare_obj($obj, $obj2);
    }
    return $res;
}

sub bench_jwt {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $data = _random_str(5000);
    my $rsa ='-----BEGIN PRIVATE KEY-----
    MIIBVAIBADANBgkqhkiG9w0BAQEFAASCAT4wggE6AgEAAkEAqPfgaTEWEP3S9w0t
    gsicURfo+nLW09/0KfOPinhYZ4ouzU+3xC4pSlEp8Ut9FgL0AgqNslNaK34Kq+NZ
    jO9DAQIDAQABAkAgkuLEHLaqkWhLgNKagSajeobLS3rPT0Agm0f7k55FXVt743hw
    Ngkp98bMNrzy9AQ1mJGbQZGrpr4c8ZAx3aRNAiEAoxK/MgGeeLui385KJ7ZOYktj
    hLBNAB69fKwTZFsUNh0CIQEJQRpFCcydunv2bENcN/oBTRw39E8GNv2pIcNxZkcb
    NQIgbYSzn3Py6AasNj6nEtCfB+i1p3F35TK/87DlPSrmAgkCIQDJLhFoj1gbwRbH
    /bDRPrtlRUDDx44wHoEhSDRdy77eiQIgE6z/k6I+ChN1LLttwX0galITxmAYrOBh
    BVl433tgTTQ=
    -----END PRIVATE KEY-----';
    my $key = '-----BEGIN PRIVATE KEY-----
    MIGHAgEAMBMGByqGSM49AgEGCCqGSM49AwEHBG0wawIBAQQgYirTZSx+5O8Y6tlG
    cka6W6btJiocdrdolfcukSoTEk+hRANCAAQkvPNu7Pa1GcsWU4v7ptNfqCJVq8Cx
    zo0MUVPQgwJ3aJtNM1QMOQUayCrRwfklg+D/rFSUwEUqtZh7fJDiFqz3
    -----END PRIVATE KEY-----';
    foreach (1..$iter) {
        my $extra   = _random_str(100);
        my $data_in = $data.$extra;
        my $token   = encode_jwt(
            payload       => $data_in,
            alg           => 'ES256',
            key           => \$key,
        );

        my $data_out = _decode_jwt2(token=>$token, key=>\$key);
        $d->add($token) if $data_in eq $data_out.$extra;

        $token   = encode_jwt(
            payload       => $data_in,
            alg           => 'RS256',
            key           => \$rsa,
        );

        $data_out = _decode_jwt2(token=>$token, key=>\$rsa);
        $d->add($token) if $data_in eq $data_out.$extra;
    }
    return $d->hexdigest;
}

sub bench_formattext {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $file;
    for (0..$iter-1) {
        my $i = $_ % 2;
        $file = catfile($datadir, "wiki$i.html");
        my $tree = HTML::TreeBuilder->new->parse_file($file);
        my $formatter = HTML::FormatText->new();
        my $text = $formatter->format($tree);
        $formatter = HTML::FormatText->new(leftmargin => 0, rightmargin => 30);
        $d->add(Encode::encode_utf8($formatter->format($tree)));
    }
    return $d->hexdigest;
}

sub bench_matrixreal {
    my $iter    = shift;
    my $d       = Digest->new("MD5");
    my $smatrix = Math::MatrixReal->new_random(13);
    my $matrix  = Math::MatrixReal->new_random(20);
    my $bmatrix = Math::MatrixReal->new_random(72);

    for (1..$iter) {
        my $r = rand(10);
        my $m1 = $r*$bmatrix;
        my $m2 = $bmatrix*$r;
        my $m3 = $bmatrix->multiply_scalar($bmatrix,$r);
        # Should be zero
        $d->add($m1->element(1, 1) + $m2->element(1, 1) - 2 * $bmatrix->element(1, 1))
            if $_ % 10 == 1;

        my $m = $matrix->det;
        $d->add($m) if $_ % 10 == 1;
        $m =$matrix->decompose_LR->det_LR;
        $d->add($m) if $_ % 10 == 1;
        $m1 = $matrix ** 2;
        $m2 = $matrix * $matrix;
        #should be zero
        $d->add($m1->element(1, 1) - $m2->element(1, 1))
            if $_ % 10 == 1;
        $m1 = $smatrix->inverse();
        $m2 = $smatrix ** -1;
        $m3 = $smatrix->decompose_LR->invert_LR;
        $d->add($m1->element(1, 1), $m2->element(1, 1), $m3->element(1, 1))
            if $_ % 10 == 1;
    }

    return $d->hexdigest;
}

sub bench_moose {
    my $iter = shift;
    my $cnt  = 0;

    for (1..$iter) {
        my $p    = rand(1000);
        my $root = Benchmark::DKbench::MooseTree->new(node => 'root');
        $root->price($p);
        $root->node;
        $root->cost;
        my $lchild = $root->left;
        $lchild->node('child');
        $lchild->price($p);
        $lchild->tax;
        my $child = $root->right;
        $child->cost;
        my $grandchild = $child->left;
        $grandchild->node('grandchild');
        $grandchild->has_parent;
        $grandchild->parent;
        $grandchild->price($p);
        $grandchild->cost;
        my $ggchild = $grandchild->right;
        $ggchild->cost;
        $cnt += 5;
    }
    return md5_hex("$cnt objects");
}

sub bench_moose_prv {
    my $iter = shift;
    my $tdir = catfile($datadir, 't');
    my $result;
    if ($iter < 1) {
        $tdir = catfile($tdir, 'recipes');
        $result = `prove -rQ $tdir`;
    } else {
        $result = `prove -rQ $tdir` for (1..$iter);
    }
    if ($result =~ /Result: (\w*)/) {
        return $1;
    } else  {
        return '?';
    }
}

sub bench_primes_m {
    my $iter = shift;
    return bench_primes($iter, 7_500_000);
}

sub bench_primes {
    my $iter = shift;
    my $max  = shift;
    my @primes;
    @primes = _get_primes($max) for (1..$iter);
    return md5_hex(scalar(@primes)." primes up to $max");
}

sub bench_regex_asc {
    my $iter = shift;
    return bench_regex_subst($iter, '');
}

sub bench_regex_utf8 {
    my $iter = shift;
    return bench_regex_subst($iter, 'utf8');
}

sub bench_regex_subst {
    my $iter  = shift;
    my $enc   = shift;
    my $str   = _read_wiki_files($enc);
    my $match = bench_regex($str, $iter);
    my $repl  = bench_subst($str, $iter);
    return md5_hex($match, $repl);
}

sub bench_regex {
    my $str  = shift;
    my $iter = shift;
    my $count;
    for (1..$iter) {
        $count = 0;
        $count += () = $str =~ /\b[A-Z][a-z]+/g;
        $count += () = $str =~ /([\w\.+-]+)@[\w\.-]+\.([\w\.-]+)/g;
        $count += () = $str =~ m![\w]+://[^/\s?#]+[^\s?#]+(?:\?[^\s#]*)?(?:#[^\s]*)?!g;
    }
    return "$count Matched";
}

sub bench_subst {
    my $str  = shift;
    my $iter = shift;
    my $count;
    for (1..$iter) {
        my $copy = $str;
        $count = 0;
        while (my $s = $copy =~ s#<([^>]+)>([^>]*?)</\1>#$2#g) {
            $count += $s;
        }
        $copy = substr($copy, int(rand(100))+1) for 1..10;
    }
    return "$count Replaced";
}

sub bench_textfuzzy {
    my $iter = shift;
    my $d    = Digest->new("MD5");
    my $data = _fuzzy_data();
    my $diff;
    foreach (1..$iter) {
        foreach my $sz (qw/10 100 1000/) {
            my $i = int(rand(10));
            my $tf = Text::Fuzzy->new($data->{$sz}->[$i]);
            $diff = $tf->distance($data->{$sz}->[$_]) for 0..9;
            $d->add($diff);
            $tf = Text::Fuzzy->new($data->{$sz}->[$i], trans => 1, max => 100);
            $diff = $tf->distance($data->{$sz}->[$_]) for 0..9;
            $d->add($diff);
            $diff = Text::Levenshtein::Damerau::XS::xs_edistance(
                $data->{$sz}->[$i], $data->{$sz}->[$_]
            ) for 1..9;
            $d->add($diff);
        }
    }
    return $d->hexdigest;
}

sub bench_timepiece {
    my $iter = shift;
    my $t    = Time::Piece::localtime(1692119499);
    my $d    = Digest->new("MD5");
    my $day  = 3600*24;
    local $ENV{TZ} = 'UTC';

    for (1..$iter) {
        $t += int(rand(1000)-500)*$day;
        $t += 100000*$day if $t->year < 1970;
        my $str = $t->strftime("%w, %d %m %Y %H:%M:%S");
        $t = Time::Piece->strptime($str, "%w, %d %m %Y %H:%M:%S");
        my $jd = $t->julian_day;
        $d->add($str,$jd);
    }
    return $d->hexdigest;
}

sub total_stats {
    my ($opt, $stats) = @_;
    my $benchmarks = benchmark_list();
    my $display = $opt->{time} ? 'times' : 'scores';
    my $title   = $opt->{time} ? 'Time (sec)' : 'Score';
    print "Aggregates:\n".pad_to("Benchmark",24).pad_to("Avg $title").pad_to("Min $title").pad_to("Max $title");
    print pad_to("Pass %") unless $opt->{time};
    print "\n";
    foreach my $bench (sort keys %$benchmarks) {
        next unless $stats->{$bench}->{$display};
        my $str = calc_stats($opt, $stats->{$bench}->{$display});
        print pad_to("$bench:",24).$str;
        print pad_to(
            sprintf("%d", 100 * ($opt->{iter}-($stats->{$bench}->{fail} || 0)) / $opt->{iter}))
            unless $opt->{time};
        print "\n";
    }
    my $str = calc_stats($opt, $stats->{total}->{$display});
    print pad_to("Overall Avg $title:", 24)."$str\n";
}

sub calc_stats {
    my $opt = shift;
    my $arr = shift;
    my $pad = shift;
    my ($min, $max, $avg) = min_max_avg($arr);
    return $avg, join '', map {pad_to(sprintf($opt->{f}, $_), $pad)} ($avg,$min,$max);
}

sub min_max_avg {
    my $arr = shift;
    return (0, 0, 0) unless @$arr;
    return min(@$arr), max(@$arr), sum(@$arr)/scalar(@$arr);
}

sub avg_stdev {
    my $arr = shift;
    return (0, 0) unless @$arr;
    my $sum = sum(@$arr);
    my $avg = $sum/scalar(@$arr);
    my @sq;
    push @sq, ($avg - $_)**2 for (@$arr);
    my $dev = min_max_avg(\@sq);
    return $avg, sqrt($dev);
}

# $single = single tail of dist curve outlier, 1 for over (right), -1 for under (left)
sub drop_outliers {
    my $arr    = shift;
    my $single = shift;
    my ($avg, $stdev) = avg_stdev($arr);
    my @newarr;
    foreach (@$arr) {
        if ($single) {
            push @newarr, $_ unless $single*($_ - $avg) > 2*$stdev;
        } else {
            push @newarr, $_ unless abs($avg - $_) > 2*$stdev;
        }
    }
    return @newarr;
}

sub pad_to {
    my $str = shift;
    my $len = shift || 20;
    return $str." "x($len-length($str));
}

sub _read_wiki_files {
    my $enc = shift || '';
    my $str = "";
    for (0..2) {
        open my $fh, "<:$enc", catfile($datadir,"wiki$_.html") or die $!;
        $str .= do { local $/; <$fh> };
    }
    return $str;
}

sub _random_str {
    my $length = shift || 1;
    my ($base, $rng) = shift ? (65, 26) : (32, 95);
    my $str = "";
    $str .= chr(int(rand($rng))+$base) for 1..$length;
    return $str;
}

sub _random_uchar {
    my $chr = int(rand(800))+32;
    $chr += 128 if $chr > 127; # Skip Latin 1 supplement
    $chr += 288 if $chr > 591; # Skip pre-Greek blocks
    return chr($chr);
}

sub _fuzzy_data {
    my %data;
    push @{$data{10}}, join('', map {_random_uchar()} 1..(8+int(rand(5))))
        for 0..9;
    push @{$data{100}}, $data{10}->[$_]x10 for 0..9;
    push @{$data{1000}}, _random_str(50,1)x20 for 0..9;
    return \%data;
}

sub _rand_where {
    my $p = rand();
    if ($p > 0.5) {
        return {foo => rand(10)};
    } elsif ($p > 0.2) {
        return {bar => {-in => [int($p*10)..int($p*20)]}};
    } else {
        my $op = $p > 0.1 ? '-and' : '-or';
        my @cond = map {_rand_where()} 1..int(rand(3)+1);
        return {$op => [@cond]};
    }
}

sub _db_data {
    my (@data, @cols);
    foreach (1..20) {
        my $d = {
        id   => int(rand(10000000)),
        date => \"NOW()",
        map {"data".$_ => "foo bar" x int(rand(5)+1)} 1..int(rand(20)+1)
        };
        push @data, $d;
        push @cols, [sort keys %$d];
    }
    return \@data, \@cols;
}

sub compare_obj {
    my ($obj1, $obj2) = @_;
    my $t1 = ref($obj1);
    my $t2 = ref($obj2);
    return 0 if $t1 ne $t2;
    return $obj1 eq $obj2 unless $t1;
    return $t1 eq 'ARRAY' ? compare_arr($obj1, $obj2) : compare_hash($obj1, $obj2);
}

sub compare_arr {
    my ($arr1, $arr2) = @_;
    my $sz = scalar @$arr1;
    return 0 if $sz != scalar @$arr2;
    for (0..$sz-1) {
        return 0 unless compare_obj($arr1->[$_], $arr2->[$_]);
    }
    return 1;
}

sub compare_hash {
    my ($h1, $h2) = @_;
    return 0 if scalar keys %$h1 != scalar keys %$h2;
    for (keys %$h1) {
        return 0 unless compare_obj($h1->{$_}, $h2->{$_});
    }
    return 1;
}

sub rand_arr {
    my $sz = shift;
    my @arr;
    for (1..$sz) {
        my $len  = int(rand(10)) + 1;
        my $item = rand(1) < 0.9 ? _random_uchar()x($len*5) : rand(1) < 0.5 ? rand_arr($len) : rand_hash($len);
        push @arr, $item;
    }
    return \@arr;
}

sub rand_hash {
    my $sz = shift;
    my %hash;
    for (1..$sz) {
        my $len  = int(rand(10)) + 1;
        my $item = rand(1) < 0.9 ? _random_uchar()x($len*5) : rand(1) < 0.5 ? rand_arr($len) : rand_hash($len);
        $hash{_random_uchar()x($len*4)} = $item;
    }
    return \%hash;
}

# modified from https://github.com/famzah/langs-performance/blob/master/primes.pl
sub _get_primes {
    my $n = shift;
    my @s = ();
    for (my $i = 3; $i < $n + 1; $i += 2) {
        push(@s, $i);
    }
    my $mroot = $n**0.5;
    my $half  = scalar @s;
    my $i     = 0;
    my $m     = 3;
    while ($m <= $mroot) {
        if ($s[$i]) {
            for (my $j = int(($m * $m - 3) / 2); $j < $half; $j += $m) {
                $s[$j] = 0;
            }
        }
        $i++;
        $m = 2 * $i + 3;
    }

    return 2, grep($_, @s);
}

# Fix for Crypt::JWT that was submitted as a patch. Will remove if it is merged.
sub _decode_jwt2 {
    my %args = @_;
    my ($header, $payload);

    if ($args{token} =~
        /^([a-zA-Z0-9_-]+)=*\.([a-zA-Z0-9_-]*)=*\.([a-zA-Z0-9_-]*)=*(?:\.([a-zA-Z0-9_-]+)=*\.([a-zA-Z0-9_-]+)=*)?$/
    ) {
        if (length($5)) {
            # JWE token (5 segments)
            ($header, $payload) =
                Crypt::JWT::_decode_jwe($1, $2, $3, $4, $5, undef, {}, {},
                %args);
        } else {
            # JWS token (3 segments)
            ($header, $payload) =
                Crypt::JWT::_decode_jws($1, $2, $3, {}, %args);
        }
    }
    return ($header, $payload) if $args{decode_header};
    return $payload;
}

# Helper package for Moose benchmark

{
    package Benchmark::DKbench::MooseTree;

    use Moose;

    has 'price' => (is => 'rw', default    => 10);
    has 'tax'   => (is => 'rw', lazy_build => 1);
    has 'node'  => (is => 'rw', isa => 'Any');
    has 'parent' => (
        is        => 'rw',
        isa       => 'Benchmark::DKbench::MooseTree',
        predicate => 'has_parent',
        weak_ref  => 1,
    );
    has 'left' => (
        is        => 'rw',
        isa       => 'Benchmark::DKbench::MooseTree',
        predicate => 'has_left',
        lazy      => 1,
        builder   => '_build_child_tree',
    );
    has 'right' => (
        is        => 'rw',
        isa       => 'Benchmark::DKbench::MooseTree',
        predicate => 'has_right',
        lazy      => 1,
        builder   => '_build_child_tree',
    );
    before 'right', 'left' => sub {
        my ($self, $tree) = @_;
        $tree->parent($self) if defined $tree;
    };

    sub _build_tax {
        my $self = shift;
        $self->price * 0.2;
    }

    sub _build_child_tree {
        my $self = shift;
        return Benchmark::DKbench::MooseTree->new( parent => $self );
    }

    sub cost {
        my $self = shift;
        $self->price + $self->tax;
    }
}

1;