File Coverage

blib/lib/Net/STOMP/Client/Frame.pm

Criterion	Covered	Total	%
statement	197	369	53.3
branch	82	206	39.8
condition	19	66	28.7
subroutine	19	28	67.8
pod	12	12	100.0
total	329	681	48.3

#+##############################################################################
#                                                                              #
# File: Net/STOMP/Client/Frame.pm                                              #
#                                                                              #
# Description: Frame support for Net::STOMP::Client                            #
#                                                                              #
#-##############################################################################

#
# module definition
#

package Net::STOMP::Client::Frame;
use 5.005; # need the four-argument form of substr()
use strict;
use warnings;
our $VERSION  = "2.5";
our $REVISION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use Encode qw();
use No::Worries::Die qw(dief);
use No::Worries::Export qw(export_control);
use No::Worries::Log qw(log_debug);
use Params::Validate qw(validate validate_pos :types);

#
# constants
#

use constant I_COMMAND => 0;
use constant I_HEADERS => 1;
use constant I_BODY    => 2; # stored as reference

#
# global variables
#

our(
    # public
    $DebugBodyLength, # the maximum length of body that will be debugged
    $StrictEncode,    # true if encoding/decoding operations should be strict
    # private
    $_HeaderNameRE,   # regular expression matching a header name (STOMP 1.0)
    %_EncMap1,        # map to \-encode some chars in the header (STOMP 1.1)
    %_DecMap1,        # map to \-decode some chars in the header (STOMP 1.1)
    $_EncSet1,        # set of chars to encode in the header (STOMP 1.1)
    %_EncMap2,        # map to \-encode some chars in the header (STOMP >= 1.2)
    %_DecMap2,        # map to \-decode some chars in the header (STOMP >= 1.2)
    $_EncSet2,        # set of chars to encode in the header (STOMP >= 1.2)
);

# public
$DebugBodyLength = 256;
$StrictEncode = undef;

# private
$_HeaderNameRE = q/[_a-zA-Z0-9\-\.]+/;
%_EncMap1 = %_EncMap2 = (
    "\r" => "\\r",
    "\n" => "\\n",
    ":"  => "\\c",
    "\\" => "\\\\",
);
delete($_EncMap1{"\r"}); # \r encoding is only for STOMP >= 1.2
%_DecMap1 = reverse(%_EncMap1);
$_EncSet1 = "[".join("", map(sprintf("\\x%02x", ord($_)), keys(%_EncMap1)))."]";
%_DecMap2 = reverse(%_EncMap2);
$_EncSet2 = "[".join("", map(sprintf("\\x%02x", ord($_)), keys(%_EncMap2)))."]";

#+++############################################################################
#                                                                              #
# helpers                                                                      #
#                                                                              #
#---############################################################################

#
# helper to guess the encoding to use from the content type header
#

sub _encoding ($) {
    my($type) = @_;

    if ($type) {
        if ($type =~ /^text\/[\w\-]+$/) {
            return("UTF-8");
        } elsif (";$type;" =~ /\;\s*charset=\"?([\w\-]+)\"?\s*\;/) {
            return($1);
        } else {
            return(undef);
        }
    } else {
        return(undef);
    }
}

#
# debugging helpers
#

sub _debug_command ($$) {
    my($what, $command) = @_;

    log_debug("%s %s frame", $what, $command);
}

sub _debug_header ($) {
    my($header) = @_;
    my($offset, $length, $line, $char);

    $length = length($header);
    $offset = 0;
    while ($offset < $length) {
        $line = "";
        while (1) {
            $char = ord(substr($header, $offset, 1));
            $offset++;
            if ($char == 0x0a) {
                last;
            } elsif (0x20 <= $char and $char <= 0x7e and $char != 0x25) {
                $line .= sprintf("%c", $char);
            } else {
                $line .= sprintf("%%%02x", $char);
            }
            last if $offset == $length;
        }
        log_debug(" H %s", $line);
    }
}

