File Coverage

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

Criterion	Covered	Total	%
statement	12	84	14.2
branch	0	28	0.0
condition	0	10	0.0
subroutine	4	7	57.1
pod	2	3	66.6
total	18	132	13.6

package XAS::Lib::Stomp::Parser;

our $VERSION = '0.03';

use XAS::Lib::Stomp::Frame;
use XAS::Constants ':stomp';

use XAS::Class
  debug     => 0,
  version   => $VERSION,
  base      => 'XAS::Base',
  mixin     => 'XAS::Lib::Mixins::Bufops',
  utils     => 'trim',
  vars => {
    PARAMS => {
      -target  => { optional => 1, default => undef, regex => STOMP_LEVELS },
    }
  }
;


my $HEADER = STOMP_HEADER;
my $CNTRL  = STOMP_CNTRL;
my $BEOH   = STOMP_BEOH;
my $EOF    = STOMP_EOF;
my $EOH    = STOMP_EOH;
my $EOL    = STOMP_EOL;

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

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

sub parse {
    my $self   = shift;
    my $buffer = shift;

    my $line;
    my $length;
    my $clength;
    my $count = 0;
    my $frame = undef;

    use bytes;

    $self->{buffer} .= $buffer;

    $self->log->debug('stomp-parser: begin');
#    $self->log->debug(hexdump($self->{buffer}));

    # A valid frame is usually this:
    #
    # command    - command
    # header     - 0 or more
    #            - seperator
    # body       - body
    #
    # as of v1.1 this is a valid frame
    #
    #
    #
    # and is used as a NOOP, which is used as a protocol keepalive. This
    # module will create a fake 'NOOP' command for that frame. Frame
    # stringification does the right thing.
    #
    # All current versions define  as \000.
    #
    # In v1.0 and v1.1,  was defined as NEWLINE, which is \012, but,
    # common usage was \n, which is platform specific, hence the $EOL, $EOH
    # and $BEOH regexs to match against.
    #
    # v1.2 changes  to \015\012
    #

    for (;;) {

        $self->log->debug('stomp-parser: state = ' . $self->{state});

        if ($self->{state} eq 'command') {

            # start of the frame
            # check for a valid buffer, must have a EOL someplace.

            if ($line = $self->buf_get_line(\$self->{buffer}, $EOL)) {

                $self->log->debug('stomp-parser: command');
#                $self->log->debug(hexdump($line));

                $line = trim($line);

                $self->{command} = ($line eq '') ? 'NOOP' : $line;
                $self->{state} = 'headers';

            } else { last; }

        } elsif ($self->{state} eq 'headers') {

            # start of the headers, they last until a standalone
            # or  is reached.

            $self->log->debug("stomp-parser: header");

            $length = length($self->{buffer});

            $self->{buffer} =~ m/$EOH/g;
            $clength = pos($self->{buffer}) || -1;

            $self->log->debug("stomp-parser: end of headers, length: $clength");

            if ($clength == -1) {

                pos($self->{buffer}) = 0;
                $self->{buffer} =~ m/$BEOH/g;
                $clength = pos($self->{buffer}) || -1;

                $self->log->debug("stomp-parser: end of frame, length: $clength");

            }

            if (($clength != -1) && ($clength <= $length)) {

                $line = $self->buf_slurp(\$self->{buffer}, $clength);
#                $self->log->debug(hexdump($line));

                while ($line =~ s/^$HEADER//) {

                    $self->log->debug('stomp-parser: valid header');

                    my $key   = lc($1);
                    my $value = trim($2);

                    # v1.2 says that the first defined header is
                    # to be honored. v1.0 and v1.1 implies that
                    # the last defined header is honored. The duplictes
                    # are discarded.

                    if ($self->target < 1.2) {

                        $self->{headers}->{$key} = $value;

                    } else {

                        unless (defined($self->{headers}->{$key})) {

                            $self->{headers}->{$key} = $value;

                        }

                    }

                    $line =~ s/$EOL//;

                }

                $self->{state} = 'body';

            } else { last; }

        } elsif ($self->{state} eq 'body') {

            $self->log->debug('stomp-parser: body');

            # start of the body, determine wither to use
            # content-length or EOF to find the end

            $length = length($self->{buffer});

            if ($clength = $self->{headers}->{'content-length'}) {

                $self->log->debug('stomp-parser: using content-length');

                if ($clength <= $length) {

                    $self->{body} = $self->buf_slurp(\$self->{buffer}, $clength);
                    $self->{state} = 'frame';

                } else { last; }

            } else {

                $self->log->debug('stomp-parser: using EOF');

                $clength = index($self->{buffer}, $EOF);

                if (($clength != -1) && ($clength <= $length)) {

                    $self->{body} = $self->buf_get_line(\$self->{buffer}, $EOF);
                    chop $self->{body};
                    $self->{state} = 'frame';

                } else { last; }

            }

        } elsif ($self->{state} eq 'frame') {

            $self->log->debug('stomp-parser: building frame');

            # clear out inter-frame crap and create the object.

            $self->{buffer} =~ s/^$CNTRL//;

            $frame = XAS::Lib::Stomp::Frame->new(
                -command => $self->{command},
                -headers => $self->{headers},
                -body    => $self->{body}
            );

            # reset ourselves

            $count = 0;

            delete $self->{command};
            delete $self->{headers};
            delete $self->{body};

            $self->{state} = 'command';

        }

    }

    return $frame;

}

sub get_pending {
    my $self = shift;

    return $self->{buffer};

}

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

sub init {
    my $class = shift;

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

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

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

    }

    $self->{state} = 'command';

    return $self;

}

1;

__END__