use strict;
use warnings;
use blib;
use Benchmark qw(cmpthese :hireswallclock);
use Sereal::Decoder qw(decode_sereal sereal_decode_with_object);
use Sereal::Encoder qw(encode_sereal sereal_encode_with_object);
use Storable qw(nfreeze thaw);
use Data::Dumper qw(Dumper);


use Getopt::Long qw(GetOptions);
require bytes;

GetOptions(
    'secs|duration=f'                    => \( my $duration           = -5 ),
    'encoder'                            => \( my $encoder            = 0 ),
    'decoder'                            => \( my $decoder            = 0 ),
    'dump|d'                             => \( my $dump               = 0 ),
    'only=s@'                            => \( my $only               = undef ),
    'exclude=s@'                         => \( my $exclude            = undef ),
    'tiny'                               => \( my $tiny_data          = 0 ),
    'small'                              => \( my $small_data         = 0 ),
    'medium'                             => \( my $medium_data        = 0 ),
    'large'                              => \( my $large_data         = 0 ),
    'very_large|very-large|verylarge'    => \( my $very_large_data    = 0 ),
    'no_bless|no-bless|nobless'          => \( my $nobless            = 0 ),
    'sereal_only|sereal-only|serealonly' => \( my $sereal_only        = 0 ),
    'diagrams'                           => \( my $diagrams           = 0 ),
    'diagram_output=s'                   => \( my $diagram_output_dir = "" ),
) or die "Bad option";

my $fail =
  $tiny_data + $small_data + $medium_data + $very_large_data + $large_data - 1;
if ( $fail and $fail > 0 ) {
    die "Only one of --tiny, --small, --medium, --large, --very-large allowed!";
}
$encoder = 1 if not $encoder and not $decoder;

#our %opt = @ARGV;
our %opt;

my $data_set_name;
srand(0);
my $chars = join( "", "a" .. "z", "A" .. "Z" ) x 2;
my @str;
push @str, substr( $chars, int( rand( int( length($chars) / 2 + 1 ) ) ), 10 )
  for 1 .. 1000;
my @rand = map rand, 1 .. 1000;

