File Coverage

blib/lib/Net/Stomp/Frame.pm
Criterion Covered Total %
statement 48 55 87.2
branch 15 22 68.1
condition 4 5 80.0
subroutine 9 9 100.0
pod 3 3 100.0
total 79 94 84.0


line stmt bran cond sub pod time code
1             package Net::Stomp::Frame;
2 11     11   76 use strict;
  11         23  
  11         324  
3 11     11   53 use warnings;
  11         20  
  11         579  
4              
5             our $VERSION='0.61';
6              
7 11     11   97 use base 'Class::Accessor::Fast';
  11         30  
  11         6053  
8             __PACKAGE__->mk_accessors(qw(command headers body));
9              
10             BEGIN {
11 11     11   88 for my $header (
12             qw(destination exchange content-type content-length message-id reply-to))
13             {
14 66         120 my $method = $header;
15 66         178 $method =~ s/-/_/g;
16 11     11   32220 no strict 'refs';
  11         28  
  11         895  
17             *$method = sub {
18 18     18   22512 my $self = shift;
19 18 100       197 $self->headers->{$header} = shift if @_;
20 18         430 $self->headers->{$header};
21 66         6847 };
22             }
23             }
24              
25             sub new {
26 167     167 1 22939 my $class = shift;
27 167         645 my $self = $class->SUPER::new(@_);
28 167 100       4628 $self->headers({}) unless defined $self->headers;
29 167         1340 return $self;
30             }
31              
32             sub as_string {
33 77     77 1 13285 my $self = shift;
34 77         1446 my $command = $self->command;
35 77         1531 my $headers = $self->headers;
36 77         1509 my $body = $self->body;
37 77         426 my $frame = $command . "\n";
38              
39             # insert a content-length header
40 77         125 my $bytes_message = 0;
41 77 50       204 if ( $headers->{bytes_message} ) {
42 0         0 $bytes_message = 1;
43 0         0 delete $headers->{bytes_message};
44 0         0 $headers->{"content-length"} = length( $self->body );
45             }
46              
47 77 50       127 while ( my ( $key, $value ) = each %{ $headers || {} } ) {
  169         664  
48 92 50       383 $frame .= $key . ':' . (defined $value ? $value : '') . "\n";
49             }
50 77         147 $frame .= "\n";
51 77   100     284 $frame .= $body || '';
52 77         323 $frame .= "\0";
53             }
54              
55             sub parse {
56 56     56 1 1003 my ($class,$string) = @_;
57              
58 56         330 $string =~ s{
59             \A\s*
60             ([A-Z]+)\n #command
61             ((?:[^\n]+\n)*)\n # header block
62             }{}smx;
63 56         214 my ($command,$headers_block) = ($1,$2);
64              
65 56 100       150 return unless $command;
66              
67 50         117 my ($headers,$body);
68 50 100       115 if ($headers_block) {
69 49         202 foreach my $line (split(/\n/, $headers_block)) {
70 62         287 my ($key, $value) = split(/\s*:\s*/, $line, 2);
71 62         241 $headers->{$key} = $value;
72             }
73             }
74              
75 50 50 66     442 if ($headers && $headers->{'content-length'}) {
    50          
76 0 0       0 if (length($string) >= $headers->{'content-length'}) {
77             $body = substr($string,
78             0,
79 0         0 $headers->{'content-length'},
80             '' );
81             }
82 0         0 else { return } # not enough body
83             } elsif ($string =~ s/\A(.*?)\0//s) {
84             # No content-length header.
85 50 100       178 $body = $1 if length($1);
86             }
87 0         0 else { return } # no body
88              
89 50         251 return $class->new({
90             command => $command,
91             headers => $headers,
92             body => $body,
93             });
94             }
95              
96             1;
97              
98             __END__