sub _debug_body ($) {
    my($body) = @_;
    my($offset, $length, $line, $ascii, $char);

    $length = length($body);
    if ($DebugBodyLength and $length > $DebugBodyLength) {
        substr($body, $DebugBodyLength, $length - $DebugBodyLength, "");
        $length = $DebugBodyLength;
    }
    $offset = 0;
    while ($length > 0) {
        $line = sprintf("%04x", $offset);
        $ascii = "";
        foreach my $index (0 .. 15) {
            if (($index & 3) == 0) {
                $line  .= " ";
                $ascii .= " ";
            }
            if ($index < $length) {
                $char = ord(substr($body, $index, 1));
                $line  .= sprintf("%02x", $char);
                $ascii .= sprintf("%c", (0x20 <= $char && $char <= 0x7e) ?
                                  $char : 0x2e);
            } else {
                $line  .= "  ";
                $ascii .= " ";
            }
        }
        log_debug(" B %s %s", $line, $ascii);
        $offset += 16;
        $length -= 16;
        substr($body, 0, 16, "");
    }
}

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

#
# constructor
#
# notes:
#  - $self->[I_COMMAND] defaults to SEND so it's always defined
#  - $self->[I_HEADERS] defaults to {} so it's always set to a hash ref
#  - $self->[I_BODY] defaults to \"" so it's always set to a scalar ref
#

my %new_options = (
    "command" => {
        optional => 1,
        type     => SCALAR,
        regex    => qr/^[A-Z]{2,16}$/,
    },
    "headers" => {
        optional => 1,
        type     => HASHREF,
    },
    "body_reference" => {
        optional => 1,
        type     => SCALARREF,
    },
    "body" => {
        optional => 1,
        type     => SCALAR,
    },
);

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

    if ($Net::STOMP::Client::NoParamsValidation) {
        ($class, %option) = @_;
    } else {
        $class = shift(@_);
        %option = validate(@_, \%new_options) if @_;
    }
    if (defined($option{"body"})) {
        # handle the convenient body option
        dief("options body and body_reference are " .
             "mutually exclusive") if $option{"body_reference"};
        $option{"body_reference"} = \ delete($option{"body"});
    }
    $option{"command"} ||= "SEND";
    $option{"headers"} ||= {};
    $option{"body_reference"} ||= \ "";
    $object = [ @option{ qw(command headers body_reference) } ];
    return(bless($object, $class));
}

#
# standard getters and setters
#

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

    $self = shift(@_);
    return($self->[I_COMMAND]) if @_ == 0;
    $value = $_[0];
    if (@_ == 1 and defined($value) and ref($value) eq ""
        and $value =~ $new_options{"command"}{"regex"}) {
        $self->[I_COMMAND] = $value;
        return($self);
    }
    # otherwise complain...
    validate_pos(@_, $new_options{"command"});
}

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

    $self = shift(@_);
    return($self->[I_HEADERS]) if @_ == 0;
    $value = $_[0];
    if (@_ == 1 and ref($value) eq "HASH") {
        $self->[I_HEADERS] = $value;
        return($self);
    }
    # otherwise complain...
    validate_pos(@_, $new_options{"headers"});
}

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

    $self = shift(@_);
    return($self->[I_BODY]) if @_ == 0;
    $value = $_[0];
    if (@_ == 1 and ref($value) eq "SCALAR") {
        $self->[I_BODY] = $value;
        return($self);
    }
    # otherwise complain...
    validate_pos(@_, $new_options{"body_reference"});
}

#
# convenient body getter and setter
#

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

    $self = shift(@_);
    return(${ $self->[I_BODY] }) if @_ == 0;
    $value = $_[0];
    if (@_ == 1 and defined($value) and ref($value) eq "") {
        $self->[I_BODY] = \$value;
        return($self);
    }
    # otherwise complain...
    validate_pos(@_, $new_options{"body"});
}

#
# convenient individual header getter and setter:
#  - $frame->header($key): get
#  - $frame->header($key, $value): set
#  - $frame->header($key, undef): delete
#

my @header_options = (
    { optional => 0, type => SCALAR },
    { optional => 1, type => SCALAR|UNDEF },
);

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

    $self = shift(@_);
    $key = $_[0];
    if (defined($key) and ref($key) eq "") {
        if (@_ == 1) {
            # get
            return($self->[I_HEADERS]{$key});
        } elsif (@_ == 2) {
            $value = $_[1];
            if (defined($value)) {
                if (ref($value) eq "") {
                    # set
                    $self->[I_HEADERS]{$key} = $value;
                    return($self);
                }
            } else {
                # delete
                delete($self->[I_HEADERS]{$key});
                return($self);
            }
        }
    }
    # otherwise complain...
    validate_pos(@_, @header_options);
}

