File Coverage

blib/lib/Messaging/Message.pm

Criterion	Covered	Total	%
statement	231	263	87.8
branch	98	116	84.4
condition	45	86	52.3
subroutine	45	49	91.8
pod	18	18	100.0
total	437	532	82.1

#+##############################################################################
#                                                                              #
# File: Messaging/Message.pm                                                   #
#                                                                              #
# Description: abstraction of a message                                        #
#                                                                              #
#-##############################################################################

#
# module definition
#

package Messaging::Message;
use strict;
use warnings;
our $VERSION  = "1.6";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Encode qw(encode decode FB_CROAK LEAVE_SRC);
use JSON qw();
use MIME::Base64 qw(encode_base64 decode_base64);
use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use Params::Validate qw(validate validate_pos :types);

#
# global variables
#

our(
    %_LoadedModule,        # hash of successfully loaded modules
    %_CompressionModule,   # known compression modules
    $_CompressionAlgos,    # known compression algorithms
    $_JSON,                # JSON object
);

%_CompressionModule = (
    "lz4"    => "LZ4",
    "snappy" => "Snappy",
    "zlib"   => "Zlib",
);
$_CompressionAlgos = join("|", sort(keys(%_CompressionModule)));
$_JSON = JSON->new();

#+++############################################################################
#                                                                              #
# helper functions                                                             #
#                                                                              #
#---############################################################################

#
# make sure a module is loaded
#

sub _require ($) {
    my($module) = @_;

    return if $_LoadedModule{$module};
    eval("require $module"); ## no critic 'ProhibitStringyEval'
    if ($@) {
        $@ =~ s/\s+at\s.+?\sline\s+\d+\.?$//;
        dief("failed to load %s: %s", $module, $@);
    } else {
        $_LoadedModule{$module} = 1;
    }
}

#
# evaluate some code with fatal warnings
#

sub _eval ($&;$) {
    my($what, $code, $arg) = @_;

    eval {
        local $SIG{__WARN__} = sub { die($_[0]) };
        $code->($arg);
    };
    return unless $@;
    $@ =~ s/\s+at\s.+?\sline\s+\d+\.?$//;
    dief("%s failed: %s", $what, $@);
}

#
# helpers for body encoding and compression
#

sub _maybe_base64_encode ($) {
    my($object) = @_;

    return unless $object->{"body"} =~ /[^\t\n\r\x20-\x7e]/;
    # only if it contains more than printable ASCII characters (plus \t \n \r)
    _eval("Base64 encoding", sub {
        $object->{"body"} = encode_base64($object->{"body"}, "");
    });
    $object->{"encoding"}{"base64"}++;
}

sub _maybe_utf8_encode ($) {
    my($object) = @_;
    my($tmp);

    _eval("UTF-8 encoding", sub {
        $tmp = encode("UTF-8", $object->{"body"}, FB_CROAK|LEAVE_SRC);
    });
    return if $tmp eq $object->{"body"};
    $object->{"body"} = $tmp;
    $object->{"encoding"}{"utf8"}++;
}

sub _do_compress ($$) {
    my($object, $algo) = @_;
    my($compress, $tmp);

    $compress = \&{"Compress::$_CompressionModule{$algo}::compress"};
    _eval("$_CompressionModule{$algo} compression", sub {
        $tmp = $compress->(\$object->{"body"});
    });
    $object->{"body"} = $tmp;
    $object->{"encoding"}{$algo}++;
}

#+++############################################################################
#                                                                              #
# object oriented interface                                                    #
#                                                                              #
#---############################################################################

#
# normal constructor
#

my %new_options = (
    "header" => {
        type => HASHREF,
        callbacks => {
            "hash of strings" =>
                sub { grep(!defined($_)||ref($_), values(%{$_[0]})) == 0 },
        },
        optional => 1,
    },
    "body" => {
        type => SCALAR,
        optional => 1,
    },
    "body_ref" => {
        type => SCALARREF,
        optional => 1,
    },
    "text" => {
        type => BOOLEAN,
        optional => 1,
    },
);