our (
    $enc, $dec,
    $enc_snappy,        $dec_snappy,
    $enc_zlib_fast,     $dec_zlib_fast,
    $enc_zlib_small,    $dec_zlib_small,
    $jsonxs, $msgpack, $dd_noindent, $dd_indent, $cbor
);
my $storable_tag= "strbl";
my $sereal_tag= "srl";
my %meta = (
    jxs => {
        enc  => '$::jsonxs->encode($data);',
        dec  => '$::jsonxs->decode($encoded);',
        name => 'JSON::XS OO',
        init => sub {
            $jsonxs = JSON::XS->new()->allow_nonref();
        },
        use => 'use JSON::XS qw(decode_json encode_json);',
    },
    ddl => {
        enc  => 'DumpLimited($data);',
        dec  => 'Data::Undump::undump($encoded);',
        name => 'Data::Dump::Limited',
        use  => [
                    'use Data::Undump qw(undump);',
                    'use Data::Dumper::Limited qw(DumpLimited);',
                ],
    },
    mp => {
        enc  => '$::msgpack->pack($data);',
        dec  => '$::msgpack->unpack($encoded);',
        name => 'Data::MsgPack',
        use  => 'use Data::MessagePack;',
        init => sub {
            $msgpack = Data::MessagePack->new();
        },
    },
    cbor => {
        enc  => '$::cbor->encode($data);',
        dec  => '$::cbor->decode($encoded);',
        name => 'CBOR::XS',
        use => 'use CBOR::XS qw(encode_cbor decode_cbor);',
        init => sub {
            $cbor= CBOR::XS->new();
        },
    },
    dd_noind => {
        enc  => 'Data::Dumper->new([$data])->Indent(0)->Dump();',
        dec  => 'eval $encoded;',
        name => 'Data::Dumper no-indent',
    },
    dd => {
        enc  => 'Dumper($data);',
        dec  => 'eval $encoded;',
        name => 'Data::Dumper indented',
    },
    $storable_tag => {
        enc  => 'nfreeze($data);',
        dec  => 'thaw($encoded);',
        name => 'Storable',
    },
    srl_func => {
        enc  => 'encode_sereal($data, $opt);',
        dec  => 'decode_sereal($encoded, $opt);',
        name => 'Sereal functional',
    },
    srl_fwo => {
        enc  => 'sereal_encode_with_object($::enc,$data);',
        dec  => 'sereal_decode_with_object($::dec,$encoded);',
        name => 'Sereal functional with object',
    },
    $sereal_tag => {
        enc  => '$::enc->encode($data);',
        dec  => '$::dec->decode($encoded);',
        name => 'Sereal OO',
        init => sub {
            $enc = Sereal::Encoder->new( %opt ? \%opt : () );
            $dec = Sereal::Decoder->new( \%opt ? \%opt : () );
        },
    },
    srl_snpy => {
        enc  => '$::enc_snappy->encode($data);',
        dec  => '$::dec_snappy->decode($encoded);',
        name => 'Sereal OO snappy',
        init => sub {
            $enc_snappy = Sereal::Encoder->new(
                {
                    %opt,
                    compress => Sereal::Encoder::SRL_SNAPPY
                }
            );
            $dec_snappy = Sereal::Decoder->new( %opt ? \%opt : () );
        },
    },
    srl_zfast => {
        enc  => '$::enc_zlib_fast->encode($data);',
        dec  => '$::dec_zlib_fast->decode($encoded);',
        name => 'Sereal OO zlib fast',
        init => sub {
            $enc_zlib_fast = Sereal::Encoder->new(
                {
                    %opt,
                    compress           => Sereal::Encoder::SRL_ZLIB,
                    compress_level     => 1,
                    compress_threshold => 0,
                }
            );
            $dec_zlib_fast = Sereal::Decoder->new( %opt ? \%opt : () );
        },
    },
    srl_zbest => {
        enc  => '$::enc_zlib_small->encode($data);',
        dec  => '$::dec_zlib_small->decode($encoded);',
        name => 'Sereal OO zib best',
        init => sub {
            $enc_zlib_small = Sereal::Encoder->new(
                {
                    %opt,
                    compress           => Sereal::Encoder::SRL_ZLIB,
                    compress_level     => 10,
                    compress_threshold => 0,
                }
            );
            $dec_zlib_small = Sereal::Decoder->new( %opt ? \%opt : () );
        },
    },
);
if ($only) {
    my @pat= map { split /\s*,\s*/, $_ } @$only;
    $only = {};
    foreach my $key (keys %meta) {
        $key=~/$_/ and $only->{$key}= 1
            for @pat;
    }
    die "Only [@pat] produced no matches!" unless keys %$only;
}
if ($exclude) {
    my @pat= map { split /\s*,\s*/, $_ } @$exclude;
    $exclude = {};
    foreach my $key (keys %meta) {
        $key=~/$_/ and $exclude->{$key}= 1
            for @pat;
    }
    die "Exclude [@pat] produced no matches!" unless keys %$exclude;
}

our %data;
our %encoded;
our %decoded;
our %enc_bench;
our %dec_bench;
foreach my $key ( sort keys %meta ) {
    my $info = $meta{$key};
    $info->{tag}= $key;
    next if $only    and not $only->{$key}    and $key ne $storable_tag;
    next if $exclude and     $exclude->{$key} and $key ne $storable_tag;
    if (my $use= $info->{use}) {
        $use= [$use] unless ref $use;
        $use= join ";\n", @$use, 1;
        unless (eval $use) {
            warn "Can't load dependencies for $info->{name}, skipping\n";
            next;
        }
    }
    $info->{enc}=~s/\$data/\$::data{$key}/g;
    $info->{dec}=~s/\$encoded/\$::encoded{$key}/g;
    $info->{enc}=~s/\$opt/%opt ? "\\%::opt" : ""/ge;
    $info->{dec}=~s/\$opt/%opt ? "\\%::opt" : ""/ge;

    $data{$key}    = make_data();
    $info->{init}->() if $info->{init};
    $encoded{$key} = eval $info->{enc}
      or die "Failed to eval $info->{enc}: $@";
    $decoded{$key} = eval '$::x = ' . $info->{dec} . '; 1'
      or die "Failed to eval $info->{dec}: $@\n$encoded{$key}\n";
    $info->{size}    = bytes::length( $encoded{$key} );
    next if $only    and not $only->{$key};
    next if $exclude and     $exclude->{$key};
    $enc_bench{$key} = '$::x_' . $key . ' = ' . $info->{enc};
    $dec_bench{$key} = '$::x_' . $key . ' = ' . $info->{dec};
}