#+++############################################################################
#                                                                              #
# parsing                                                                      #
#                                                                              #
#---############################################################################

#
# parse the given buffer reference and return a hash of pointers to frame parts
# if the frame is complete or false otherwise; an optional hash can be given to
# represent state information from a previous parse on the exact same buffer
#
# note: for STOMP <1.2, we may miss a final \r in command or header as it would
# be part of the eol; up to the caller to be strict and check for its presence
# or to simply ignore this corner case for the sake of simplicity
#

my %parse_options = (
    state => { optional => 1, type => HASHREF },
);

sub parse ($@) {  ## no critic 'ProhibitExcessComplexity'
    my($bufref, %option, $state, $index, $buflen, $eol, $tmp);

    #
    # setup
    #
    if ($Net::STOMP::Client::NoParamsValidation) {
        ($bufref, %option) = @_;
    } else {
        validate_pos(@_, { type => SCALARREF }) unless ref($_[0]) eq "SCALAR";
        $bufref = shift(@_);
        %option = validate(@_, \%parse_options) if @_;
    }
    $state = $option{state} || {};
    #
    # before: allow 0 or more end-of-line characters
    # (note: we allow \n and \r\n but also \r as EOL, this should not be a
    #  problem in practice)
    #
    unless (exists($state->{before_len})) {
        return(0) unless ${$bufref} =~ /^[\r\n]*[^\r\n]/g;
        $state->{before_len} = pos(${$bufref}) - 1;
    }
    #
    # command: everything up to the first EOL
    #
    unless (exists($state->{command_len})) {
        $state->{command_idx} = $state->{before_len};
        $index = index(${$bufref}, "\n", $state->{command_idx});
        return(0) if $index < 0;
        $state->{command_len} = $index - $state->{command_idx};
        if (substr(${$bufref}, $index - 1, 1) eq "\r") {
            $state->{command_len}--;
            $state->{command_eol} = 2;
        } else {
            $state->{command_eol} = 1;
        }
    }
    #
    # header: everything up to the first double EOL
    #
    unless (exists($state->{header_len})) {
        $state->{header_idx} = $state->{command_idx} + $state->{command_len};
        $eol = $state->{command_eol};
        $tmp = $state->{header_idx} + $eol;
        while (1) {
            $index = index(${$bufref}, "\n", $tmp);
            return(0) if $index < 0;
            if ($index == $tmp) {
                $state->{header_eol} = $eol + 1;
                last;
            } elsif ($index == $tmp + 1
                     and substr(${$bufref}, $tmp, 1) eq "\r") {
                $state->{header_eol} = $eol + 2;
                last;
            }
            $eol = substr(${$bufref}, $index - 1, 1) eq "\r" ? 2 : 1;
            $tmp = $index + 1;
        }
        $index -= $state->{header_eol} - 1;
        if ($index == $state->{header_idx}) {
            # empty header
            $state->{header_len} = 0;
        } else {
            # non-empty header
            $state->{header_idx} += $state->{command_eol};
            $state->{header_len} = $index - $state->{header_idx};
            $tmp = substr(${$bufref}, $state->{header_idx} - 1,
                          $state->{header_len} + 3);
            $state->{content_length} = $1
                if $tmp =~ /\ncontent-length *: *(\d+) *\r?\n/;
        }
    }
    #
    # body: everything up to content-length bytes or the first NULL byte
    #
    $buflen = length(${$bufref});
    $state->{body_idx} = $state->{header_idx} + $state->{header_len}
        + $state->{header_eol};
    if (exists($state->{content_length})) {
        # length is known
        return(0)
            if $buflen < $state->{body_idx} + $state->{content_length} + 1;
        $state->{body_len} = $state->{content_length};
        $tmp = substr(${$bufref}, $state->{body_idx} + $state->{body_len}, 1);
        dief("missing NULL byte at end of frame") unless $tmp eq "\0";
    } else {
        # length is not known
        $index = index(${$bufref}, "\0", $state->{body_idx});
        return(0) if $index < 0;
        $state->{body_len} = $index - $state->{body_idx};
    }
    #
    # after: allow 0 or more end-of-line characters
    # (note: we allow \n and \r\n but also \r as EOL, this should not be a
    #  problem in practice)
    #
    $state->{after_idx} = $state->{body_idx} + $state->{body_len} + 1;
    $state->{after_len} = 0;
    while ($buflen > $state->{after_idx} + $state->{after_len}) {
        $tmp = substr(${$bufref}, $state->{after_idx} + $state->{after_len}, 1);
        last unless $tmp eq "\r" or $tmp eq "\n";
        $state->{after_len}++;
    }
    $state->{total_len} = $state->{after_idx} + $state->{after_len};
    # so far so good ;-)
    return($state);
}

