File Coverage

blib/lib/XAS/Lib/Stomp/Frame.pm

Criterion	Covered	Total	%
statement	30	121	24.7
branch	0	28	0.0
condition	0	2	0.0
subroutine	10	20	50.0
pod	2	2	100.0
total	42	173	24.2

package XAS::Lib::Stomp::Frame;

our $VERSION = '0.03';

use XAS::Constants 'CRLF LF :stomp';

use XAS::Class
  debug     => 0,
  version   => $VERSION,
  base      => 'XAS::Base',
  utils     => 'dotid',
  accessors => 'eol header',
  mutators  => 'command body',
  codec     => 'unicode',
  vars => {
    PARAMS => {
      -body    => { optional => 1, default => undef },
      -command => { optional => 1, default => undef },
      -headers => { optional => 1, default => undef },
      -target  => { optional => 1, default => undef, regex => STOMP_LEVELS },
    }
  }
;

our %ENCODE_MAP = (
    "\r" => "\\r",
    "\n" => "\\n",
    ":"  => "\\c",
    "\\" => "\\\\",
);

our %DECODE_MAP = reverse %ENCODE_MAP;

#use Data::Dumper;
#use Data::Hexdumper;

# ----------------------------------------------------------------------
# Public Methods
# ----------------------------------------------------------------------

sub as_string {
    my $self = shift;

    # protocol spec is unclear about the case of the command,
    # so uppercase the command, Why, just because I can.

    my $frame;
    my $command = uc($self->command);
    my $headers = $self->header->devolve;
    my $body    = $self->body;

    # special handling for NOOPs

    if ($command eq 'NOOP') {

        $command = '';
        $headers = {};
        $body    = '';

    }

    if ($self->target > 1.1) {

        $frame = encode('utf8', $command) . $self->eol;

    } else {

        $frame = $command . $self->eol;

    }

    # v1.0 and v1.1 is unclear about spaces between headers and values
    # nor the case of the header.
    #
    # v1.2 says there should be no 'padding' in headers and values, not
    # sure what 'padding' means. It also adds the capability to 'escape'
    # certain values. Please see %ENCODE_MAP and %DECODE_MAP for those
    # values.
    #
    # So add a space and lowercase the header. Why, just because I can.

    if (keys %{$headers}) {

        $self->_encode_headers(\$headers) if ($self->target > 1.1);

        while (my ($key, $value) = each(%{$headers})) {

            if (defined($value)) {

                $frame .= lc($key) . ': ' . $value . $self->eol();

            }

        }

    } else {

        $frame .= $self->eol();

    }

    $frame .= $self->eol();
    $frame .= $body;
    $frame .= STOMP_EOF;

    return $frame;

}

# ----------------------------------------------------------------------
# Private Methods
# ----------------------------------------------------------------------

sub init {
    my $class = shift;

    my $self = $class->SUPER::init(@_);

    unless (defined($self->{'target'})) {

        $self->{'target'} = $self->env->mqlevel;

    }

    my $headers = $self->headers || {};

    $self->{'eol'} = ($self->target > 1.1) ? CRLF : LF;

    $self->_decode_headers(\$headers) if ($self->target > 1.1);
    $self->{'header'} = XAS::Lib::Stomp::Frame::Headers->new($headers);

    return $self;

}

sub _encode_headers {
    my $self    = shift;
    my $headers = shift; # a pointer to a reference of a hash, oh my...

    my $ENCODE_KEYS = '['.join('', map(sprintf('\\x%02x', ord($_)), keys(%ENCODE_MAP))).']';

    while (my ($k, $v) = each(%$$headers)) {

        $k = encode('utf8', $k);
        $v = encode('utf8', $v);

        $v =~ s/($ENCODE_KEYS)/$ENCODE_MAP{$1}/ego;
        $k =~ s/($ENCODE_KEYS)/$ENCODE_MAP{$1}/ego;

        $$headers->{$k} = $v;

    }

}

sub _decode_headers {
    my $self    = shift;
    my $headers = shift; # a pointer to a reference of a hash, oh my...

    while (my ($k, $v) = each(%$$headers)) {

        $k = decode('utf8', $k);
        $v = decode('utf8', $v);

        if ($v =~ m/(\\.)/) {

            unless ($v =~ s/(\\.)/$DECODE_MAP{$1}/eg) {

                $self->throw_msg(
                    dotid($self->class) . '.decode_header.badval',
                    'stomp_badval',
                );

            }

        }

        if ($k =~ m/(\\.)/) {

            unless ($k =~ s/(\\.)/$DECODE_MAP{$1}/eg) {

                $self->throw_msg(
                    dotid($self->class) . '.decode_header.badkey',
                    'stomp_badkey'
                );

            }

        }

        $$headers->{$k} = $v;

    }

}

package # hide from pause...
      XAS::Lib::Stomp::Frame::Headers;

our $VERSION = '0.02';

use XAS::Lib::Set::Light;

use XAS::Class
  debug     => 0,
  version   => $VERSION,
  base      => 'XAS::Base',
  constants => 'REFS',
  accessors => 'methods',
;

#use Data::Dumper;

sub remove {
    my ($self, $key) = @_;

    $self->methods->remove($key);

    delete($self->{$key});

    no warnings;
    no strict REFS;

    *$key = undef;

}

sub add {
    my ($self, $key, $value) = @_;

    $key =~ s/-/_/g;

    $self->{$key} = $value;
    $self->methods->insert($key);

    no warnings;
    no strict REFS;

    *$key = sub {
        my $self = shift;
        $self->{$key} = shift if @_;
        return $self->{$key};
    };

}

sub devolve {
    my $self = shift;

    my $value;
    my $header = {};

    foreach my $key ($self->methods->items()) {

        $value = $self->{$key};
        $key =~ s/_/-/g;
        $header->{$key} = $value;

    }

    return $header;

}

sub init {
    my $self    = shift;
    my $configs = shift;

    $self->{'config'}  = $configs;
	$self->{'methods'} = XAS::Lib::Set::Light->new();

    # turn frame headers into mutators of there values

    while (my ($key, $value) = each(%$configs)) {

        $key =~ s/-/_/g;

        $self->{$key} = $value;
        $self->methods->insert($key);

        no warnings;
        no strict REFS;

        *$key = sub {
            my $self = shift;
            $self->{$key} = shift if @_;
            return $self->{$key};
        };

    }

    return $self;

}

1;

__END__