my $sereal = $encoded{$sereal_tag};
print($sereal), exit if $dump;

my $storable_len = bytes::length($encoded{$storable_tag});
foreach my $info (
    sort { $a->{size} <=> $b->{size} || $a->{name} cmp $b->{name} }
    grep { defined $_->{size} }
    values %meta
) {
    next unless $info->{size};
    if ($info->{tag} eq $storable_tag) {
        printf "%-40s %12d bytes\n",
            $info->{name} . " ($info->{tag})", $info->{size};
    } else {
        printf "%-40s %12d bytes %6.2f%% of $storable_tag\n",
            $info->{name} . " ($info->{tag})", $info->{size},
            $info->{size} / $storable_len * 100;
    }
}

our $x;
my ( $encoder_result, $decoder_result );
if ($encoder) {
    print "\n* Timing encoders\n";
    $encoder_result = cmpthese( $duration, \%enc_bench );
}

if ($decoder) {
    print "\n* Timing decoders\n";
    $decoder_result = cmpthese( $duration, \%dec_bench );
}

sub make_data {
    if ($tiny_data) {
        $data_set_name = "empty hash";
        return {};
    }
    elsif ($small_data) {
        $data_set_name = "small hash";
        return {
            foo => 1,
            bar => [ 100, 101, 102 ],
            str => "this is a \x{df} string which has to be serialized"
        };
    }
    elsif ($medium_data) {
        my @obj = (
            {
                foo => 1,
                bar => [ 100, 101, 102 ],
                str => "this is a \x{df} string which has to be serialized"
            },
            {
                foo => 2,
                bar => [ 103, 103, 106, 999 ],
                str2 =>
                  "this is a \x{df} aaaaaastring which has to be serialized"
            },
            {
                foozle => 3,
                bar    => [100],
                str3 =>
                  "this is a \x{df} string which haaaaadsadas to be serialized"
            },
            {
                foozle => 3,
                bar    => [],
                st4r =>
                  "this is a \x{df} string which has to be sdassdaerialized"
            },
            {
                foo  => 1,
                bar  => [ 100, 101, 102 ],
                s5tr => "this is a \x{df} string which has to be serialized"
            },
            {
                foo => 2,
                bar => [ 103, 103, 106, 999 ],
                str =>
                  "this is a \x{df} aaaaaastring which has to be serialized"
            },
            {
                foozle => 3,
                bar    => [100],
                str =>
                  "this is a \x{df} string which haaaaadsadas to be serialized"
            },
            {
                foozle => 3,
                bar    => [],
                str2 =>
                  "this is a \x{df} string which has to be sdassdaerialized"
            },
            {
                foo2 => -99999,
                bar  => [ 100, 101, 102 ],
                str2 => "this is a \x{df} string which has to be serialized"
            },
            {
                foo2 => 213,
                bar  => [ 103, 103, 106, 999 ],
                str =>
                  "this is a \x{df} aaaaaastring which has to be serialized"
            },
            {
                foozle2 => undef,
                bar     => [100],
                str =>
                  "this is a \x{df} string which haaaaadsadas to be serialized"
            },
            {
                foozle2 => undef,
                bar     => [ 1 .. 20 ],
                str =>
                  "this is a \x{df} string which has to be sdassdaerialized"
            },
        );
        my @classes = qw(Baz Baz Baz3 Baz2 Baz Baz Baz3 Baz2 Baz Baz Baz3 Baz2);
        if ( $nobless ) {
            $data_set_name = "array of small hashes with relations";
        }
        else {
            bless( $obj[$_], $classes[$_] ) for 0 .. $#obj;
            $data_set_name = "array of small objects with relations";
        }
        foreach my $i ( 1 .. $#obj ) {
            $obj[$i]->{parent} = $obj[ $i - 1 ];
        }
        return \@obj;
    }
    elsif ($very_large_data) {    # "large data"
        $data_set_name = "really rather large data structure";
        my @refs = (
            [ 1 .. 10000 ],
            {@str}, {@str}, [ 1 .. 10000 ],
            {@str}, [@rand], {@str}, {@str},
        );
        return [
            \@refs, \@refs,
            [ map { [ reverse 1 .. 100 ] } ( 0 .. 1000 ) ],
            [ map { +{ foo => "bar", baz => "buz" } } 1 .. 2000 ]
        ];
    }
    else {    # "large data"
        $data_set_name = "large data structure";
        return [
            [ map { my $y= "$_"; $_ } 1 .. 10000 ], {@str}, {@str}, [ map { my $y= "$_"; $_ } 1 .. 10000 ],
            {@str}, [@rand], {@str}, {@str},
        ];
    }
}