#+++############################################################################
#                                                                              #
# decoding                                                                     #
#                                                                              #
#---############################################################################

#
# decode the given string reference and return a frame object if the frame is
# complete or false otherwise; take the same options as parse() plus debug
# and version
#
# side effect: in case a frame is successfully decoded, the given string is
# _modified_ to remove the corresponding encoded frame
#

my %decode_options = (
    debug   => { optional => 1, type => UNDEF|SCALAR },
    state   => { optional => 1, type => HASHREF },
    strict  => { optional => 1, type => BOOLEAN },
    version => { optional => 1, type => SCALAR, regex => qr/^1\.\d$/ },
);

sub decode ($@) {  ## no critic 'ProhibitExcessComplexity'
    my($bufref, %option, $check, $state, $key, $val, $errors, $tmp, %frame);

    #
    # setup
    #
    if ($Net::STOMP::Client::NoParamsValidation) {
        ($bufref, %option) = @_;
    } else {
        validate_pos(@_, { type => SCALARREF }) unless ref($_[0]) eq "SCALAR";
        $bufref = shift(@_);
        %option = validate(@_, \%decode_options) if @_;
    }
    $option{debug} ||= "";
    $state = $option{state} || {};
    $option{strict} = $StrictEncode unless defined($option{strict});
    $option{version} ||= "1.0";
    $check = $option{strict} ? Encode::FB_CROAK : Encode::FB_DEFAULT;
    #
    # frame parsing
    #
    {
        local $Net::STOMP::Client::NoParamsValidation = 1;
        $tmp = parse($bufref, state => $state);
    }
    return(0) unless $tmp;
    #
    # frame debugging
    #
    if ($option{debug} =~ /\b(command|all)\b/) {
        $tmp = substr(${$bufref}, $state->{command_idx}, $state->{command_len});
        _debug_command("decoding", $tmp);
    }
    if ($option{debug} =~ /\b(header|all)\b/) {
        $tmp = substr(${$bufref}, $state->{header_idx}, $state->{header_len});
        _debug_header($tmp);
    }
    if ($option{debug} =~ /\b(body|all)\b/) {
        $tmp = substr(${$bufref}, $state->{body_idx}, $state->{body_len});
        _debug_body($tmp);
    }
    #
    # frame decoding (command)
    #
    $frame{"command"} =
        substr(${$bufref}, $state->{command_idx}, $state->{command_len});
    dief("invalid command: %s", $frame{"command"})
        unless $frame{"command"} =~ $new_options{"command"}{"regex"};
    #
    # frame decoding (headers)
    #
    if ($state->{header_len}) {
        $frame{"headers"} = {};
        $tmp = substr(${$bufref}, $state->{header_idx}, $state->{header_len});
        if ($option{version} ge "1.1") {
            # STOMP >=1.1 behavior: the header is assumed to be UTF-8 encoded
            $tmp = Encode::decode("UTF-8", $tmp, $check);
        }
        if ($option{version} eq "1.0") {
            # STOMP 1.0 behavior:
            #  - we arbitrarily restrict the header name as a safeguard
            #  - space surrounding the comma and at end of line is not significant
            #  - last header wins (not specified explicitly but reasonable default)
            foreach my $line (split(/\n/, $tmp)) {
                if ($line =~ /^($_HeaderNameRE)\s*:\s*(.*?)\s*$/o) {
                    $frame{"headers"}{$1} = $2;
                } else {
                    dief("invalid header: %s", $line);
                }
            }
        } elsif ($option{version} eq "1.1") {
            # STOMP 1.1 behavior:
            #  - header names and values can contain any byte except \n or :
            #  - space is significant
            #  - only the first header entry should be used
            #  - handle backslash escaping
            foreach my $line (split(/\n/, $tmp)) {
                if ($line =~ /^([^\n\:]+):([^\n\:]*)$/) {
                    ($key, $val, $errors) = ($1, $2, 0);
                } else {
                    dief("invalid header: %s", $line);
                }
                $key =~ s/(\\.)/$_DecMap1{$1}||$errors++/eg;
                $val =~ s/(\\.)/$_DecMap1{$1}||$errors++/eg;
                dief("invalid header: %s", $line) if $errors;
                $frame{"headers"}{$key} = $val
                    unless exists($frame{"headers"}{$key});
            }
        } else {
            # STOMP 1.2 behavior:
            #  - header names and values can contain any byte except \r or \n or :
            #  - space is significant
            #  - only the first header entry should be used
            #  - handle backslash escaping
            foreach my $line (split(/\r?\n/, $tmp)) {
                if ($line =~ /^([^\r\n\:]+):([^\r\n\:]*)$/) {
                    ($key, $val, $errors) = ($1, $2, 0);
                } else {
                    dief("invalid header: %s", $line)
                }
                $key =~ s/(\\.)/$_DecMap2{$1}||$errors++/eg;
                $val =~ s/(\\.)/$_DecMap2{$1}||$errors++/eg;
                dief("invalid header: %s", $line) if $errors;
                $frame{"headers"}{$key} = $val
                    unless exists($frame{"headers"}{$key});
            }
        }
    }
    #
    # frame decoding (body)
    #
    if ($state->{body_len}) {
        $tmp = substr(${$bufref}, $state->{body_idx}, $state->{body_len});
        if ($option{version} ge "1.1" and $frame{"headers"}) {
            # STOMP >=1.1 behavior: the body may be encoded
            $val = _encoding($frame{"headers"}{"content-type"});
            if ($val) {
                $tmp = Encode::decode($val, $tmp, $check);
            }
        }
        $frame{"body_reference"} = \$tmp;
    }
    #
    # so far so good
    #
    substr(${$bufref}, 0, $state->{total_len}, "");
    %{ $state } = ();
    local $Net::STOMP::Client::NoParamsValidation = 1;
    return(__PACKAGE__->new(%frame));
}

