File Coverage

blib/lib/Benchmark/Serialize.pm

Criterion	Covered	Total	%
statement	18	134	13.4
branch	0	48	0.0
condition	0	3	0.0
subroutine	6	20	30.0
pod	1	11	9.0
total	25	216	11.5

package Benchmark::Serialize;

use strict;
use warnings;

=head1 NAME

Benchmark::Serialize - Benchmarks of serialization modules

=head1 VERSION

Version 0.08

=cut

our $VERSION = '0.08';

=head1 SYNOPSIS

    use Benchmark::Serialize qw(cmpthese);

    my $structure = {
        array  => [ 'a' .. 'j' ],
        hash   => { 'a' .. 'z' },
        string => 'x' x 200,
    };

    cmpthese( -5, $structure, qw(:core :json :yaml) );

=head1 DESCRIPTION

This module encapsulates some basic benchmarks to help you choose a module
for serializing data. Note that using this module is only a part of chosing a
serialization format. Other factors than the benchmarked might be of
relevance!

Included is support for 24 different serialization modules. Also supported
is the Data::Serializer wrapper providing a unified interface for
serialization and some extra features. Benchmarking of specialized modules
made with Protocol Buffers for Perl/XS (protobuf-perlxs) is also available.

=head2 Functions

This module provides the following functions

=over 5

=item cmpthese(COUNT, STRUCTURE, BENCHMARKS ...)

Benchmark COUNT interations of a list of modules. A benchmark is either a name
of a supported module, a tag, or a hash ref containing at least an inflate, a
deflate, and a name attribute:

  {
      name    => 'JSON::XS',
      deflate => sub { JSON::XS::encode_json($_[0]) }
      inflate => inflate  => sub { JSON::XS::decode_json($_[0]) }
  }

By default Benchmark::Serialize will try to use the name attribute as a module
to be loaded. This can be overridden by having a packages attribute with an
arrayref containing modules to be loaded.

=back

=head2 Benchmark tags

The following tags are supported

=over 5

=item :all     - All modules with premade benchmarks

=item :default - A default set of serialization modules

=item :core    - Serialization modules included in core

=item :json    - JSON modules

=item :yaml    - YAML modules

=item :xml     - XML formats

=back

=cut

use Benchmark          qw[timestr];
use Test::Deep::NoTest;

use Benchmark::Serialize::Library;

use Exporter qw(import);
our @EXPORT_OK   = qw( cmpthese );
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

our $benchmark_deflate  = 1;       # boolean
our $benchmark_inflate  = 1;       # boolean
our $benchmark_roundtrip= 1;       # boolean
our $benchmark_size     = 1;       # boolean
our $verbose            = 0;       # boolean
our $output             = 'chart'; # chart or list

sub cmpthese {
    my $iterations = shift;
    my $structure  = shift;
    my @benchmarks = Benchmark::Serialize::Library->load( @_ );

    my $width   = width(map { $_->name } @benchmarks);
    my $results = { };

    print "\nModules\n";

    BENCHMARK:

    foreach my $benchmark ( sort { $a->name cmp $b->name } @benchmarks ) {
	my $name = $benchmark->name;

        my ($deflated, $inflated);
        eval {
            $deflated = $benchmark->deflate($structure);
            $inflated = $benchmark->inflate($deflated);
            1;
        } or do {
            warn "Benchmark $name died with:\n    $@\n";
            next BENCHMARK;
        };

        my ($likeliness, $diag) = likeliness( $inflated, $structure );
        printf( "%-${width}s : %8s %s\n", $benchmark->name, $benchmark->version, $likeliness);

        print Test::Deep::deep_diag($diag), "\n" if defined($diag) and $Benchmark::Serialize::verbose;

        $results->{deflate}->{$name} = timeit_deflate( $iterations, $structure, $benchmark )
            if $benchmark_deflate;

        $results->{inflate}->{$name} = timeit_inflate( $iterations, $structure, $benchmark )
            if $benchmark_inflate;

        $results->{roundtrip}->{$name} = timeit_roundtrip( $iterations, $structure, $benchmark )
            if $benchmark_roundtrip;

        $results->{size}->{$name}    = length( $deflated );
    }

    output( 'Sizes', "size", $output, $results->{size}, $width )
        if $benchmark_size;

    output( 'Deflate (perl -> serialized)', "time", $output, $results->{deflate}, $width )
        if $benchmark_deflate;

    output( 'Inflate (serialized -> perl)', "time", $output, $results->{inflate}, $width )
        if $benchmark_inflate;

    output( 'Roundtrip', "time", $output, $results->{roundtrip}, $width )
        if $benchmark_roundtrip;
}

sub output {
    my $title  = shift;
    my $type   = shift;
    my $output = shift;
    printf( "\n%s\n", $title );
    if ( $type eq "size" ) {
        ($output eq "list") ? &size_list : &size_chart ;
    } elsif ( $type eq "time" ) {
        ($output eq "list") ? &time_list : &time_chart ;

    } else {
        warn("Unknown data type: $type");
    }
}

