File Coverage

blib/lib/Net/MQTT/Constants.pm
Criterion Covered Total %
statement 73 74 98.6
branch 12 12 100.0
condition 4 4 100.0
subroutine 17 18 94.4
pod 12 12 100.0
total 118 120 98.3


line stmt bran cond sub pod time code
1 3     3   35423 use strict;
  3         6  
  3         104  
2 3     3   13 use warnings;
  3         3  
  3         158  
3             package Net::MQTT::Constants;
4             $Net::MQTT::Constants::VERSION = '1.143260';
5             # ABSTRACT: Module to export constants for MQTT protocol
6              
7              
8 3     3   12 use Carp qw/croak/;
  3         3  
  3         317  
9              
10             my %constants =
11             (
12             MQTT_CONNECT => 0x1,
13             MQTT_CONNACK => 0x2,
14             MQTT_PUBLISH => 0x3,
15             MQTT_PUBACK => 0x4,
16             MQTT_PUBREC => 0x5,
17             MQTT_PUBREL => 0x6,
18             MQTT_PUBCOMP => 0x7,
19             MQTT_SUBSCRIBE => 0x8,
20             MQTT_SUBACK => 0x9,
21             MQTT_UNSUBSCRIBE => 0xa,
22             MQTT_UNSUBACK => 0xb,
23             MQTT_PINGREQ => 0xc,
24             MQTT_PINGRESP => 0xd,
25             MQTT_DISCONNECT => 0xe,
26              
27             MQTT_QOS_AT_MOST_ONCE => 0x0,
28             MQTT_QOS_AT_LEAST_ONCE => 0x1,
29             MQTT_QOS_EXACTLY_ONCE => 0x2,
30              
31             MQTT_CONNECT_ACCEPTED => 0,
32             MQTT_CONNECT_REFUSED_UNACCEPTABLE_PROTOCOL_VERSION => 1,
33             MQTT_CONNECT_REFUSED_IDENTIFIER_REJECTED => 2,
34             MQTT_CONNECT_REFUSED_SERVER_UNAVAILABLE => 3,
35             MQTT_CONNECT_REFUSED_BAD_USER_NAME_OR_PASSWORD => 4,
36             MQTT_CONNECT_REFUSED_NOT_AUTHORIZED => 5,
37             );
38              
39             sub import {
40 3     3   12 no strict qw/refs/; ## no critic
  3         3  
  3         2081  
41 42     42   90 my $pkg = caller(0);
42 42         216 foreach (keys %constants) {
43 966         798 my $v = $constants{$_};
44 966     0   3347 *{$pkg.'::'.$_} = sub () { $v };
  966         3227  
  0         0  
45             }
46 42         101 foreach (qw/decode_byte encode_byte
47             decode_short encode_short
48             decode_string encode_string
49             decode_remaining_length encode_remaining_length
50             qos_string
51             message_type_string
52             dump_string
53             connect_return_code_string
54             /) {
55 504         355 *{$pkg.'::'.$_} = \&{$_};
  504         7941  
  504         688  
56             }
57             }
58              
59              
60             sub decode_remaining_length {
61 25     25 1 34 my ($data, $offset) = @_;
62 25         28 my $multiplier = 1;
63 25         25 my $v = 0;
64 25         25 my $d;
65 25         20 do {
66 30         42 $d = decode_byte($data, $offset);
67 28         41 $v += ($d&0x7f) * $multiplier;
68 28         63 $multiplier *= 128;
69             } while ($d&0x80);
70 23         51 $v
71             }
72              
73              
74             sub encode_remaining_length {
75 42     42 1 32 my $v = shift;
76 42         35 my $o;
77             my $d;
78 42         36 do {
79 44         45 $d = $v % 128;
80 44         66 $v = int($v/128);
81 44 100       64 if ($v) {
82 2         3 $d |= 0x80;
83             }
84 44         68 $o .= encode_byte($d);
85             } while ($d&0x80);
86 42         76 $o;
87             }
88              
89              
90             sub decode_byte {
91 68     68 1 431 my ($data, $offset) = @_;
92 68 100       708 croak 'decode_byte: insufficient data' unless (length $data >= $$offset+1);
93 65         114 my $res = unpack 'C', substr $data, $$offset, 1;
94 65         62 $$offset++;
95 65         105 $res
96             }
97              
98              
99             sub encode_byte {
100 110     110 1 337 pack 'C', $_[0];
101             }
102              
103              
104             sub decode_short {
105 29     29 1 469 my ($data, $offset) = @_;
106 29 100       326 croak 'decode_short: insufficient data' unless (length $data >= $$offset+2);
107 27         49 my $res = unpack 'n', substr $data, $$offset, 2;
108 27         30 $$offset += 2;
109 27         48 $res;
110             }
111              
112              
113             sub encode_short {
114 24     24 1 63 pack 'n', $_[0];
115             }
116              
117              
118             sub decode_string {
119 16     16 1 711 my ($data, $offset) = @_;
120 16         23 my $len = decode_short($data, $offset);
121 15 100       173 croak 'decode_string: insufficient data'
122             unless (length $data >= $$offset+$len);
123 14         16 my $res = substr $data, $$offset, $len;
124 14         14 $$offset += $len;
125 14         37 $res;
126             }
127              
128              
129             sub encode_string {
130 28     28 1 89 pack "n/a*", $_[0];
131             }
132              
133              
134             sub qos_string {
135 48     48 1 173 [qw/at-most-once at-least-once exactly-once reserved/]->[$_[0]]
136             }
137              
138              
139             sub message_type_string {
140 42     42 1 337 [qw/Reserved0 Connect ConnAck Publish PubAck PubRec PubRel PubComp
141             Subscribe SubAck Unsubscribe UnsubAck PingReq PingResp Disconnect
142             Reserved15/]->[$_[0]];
143             }
144              
145              
146             sub dump_string {
147 42   100 42 1 103 my $data = shift || '';
148 42   100     111 my $prefix = shift || '';
149 42         35 $prefix .= ' ';
150 42         27 my @lines;
151 42         78 while (length $data) {
152 26         39 my $d = substr $data, 0, 16, '';
153 26         46 my $line = unpack 'H*', $d;
154 26         328 $line =~ s/([A-F0-9]{2})/$1 /ig;
155 26         40 $d =~ s/[^ -~]/./g;
156 26         66 $line = sprintf "%-48s %s", $line, $d;
157 26         78 push @lines, $line
158             }
159 42 100       156 scalar @lines ? "\n".$prefix.(join "\n".$prefix, @lines) : ''
160             }
161              
162              
163              
164             sub connect_return_code_string {
165             [
166 4 100   4 1 28 'Connection Accepted',
167             'Connection Refused: unacceptable protocol version',
168             'Connection Refused: identifier rejected',
169             'Connection Refused: server unavailable',
170             'Connection Refused: bad user name or password',
171             'Connection Refused: not authorized',
172             ]->[$_[0]] || 'Reserved'
173             }
174              
175             __END__