#+++############################################################################
#                                                                              #
# encoding                                                                     #
#                                                                              #
#---############################################################################

#
# encode the given frame object and return a string reference; take the same
# options as decode() except state
#

my %encode_options = (
    debug   => { optional => 1, type => UNDEF|SCALAR },
    strict  => { optional => 1, type => BOOLEAN },
    version => { optional => 1, type => SCALAR, regex => qr/^1\.\d$/ },
);

sub encode : method {  ## no critic 'ProhibitExcessComplexity'
    my($self, %option, $check, $header, $tmp);
    my($body, $bodyref, $bodylen, $conlen, $key, $val);

    #
    # setup
    #
    if ($Net::STOMP::Client::NoParamsValidation) {
        ($self, %option) = @_;
    } else {
        $self = shift(@_);
        %option = validate(@_, \%encode_options) if @_;
    }
    $option{debug} ||= "";
    $option{strict} = $StrictEncode unless defined($option{strict});
    $option{version} ||= "1.0";
    $check = $option{strict} ? Encode::FB_CROAK : Encode::FB_DEFAULT;
    #
    # body encoding (must be done first because of the content-length header)
    #
    if ($option{version} ge "1.1") {
        $tmp = _encoding($self->[I_HEADERS]{"content-type"});
    } else {
        $tmp = undef;
    }
    if ($tmp) {
        $body = Encode::encode($tmp, ${ $self->[I_BODY] },
                               $check | Encode::LEAVE_SRC);
        $bodyref = \$body;
    } else {
        $bodyref = $self->[I_BODY];
    }
    $bodylen = length(${ $bodyref });
    #
    # content-length header handling
    #
    $tmp = $self->[I_HEADERS]{"content-length"};
    if (defined($tmp)) {
        # content-length is defined: we use it unless it is the empty string
        # (which means do not set the content-length even with a body)
        $conlen = $tmp unless $tmp eq "";
    } else {
        # content-length is not defined (default behavior): we set it to the
        # body length only if the body is not empty
        $conlen = $bodylen unless $bodylen == 0;
    }
    #
    # header encoding
    #
    $tmp = $self->[I_HEADERS];
    if ($option{version} eq "1.0") {
        # STOMP 1.0 behavior: no backslash escaping
        $header = join("\n", map($_ . ":" . $tmp->{$_},
                       grep($_ ne "content-length", keys(%{ $tmp }))), "");
    } elsif ($option{version} eq "1.1") {
        # STOMP 1.1 behavior: backslash escaping
        $header = "";
        while (($key, $val) = each(%{ $tmp })) {
            next if $key eq "content-length";
            $key =~ s/($_EncSet1)/$_EncMap1{$1}/ego;
            $val =~ s/($_EncSet1)/$_EncMap1{$1}/ego;
            $header .= $key . ":" . $val . "\n";
        }
    } else {
        # STOMP 1.2 behavior: backslash escaping
        $header = "";
        while (($key, $val) = each(%{ $tmp })) {
            next if $key eq "content-length";
            $key =~ s/($_EncSet2)/$_EncMap2{$1}/ego;
            $val =~ s/($_EncSet2)/$_EncMap2{$1}/ego;
            $header .= $key . ":" . $val . "\n";
        }
    }
    $header .= "content-length:" . $conlen . "\n" if defined($conlen);
    if ($option{version} ge "1.1") {
        # STOMP >=1.1 behavior: the header must be UTF-8 encoded
        $header = Encode::encode("UTF-8", $header, $check);
    }
    #
    # frame debugging
    #
    if ($option{debug} =~ /\b(command|all)\b/) {
        _debug_command("encoding", $self->[I_COMMAND]);
    }
    if ($option{debug} =~ /\b(header|all)\b/) {
        _debug_header($header);
    }
    if ($option{debug} =~ /\b(body|all)\b/) {
        _debug_body(${ $bodyref });
    }
    #
    # assemble all the parts
    #
    $tmp = $self->[I_COMMAND] . "\n" . $header . "\n" . ${ $bodyref } . "\0";
    # return a reference to the encoded frame
    return(\$tmp);
}