sub new : method {
    my($class, %option, $body, $self);

    $class = shift(@_);
    %option = validate(@_, \%new_options) if @_;
    dief("new(): options body and body_ref are mutually exclusive")
        if exists($option{"body"}) and exists($option{"body_ref"});
    # default message
    $body = "";
    $self = { "header" => {}, "body_ref" => \$body, "text" => 0 };
    # handle options
    $self->{"header"} = $option{"header"}     if exists($option{"header"});
    $self->{"body_ref"} = $option{"body_ref"} if exists($option{"body_ref"});
    $self->{"body_ref"} = \$option{"body"}    if exists($option{"body"});
    $self->{"text"} = $option{"text"} ? 1 : 0 if exists($option{"text"});
    # so far so good!
    bless($self, $class);
    return($self);
}

#
# normal accessors
#

sub header : method {
    my($self);

    $self = shift(@_);
    return($self->{"header"}) if @_ == 0;
    validate_pos(@_, $new_options{"header"});
    $self->{"header"} = $_[0];
    return($self);
}

sub body_ref : method {
    my($self);

    $self = shift(@_);
    return($self->{"body_ref"}) if @_ == 0;
    validate_pos(@_, $new_options{"body_ref"})
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "SCALAR";
    $self->{"body_ref"} = $_[0];
    return($self);
}

sub text : method {
    my($self);

    $self = shift(@_);
    return($self->{"text"}) if @_ == 0;
    validate_pos(@_, $new_options{"text"})
        unless @_ == 1 and (not defined($_[0]) or ref($_[0]) eq "");
    $self->{"text"} = $_[0] ? 1 : 0;
    return($self);
}

#
# extra accessors
#

sub header_field : method {
    my($self);

    $self = shift(@_);
    if (@_ >= 1 and defined($_[0]) and ref($_[0]) eq "") {
        return($self->{"header"}{$_[0]}) if @_ == 1;
        if (@_ == 2 and defined($_[1]) and ref($_[1]) eq "") {
            $self->{"header"}{$_[0]} = $_[1];
            return($self);
        }
    }
    # so far so bad :-(
    validate_pos(@_, { type => SCALAR }, { type => SCALAR, optional => 1 });
}

sub body : method {
    my($self, $body);

    $self = shift(@_);
    return(${ $self->{"body_ref"} }) if @_ == 0;
    validate_pos(@_, $new_options{"body"})
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "";
    $body = $_[0]; # copy
    $self->{"body_ref"} = \$body;
    return($self);
}

#
# extra methods
#

sub copy : method {
    my($self, %header, $body, $copy);

    $self = shift(@_);
    validate_pos(@_) if @_;
    %header = %{ $self->{"header"} }; # copy
    $body = ${ $self->{"body_ref"} }; # copy
    $copy = {
        "header"   => \%header,
        "body_ref" => \$body,
        "text"     => $self->{"text"},
    };
    bless($copy, ref($self));
    return($copy);
}

sub size : method {
    my($self, $size, $key, $value);

    $self = shift(@_);
    validate_pos(@_) if @_;
    $size = 1 + length(${ $self->{"body_ref"} });
    while (($key, $value) = each(%{ $self->{"header"} })) {
        $size += 2 + length($key) + length($value);
    }
    return($size);
}

#+++############################################################################
#                                                                              #
# (de)jsonification                                                            #
#                                                                              #
#---############################################################################

#
# jsonify (= transform into a JSON object)
#

my %jsonify_options = (
    "compression" => {
        type     => SCALAR,
        regex    => qr/^($_CompressionAlgos)?!?$/o,
        optional => 1,
    },
);

sub _jsonify_text ($$$$$) {
    my($self, $object, $algo, $force, $len) = @_;

    if ($algo and $force) {
        # always compress
        _maybe_utf8_encode($object);
        _do_compress($object, $algo);
        _maybe_base64_encode($object);
    } elsif ($algo and $len > 255) {
        # maybe compress
        _maybe_utf8_encode($object);
        _do_compress($object, $algo);
        _maybe_base64_encode($object);
        if (length($object->{"body"}) >= $len) {
            # not worth it
            $object->{"body"} = ${ $self->{"body_ref"} };
            delete($object->{"encoding"});
        }
    } else {
        # do not compress
    }
}