if ($diagrams) {
    require SOOT;
    SOOT::Init(0);
    SOOT->import(":all");

    my ( $enc_data, $dec_data );
    $enc_data = cmpthese_to_sanity($encoder_result) if $encoder_result;
    $dec_data = cmpthese_to_sanity($decoder_result) if $decoder_result;

    foreach my $dia (
        [ "Encoder performance [1/s]", $enc_data ],
        [ "Decoder performance [1/s]", $dec_data ],
      )
    {
        my ( $title, $d ) = @$dia;
        next if not $d;
        $_->[0] =~ s/_/ /g, $_->[0] =~ s/sereal /sereal, / for @$d;
        make_bar_chart(
            substr( $title, 0, 3 ),
            $d,
            {
                title    => $title,
                filename => do {
                    my $x = $title;
                    $x =~ s/\[1\/s\]/per second/;
                    $data_set_name . " - " . $x;
                },
            }
        );
    }

    my %names = (
        "JSON::XS"                => 'json xs',
        "Data::Dumper::Limited"   => 'ddl',
        "Data::MessagePack"       => "msgpack",
        "Data::Dumper (1)"        => "dd noindent",
        "Data::Dumper (2)"        => "dd",
        "Storable"                => 'storable',
        "Sereal::Encoder"         => 'sereal',
        "Sereal::Encoder, Snappy" => 'sereal, snappy',
    );

    make_bar_chart(
        "size",
        [
            sort { $b->[1] <=> $a->[1] }
            map { $_->{size} ? [ $_->{name}, $_->{size} ] : () } values %meta
        ],
        {
            title    => "Encoded output sizes [bytes]",
            color    => kRed(),
            filename => $data_set_name . " - Encoded output sizes in bytes",
        },
    );
    SOOT->Run if not $diagram_output_dir;
}

sub make_bar_chart {
    my ( $name, $data, $opts ) = @_;
    my $h = TH1D->new( $name, ( $opts->{title} || $name ),
        scalar(@$data), -0.5, scalar(@$data) - 0.5 );
    $h->keep;
    $h->SetFillColor( $opts->{color} || kBlue() );
    $h->SetBarOffset(0.12);
    $h->SetBarWidth(0.74);
    $h->SetStats(0);
    $h->GetXaxis()->SetLabelSize(0.06);
    $h->GetXaxis()->SetLabelOffset(0.009);
    $h->GetYaxis()->SetTitle( $opts->{title} ) if defined $opts->{title};
    $h->GetYaxis()->SetTitleSize(0.045);

    for my $i ( 1 .. @$data ) {
        my ( $label, $rate ) = @{ $data->[ $i - 1 ] };
        $h->GetXaxis()->SetBinLabel( $i, $label );
        $h->SetBinContent( $i, 0 + $rate );
    }
    my $c = TCanvas->new->keep;
    $c->GetPad(0)->SetBottomMargin(0.175);
    $c->GetPad(0)->SetLeftMargin(0.15);
    $c->GetPad(0)->SetRightMargin(0.115);
    $c->GetPad(0)->SetGrid();
    $h->Draw("bar2");
    if ($diagram_output_dir) {
        require File::Path;
        File::Path::mkpath($diagram_output_dir);
        my $file = $opts->{filename}
          || do { my $f = $opts->{title}; $f =~ s/[^a-zA-Z0-9_\ ]/_/g; $f };
        $c->SaveAs("$diagram_output_dir/$file.png");
    }
}

sub cmpthese_to_sanity {
    my $res  = shift;
    my @rows = map {
        my $rate = $_->[1];
        if ( not $rate =~ s/\s*\/\s*s$// ) {
            $rate = 1 / $rate;
        }
        [ $_->[0], $rate ]
    } grep { defined $_->[0] and $_->[0] =~ /\S/ } @$res;
    return \@rows;
}
print "\n";