File Coverage

blib/lib/Benchmark/Serialize/Library.pm

Criterion	Covered	Total	%
statement	12	55	21.8
branch	0	18	0.0
condition	0	11	0.0
subroutine	4	11	36.3
pod	3	3	100.0
total	19	98	19.3

package Benchmark::Serialize::Library;

use strict;
use warnings;

use UNIVERSAL::require qw();
use Carp;

=head1 NAME

Benchmark::Serialize::Library - Library of serialization modules

=head1 VERSION

Version 0.08

=cut

our $VERSION = '0.08';

=head1 SYNOPSIS

    use Benchmark::Serialize::Library;

    Benchmark::Serialize::Library->register(
        MyModule => {
            deflate => sub { MyModule::deflate( $_[0] ) },
            inflate => sub { MyModule::inflate( $_[0] ) },
        }
    );

    my %benchmarks = Benchmark::Serialize::Library->load( ":all" );

=head1 DESCRIPTION

This module contains a library of serialization routines for use with Benchmark::Serialize

=cut

my $benchmarks = {
    'AnyMongo::BSON' => {
        deflate => sub { AnyMongo::BSON::bson_encode( $_[0] )    },
        inflate => sub { AnyMongo::BSON::bson_decode( $_[0] )    },
    },
    'Bencode' => {
        deflate  => sub { Bencode::bencode($_[0])                },
        inflate  => sub { Bencode::bdecode($_[0])                }
    },
    'Convert::Bencode' => {
        deflate  => sub { Convert::Bencode::bencode($_[0])       },
        inflate  => sub { Convert::Bencode::bdecode($_[0])       }
    },
    'Convert::Bencode_XS' => {
        deflate  => sub { Convert::Bencode_XS::bencode($_[0])    },
        inflate  => sub { Convert::Bencode_XS::bdecode($_[0])    }
    },
    'Data::asXML' => {
        deflate  => sub { Data::asXML->new(pretty=>0)->encode($_[0])->toString },
        inflate  => sub { Data::asXML->new(pretty=>0)->decode($_[0]) },
        xml      => 1,
    },
    'Data::Dumper' => {
        deflate  => sub { Data::Dumper->Dump([ $_[0] ])          },
        inflate  => sub { my $VAR1; eval $_[0]                   },
        default  => 1,
        core     => 1,
    },
    'Data::MessagePack' => {
        deflate  => sub { Data::MessagePack->pack($_[0])         },
        inflate  => sub { Data::MessagePack->unpack($_[0])       },
    },
    'Data::Taxi' => {
        deflate  => sub { Data::Taxi::freeze($_[0])              },
        inflate  => sub { Data::Taxi::thaw($_[0])                },
        xml      => 1,
    },
    'Data::Pond' => {
        deflate  => sub { Data::Pond::pond_write_datum($_[0])    },
        inflate  => sub { Data::Pond::pond_read_datum($_[0])     },
    },
    'Data::Pond,eval' => {
        deflate  => sub { Data::Pond::pond_write_datum($_[0])    },
        inflate  => sub { eval($_[0])                            },
        packages => ['Data::Pond'],
    },
    'FreezeThaw' => {
        deflate  => sub { FreezeThaw::freeze($_[0])              },
        inflate  => sub { FreezeThaw::thaw($_[0])                },
        default  => 1
    },
    'JSON::PP' => {
        deflate  => sub { JSON::PP::encode_json($_[0])           },
        inflate  => sub { JSON::PP::decode_json($_[0])           },
        default  => 1,
        json     => 1
    },
    'JSON::XS' => {
        deflate  => sub { JSON::XS::encode_json($_[0])           },
        inflate  => sub { JSON::XS::decode_json($_[0])           },
        default  => 1,
        json     => 1
    },
    'JSON::XS,pretty' => {
        deflate  => sub { $_[1]->encode( $_[0] ) },
        inflate  => sub { $_[1]->decode( $_[0] ) },
        args     => sub { JSON::XS->new->pretty(1)->allow_blessed(1)->convert_blessed(1)->canonical(1) },
        json     => 1,
        packages => ['JSON::XS'],
    },
    'JSON::DWIW' => {
        deflate  => sub { JSON::DWIW->to_json($_[0])             },
        inflate  => sub { JSON::DWIW::deserialize($_[0])         },
        json     => 1,
    },
    'JSYNC' => {
        deflate  => sub { JSYNC::dump($_[0])                     },
        inflate  => sub { JSYNC::load($_[0])                     },
    },
    'Storable' => {
        deflate  => sub { Storable::nfreeze($_[0])               },
        inflate  => sub { Storable::thaw($_[0])                  },
        default  => 1,
        core     => 1,
    },
    'PHP::Serialization' => {
        deflate  => sub { PHP::Serialization::serialize($_[0])   },
        inflate  => sub { PHP::Serialization::unserialize($_[0]) }
    },
    'PHP::Serialization::XS' => {
        deflate  => sub { PHP::Serialization::XS::serialize($_[0])   },
        inflate  => sub { PHP::Serialization::XS::unserialize($_[0]) }
    },
    'RPC::XML' => {
        deflate  => sub { RPC::XML::response->new($_[0])->as_string         },
        inflate  => sub { RPC::XML::ParserFactory->new->parse($_[0])->value },
        packages => ['RPC::XML', 'RPC::XML::ParserFactory'],
        xml      => 1,
    },
    'YAML::Old' => {
        deflate  => sub { YAML::Old::Dump($_[0])                 },
        inflate  => sub { YAML::Old::Load($_[0])                 },
        default  => 1,
        yaml     => 1
    },
    'YAML::XS' => {
        deflate  => sub { YAML::XS::Dump($_[0])                  },
        inflate  => sub { YAML::XS::Load($_[0])                  },
        default  => 1,
        yaml     => 1
    },
    'YAML::Tiny' => {
        deflate  => sub { YAML::Tiny::Dump($_[0])                },
        inflate  => sub { YAML::Tiny::Load($_[0])                },
        default  => 1,
        yaml     => 1
    },
    'XML::Simple' => {
        deflate  => sub { XML::Simple::XMLout($_[0])             },
        inflate  => sub { XML::Simple::XMLin($_[0])              },
        default  => 1,
        xml      => 1,
    },
    'XML::TreePP' => {
        deflate => sub { XML::TreePP->new()->write( $_[0] )      },
        inflate => sub { XML::TreePP->new()->parse( $_[0] )      },
        xml     => 1,
    },
};