sub _jsonify_binary ($$$$$) {
    my($self, $object, $algo, $force, $len) = @_;

    if ($algo and $force) {
        # always compress
        _do_compress($object, $algo);
        _maybe_base64_encode($object);
    } elsif ($algo and $len > 255) {
        # maybe compress
        $len *= 4/3 if $object->{"body"} =~ /[^\t\n\r\x20-\x7e]/;
        _do_compress($object, $algo);
        _maybe_base64_encode($object);
        if (length($object->{"body"}) >= $len) {
            # not worth it
            $object->{"body"} = ${ $self->{"body_ref"} };
            delete($object->{"encoding"});
            _maybe_base64_encode($object);
        }
    } else {
        # do not compress
        _maybe_base64_encode($object);
    }
}

sub jsonify : method {
    my($self, %option, %object, $algo, $force, $len);

    $self = shift(@_);
    %option = validate(@_, \%jsonify_options) if @_;
    if ($option{"compression"} and $option{"compression"} =~ /^(\w+)(!?)$/) {
        ($algo, $force) = ($1, $2);
    }
    # check compression availability
    _require("Compress::$_CompressionModule{$algo}") if $algo;
    # build the JSON object
    $object{"text"} = JSON::true if $self->{"text"};
    $object{"header"} = $self->{"header"} if keys(%{ $self->{"header"} });
    $len = length(${ $self->{"body_ref"} });
    return(\%object) unless $len;
    $object{"body"} = ${ $self->{"body_ref"} };
    # handle non-empty body
    if ($self->{"text"}) {
        # text body
        _jsonify_text($self, \%object, $algo, $force, $len);
    } else {
        # binary body
        _jsonify_binary($self, \%object, $algo, $force, $len);
    }
    # set the encoding string
    $object{"encoding"} = join("+", sort(keys(%{ $object{"encoding"} })))
        if $object{"encoding"};
    # so far so good!
    return(\%object);
}

#
# dejsonify (= alternate constructor using the JSON object)
#

my %dejsonify_options = (
    "header" => $new_options{"header"},
    "body" => {
        type => SCALAR,
        optional => 1,
    },
    "text" => {
        type => OBJECT,
        callbacks => {
            "JSON::is_bool" => sub { JSON::is_bool($_[0]) },
        },
        optional => 1,
    },
    "encoding" => {
        type => SCALAR,
        optional => 1,
    },
);

sub dejsonify : method {
    my($class, $object, $encoding, $self, $tmp, $len, $uncompress);

    $class = shift(@_);
    validate_pos(@_, { type => HASHREF })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "HASH";
    validate(@_, \%dejsonify_options);
    $object = $_[0];
    $encoding = $object->{"encoding"} || "";
    dief("invalid encoding: %s", $encoding)
        unless $encoding eq ""
            or "${encoding}+" =~ /^((base64|utf8|$_CompressionAlgos)\+)+$/o;
    _require("Compress::$_CompressionModule{$1}")
        if $encoding =~ /($_CompressionAlgos)/o;
    # construct the message
    $self = $class->new();
    $self->{"text"} = 1 if $object->{"text"};
    $self->{"header"} = $object->{"header"}
        if $object->{"header"} and keys(%{ $object->{"header"} });
    if (exists($object->{"body"})) {
        $tmp = $object->{"body"};
        if ($encoding =~ /base64/) {
            # body has been Base64 encoded, compute length to detect unexpected
            # characters (this is because MIME::Base64 silently ignores them)
            $len = length($tmp);
            dief("invalid Base64 data: %s", $object->{"body"}) if $len % 4;
            $len = $len * 3 / 4;
            $len -= substr($tmp, -2) =~ tr/=/=/;
            _eval("Base64 decoding", sub {
                $tmp = decode_base64($tmp);
            });
            dief("invalid Base64 data: %s", $object->{"body"})
                unless $len == length($tmp);
        }
        if ($encoding =~ /($_CompressionAlgos)/o) {
            # body has been compressed
            $uncompress = \&{"Compress::$_CompressionModule{$1}::uncompress"};
            _eval("$_CompressionModule{$1} decompression", sub {
                $tmp = $uncompress->(\$tmp);
            });
            dief("invalid $_CompressionModule{$1} compressed data!")
                unless defined($tmp);
        }
        if ($encoding =~ /utf8/) {
            # body has been UTF-8 encoded
            _eval("UTF-8 decoding", sub {
                $tmp = decode("UTF-8", $tmp, FB_CROAK);
            });
        }
        $self->{"body_ref"} = \$tmp;
    }
    # so far so good!
    return($self);
}