#
# FIXME: compatibility hack for Net::STOMP::Client 1.x (to be removed one day)
#

sub check : method {
    return(1);
}

#+++############################################################################
#                                                                              #
# integration with Messaging::Message                                          #
#                                                                              #
#---############################################################################

#
# transform a frame into a message
#

sub messagify : method {
    my($self) = @_;

    unless ($Messaging::Message::VERSION) {
        eval { require Messaging::Message };
        dief("cannot load Messaging::Message: %s", $@) if $@;
    }
    return(Messaging::Message->new(
        "header"   => $self->headers(),
        "body_ref" => $self->body_reference(),
        "text"     => _encoding($self->header("content-type")) ? 1 : 0,
    ));
}

#
# transform a message into a frame
#

sub demessagify ($) {
    my($message, $frame, $content_type);

    # FIXME: compatibility hack for Net::STOMP::Client 1.x (to be removed one day)
    if (@_ == 1) {
        # normal API, to become: my($message) = @_
        $message = $_[0];
    } elsif (@_ == 2 and $_[0] eq "Net::STOMP::Client::Frame") {
        # old API, was a class method
        shift(@_);
        $message = $_[0];
    }
    validate_pos(@_, { isa => "Messaging::Message" });
    $frame = __PACKAGE__->new(
        "command"        => "SEND",
        "headers"        => $message->header(),
        "body_reference" => $message->body_ref(),
    );
    # handle the text attribute wrt the content-type header
    $content_type = $frame->header("content-type");
    if (defined($content_type)) {
        # make sure the content-type is consistent with the message type
        if (_encoding($content_type)) {
            dief("unexpected text content-type for binary message: %s",
                 $content_type) unless $message->text();
        } else {
            dief("unexpected binary content-type for text message: %s",
                 $content_type) if $message->text();
        }
    } else {
        # set a text content-type if it is missing (this is needed by STOMP >=1.1)
        $frame->header("content-type", "text/unknown") if $message->text();
    }
    return($frame);
}

#
# export control
#

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

    $pkg = shift(@_);
    grep($exported{$_}++, qw(demessagify));
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__END__