sub time_chart {
    my $results = shift;
    Benchmark::cmpthese($results);
}

sub time_list {
    my $results = shift;
    my $width   = shift;
    foreach my $title ( sort keys %{ $results } ) {
        printf( "%-${width}s %s\n", $title, timestr( $results->{ $title } ) );
    }
}

sub size_chart {
    my $results = shift;
    my @vals    = sort { $a->[1] <=> $b->[1] } map { [ $_, $results->{$_} ] } keys %$results;

    my @rows    = ( [
        '',
        'bytes',
        map { $_->[0] } @vals,
    ] );

    my @col_width = map { length ( $_ ) } @{ $rows[0] };

    for my $row_val ( @vals ) {
        my @row;

        push @row, $row_val->[0], $row_val->[1];
        $col_width[0] = ( length ( $row_val->[0] ) > $col_width[0] ? length( $row_val->[0] ) : $col_width[0] );
        $col_width[1] = ( length ( $row_val->[1] ) > $col_width[1] ? length( $row_val->[1] ) : $col_width[1] );

        # Columns 2..N = performance ratios
        for my $col_num ( 0 .. $#vals ) {
            my $col_val = $vals[$col_num];
            my $out;

            if ( $col_val->[0] eq $row_val->[0] ) {
                $out = "--";
            } else {
                $out = sprintf( "%.0f%%", 100*$row_val->[1]/$col_val->[1] - 100 );
            }

            push @row, $out;
            $col_width[$col_num+2] = ( length ( $out ) > $col_width[$col_num+2] ? length ( $out ) : $col_width[$col_num+2]);
        }
        push @rows, \@row;
    }

    # Pasted from Benchmark.pm
    # Equalize column widths in the chart as much as possible without
    # exceeding 80 characters.  This does not use or affect cols 0 or 1.
    my @sorted_width_refs =
       sort { $$a <=> $$b } map { \$_ } @col_width[2..$#col_width];
    my $max_width = ${$sorted_width_refs[-1]};

    my $total = @col_width - 1 ;
    for ( @col_width ) { $total += $_ }

    STRETCHER:
    while ( $total < 80 ) {
        my $min_width = ${$sorted_width_refs[0]};
        last
           if $min_width == $max_width;
        for ( @sorted_width_refs ) {
            last
                if $$_ > $min_width;
            ++$$_;
            ++$total;
            last STRETCHER
                if $total >= 80;
        }
    }

    # Dump the output
    my $format = join( ' ', map { "%${_}s" } @col_width ) . "\n";
    substr( $format, 1, 0 ) = '-';
    for ( @rows ) {
        printf $format, @$_;
    }
}

sub size_list {
    my $results = shift;
    my $width   = shift;
    foreach my $title ( sort keys %{ $results } ) {
        printf( "%-${width}s : %d bytes\n", $title, $results->{ $title } );
    }
}

sub timeit_deflate {
    my ( $iterations, $structure, $benchmark ) = @_;
    return Benchmark::timethis( $iterations, sub { $benchmark->deflate($structure) }, '', 'none' );
}

sub timeit_inflate {
    my ( $iterations, $structure, $benchmark ) = @_;
    my $deflated = $benchmark->deflate($structure);
    return Benchmark::timethis( $iterations, sub { $benchmark->inflate($deflated) }, '', 'none' );
}

sub timeit_roundtrip {
    my ( $iterations, $structure, $benchmark ) = @_;
    return Benchmark::timethis( $iterations, sub { $benchmark->inflate( $benchmark->deflate( $structure )) }, '', 'none' );
}

sub width {
    return length( ( sort { length $a <=> length $b } @_ )[-1] );
}

sub likeliness {
    my ($got, $expected) = @_;
    my ($ok, $diag);

    ($ok, $diag) = Test::Deep::cmp_details( $got, $expected );
    return ("Identical", undef) if $ok;

    ($ok, $diag) = Test::Deep::cmp_details( $got, noclass($expected) );
    return ("Changes blessing", undef) if $ok;

    ($ok, $diag) = Test::Deep::cmp_details( $got, noclass(superhashof $expected) );
    return ("Adds content", undef) if $ok;

    ($ok, $diag) = Test::Deep::cmp_details( $got, noclass(subhashof $expected) );
    return ("Removes content", undef) if $ok;

    return ("Changes content", $diag);
}

=head1 RESULTS

See the README file for example results.

=head1 AUTHOR

Peter Makholm, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to C
rt.cpan.org>, or through
the web interface at
L.  I will
be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 ACKNOWLEDGEMENTS

This module started out as a script written by Christian Hansen, see
http://idisk.mac.com/christian.hansen/Public/perl/serialize.pl

=head1 COPYRIGHT & LICENSE

Copyright 2009 Peter Makholm.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1;