#+++############################################################################
#                                                                              #
# (de)stringification                                                          #
#                                                                              #
#---############################################################################

#
# stringify (= transform into a text string)
#

sub stringify : method {
    my($self, $tmp);

    $self = shift(@_);
    $tmp = $self->jsonify(@_);
    _eval("JSON encoding", sub {
        $tmp = $_JSON->encode($tmp);
    });
    return($tmp);
}

sub stringify_ref : method {
    my($self, $tmp);

    $self = shift(@_);
    $tmp = $self->jsonify(@_);
    _eval("JSON encoding", sub {
        $tmp = $_JSON->encode($tmp);
    });
    return(\$tmp);
}

#
# destringify (= alternate constructor using the stringified representation)
#

sub destringify : method {
    my($class, $tmp);

    $class = shift(@_);
    validate_pos(@_, { type => SCALAR })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "";
    _eval("JSON decoding", sub {
        $tmp = $_JSON->decode(${ $_[0] });
    }, \$_[0]);
    return($class->dejsonify($tmp));
}

sub destringify_ref : method {
    my($class, $tmp);

    $class = shift(@_);
    validate_pos(@_, { type => SCALARREF })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "SCALAR";
    _eval("JSON decoding", sub {
        $tmp = $_JSON->decode(${ $_[0] });
    }, $_[0]);
    return($class->dejsonify($tmp));
}

#+++############################################################################
#                                                                              #
#  (de)serialization                                                           #
#                                                                              #
#---############################################################################

#
# serialize (= transform into a binary string)
#

sub serialize : method {
    my($self, $tmp);

    $self = shift(@_);
    $tmp = $self->stringify_ref(@_);
    _eval("UTF-8 encoding", sub {
        $tmp = encode("UTF-8", ${ $tmp }, FB_CROAK);
    });
    return($tmp);
}

sub serialize_ref : method {
    my($self, $tmp);

    $self = shift(@_);
    $tmp = $self->stringify_ref(@_);
    _eval("UTF-8 encoding", sub {
        $tmp = encode("UTF-8", ${ $tmp }, FB_CROAK);
    });
    return(\$tmp);
}

#
# deserialize (= alternate constructor using the serialized representation)
#

sub deserialize : method {
    my($class, $tmp);

    $class = shift(@_);
    validate_pos(@_, { type => SCALAR })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "";
    return($class->destringify($_[0])) unless $_[0] =~ /[^[:ascii:]]/;
    _eval("UTF-8 decoding", sub {
        $tmp = decode("UTF-8", ${ $_[0] }, FB_CROAK|LEAVE_SRC);
    }, \$_[0]);
    return($class->destringify($tmp));
}

sub deserialize_ref : method {
    my($class, $tmp);

    $class = shift(@_);
    validate_pos(@_, { type => SCALARREF })
        unless @_ == 1 and defined($_[0]) and ref($_[0]) eq "SCALAR";
    return($class->destringify_ref($_[0])) unless ${ $_[0] } =~ /[^[:ascii:]]/;
    _eval("UTF-8 decoding", sub {
        $tmp = decode("UTF-8", ${ $_[0] }, FB_CROAK|LEAVE_SRC);
    }, $_[0]);
    return($class->destringify($tmp));
}

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    %exported = ("_require" => 1);
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__