=head2 Library methods

This class provides the following methods

=over 5

=item register( NAME => SPECIFICATION )

Registers a new benchmarkable form of serialization. A specification is a
hashref containing the following fields:

=over 5

=item deflate (required)

A coderef taking one argument (a perl structure) and returns the serialized
structure

=item inflate (required)

A coderef taking one argument (a serialized structure) and returns the
perl structure

=item packages (optional)

A array reference containing modules to be loaded. The default value is the
name of the benchmark.

=item args (optional)

A coderef returning a list of aditional arguments for the deflate and inflate
routines. Only run once during initialization of benchmark.

=back

All additional fields are interpreted as tags used for selecting benchmarks.

=cut

sub register {
    my $class     = shift;
    my $name      = shift;
    my $benchmark = shift;

    croak "Missing deflate and/or inflate field"
        unless exists $benchmark->{deflate} && $benchmark->{inflate};

    croak "Existing benchmark"
	if exists $benchmarks->{$name};

    $benchmarks->{$name} = $benchmark;
    return 1;
}

=item load NAME|TAG|BENCHMARK ...

Loads and initializes a number of benchmarks. Arguments can be either
registered names, registered tags, or unregistered benchmarks following the
same format as the C method.

Returns a list of benchmarks

=cut

sub load {
    my $class = shift;

    my %benchmark;
    for my $spec (@_) {
        if ( ref $spec eq "HASH" ) {
            $benchmark{ $spec->{name} } = $spec;

        } elsif ( $spec eq "all" or $spec eq ":all" ) {
            $benchmark { $_ } = $benchmarks->{ $_ } for keys %{ $benchmarks };

        } elsif ( $spec eq "default" ) {
            $benchmark{ $_ } = $benchmarks->{ $_ } for grep { $benchmarks->{ $_ }->{default} } keys %{ $benchmarks };

        } elsif ( $spec =~ /^:(.*)/ ) {
            $benchmark{ $_ } = $benchmarks->{ $_ } for grep { $benchmarks->{ $_ }->{$1} } keys %{ $benchmarks };

        } elsif ( exists $benchmarks->{ $spec } ) {
            $benchmark{ $spec } = $benchmarks->{ $spec }

        } else {
            warn "Unknown benchmark '$spec'.";
        }
    }

    my @list;
    BENCHMARK:
    foreach my $name ( keys %benchmark ) {

        my $benchmark = $benchmark{$name};
        my @packages  = ( exists($benchmark->{packages}) ? @{ $benchmark->{packages} } : $name );

        $_->require or next BENCHMARK for @packages;

        $benchmark->{args} = [ $benchmark->{args}->() ] if exists $benchmark->{args}
                                                        && ref $benchmark->{args} eq "CODE";

	$benchmark->{name}    = $name;
        $benchmark->{version} = $packages[0]->VERSION;

	push @list, bless $benchmark, "Benchmark::Serialize::Benchmark";
    }

    return @list;
}

=item list

Returns a list of all available benchmarks. For each benchmark both the name
and the version is returned in a array ref.

=cut

sub list {
    return map { [ $_->name, $_->version ] } Benchmark::Serialize::Library->load(":all");
}

=back

=cut

package Benchmark::Serialize::Benchmark;

=head2 Benchmark methods

Each benchmark is represented by a object with the following mathods

=over 5

=item deflate

Takes a perl structure as argument and returns the serialized form

=cut

sub deflate {
    $_[0]->{deflate}->($_[1], @{ $_[0]->{args} } );
}

=item inflate

Takes a serialized form as argument and returns the perl structure.

=cut

sub inflate {
    $_[0]->{inflate}->($_[1], @{ $_[0]->{args} } );
}

=item name

Returns the name of the benchmark

=cut

sub name {
    my $self = shift;

    return $self->{name};
}

=item version

Returns the module version of the benchmark. For benchmark needing multiple
loaded modules, the first in the specification list is used.

=cut

sub version {
    my $self = shift;

    return $self->{version};
}

=back

=head2 Known tags

The following tags are usec in the standard library

=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


=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-2010 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;