File Coverage

File:lib/Net/MQTT/Constants.pm
Coverage:98.2%

linestmtbrancondsubpodtimecode
1
3
3
3
3.95847846209746e+15
22
235
use strict;
2
3
3
3
38
14
517
use warnings;
3package Net::MQTT::Constants;
4
5# ABSTRACT: Module to export constants for MQTT protocol
6
7 - 15
=head1 SYNOPSIS

  use Net::MQTT::Constants;

=head1 DESCRIPTION

Module to export constants for MQTT protocol.

=cut
16
17
3
3
3
40
19
1062
use Carp qw/croak/;
18
19my %constants =
20  (
21   MQTT_CONNECT => 0x1,
22   MQTT_CONNACK => 0x2,
23   MQTT_PUBLISH => 0x3,
24   MQTT_PUBACK => 0x4,
25   MQTT_PUBREC => 0x5,
26   MQTT_PUBREL => 0x6,
27   MQTT_PUBCOMP => 0x7,
28   MQTT_SUBSCRIBE => 0x8,
29   MQTT_SUBACK => 0x9,
30   MQTT_UNSUBSCRIBE => 0xa,
31   MQTT_UNSUBACK => 0xb,
32   MQTT_PINGREQ => 0xc,
33   MQTT_PINGRESP => 0xd,
34   MQTT_DISCONNECT => 0xe,
35
36   MQTT_QOS_AT_MOST_ONCE => 0x0,
37   MQTT_QOS_AT_LEAST_ONCE => 0x1,
38   MQTT_QOS_EXACTLY_ONCE => 0x2,
39
40   MQTT_CONNECT_ACCEPTED => 0,
41   MQTT_CONNECT_REFUSED_UNACCEPTABLE_PROTOCOL_VERSION => 1,
42   MQTT_CONNECT_REFUSED_IDENTIFIER_REJECTED => 2,
43   MQTT_CONNECT_REFUSED_SERVER_UNAVAILABLE => 3,
44   MQTT_CONNECT_REFUSED_BAD_USER_NAME_OR_PASSWORD => 4,
45   MQTT_CONNECT_REFUSED_NOT_AUTHORIZED => 5,
46  );
47
48sub import {
49
3
3
3
42
27
6760
  no strict qw/refs/; ## no critic
50
42
461
  my $pkg = caller(0);
51
42
829
  foreach (keys %constants) {
52
966
4783
    my $v = $constants{$_};
53
966
966
0
19126
15405
0
    *{$pkg.'::'.$_} = sub () { $v };
54  }
55
42
473
  foreach (qw/decode_byte encode_byte
56              decode_short encode_short
57              decode_string encode_string
58              decode_remaining_length encode_remaining_length
59              qos_string
60              message_type_string
61              dump_string
62              connect_return_code_string
63             /) {
64
504
504
504
1918
34291
4017
    *{$pkg.'::'.$_} = \&{$_};
65  }
66}
67
68 - 76
=head1 C<FUNCTIONS>

=head2 C<decode_remaining_length( $data, \$offset )>

Calculates the C<remaining length> from the bytes in C<$data> starting
at the offset read from the scalar reference.  The offset reference is
subsequently incremented by the number of bytes processed.

=cut
77
78sub decode_remaining_length {
79
25
247
  my ($data, $offset) = @_;
80
25
157
  my $multiplier = 1;
81
25
140
  my $v = 0;
82
25
133
  my $d;
83
25
164
  do {
84
30
236
    $d = decode_byte($data, $offset);
85
28
232
    $v += ($d&0x7f) * $multiplier;
86
28
350
    $multiplier *= 128;
87  } while ($d&0x80);
88
23
648
  $v
89}
90
91 - 96
=head2 C<encode_remaining_length( $length )>

Calculates the C<remaining length> bytes from the length, C<$length>,
and returns the packed bytes as a string.

=cut
97
98sub encode_remaining_length {
99
42
313
  my $v = shift;
100
42
227
  my $o;
101
42
281
  my $d;
102
42
259
  do {
103
44
302
    $d = $v % 128;
104
44
368
    $v = int($v/128);
105
44
370
    if ($v) {
106
2
15
      $d |= 0x80;
107    }
108
44
340
    $o .= encode_byte($d);
109  } while ($d&0x80);
110
42
1166
  $o;
111}
112
113 - 119
=head2 C<decode_byte( $data, \$offset )>

Returns a byte by unpacking it from C<$data> starting at the offset
read from the scalar reference.  The offset reference is subsequently
incremented by the number of bytes processed.

=cut
120
121sub decode_byte {
122
68
1686
  my ($data, $offset) = @_;
123
68
2348
  croak 'decode_byte: insufficient data' unless (length $data >= $$offset+1);
124
65
820
  my $res = unpack 'C', substr $data, $$offset, 1;
125
65
430
  $$offset++;
126
65
1264
  $res
127}
128
129 - 133
=head2 C<encode_byte( $byte )>

Returns a packed byte.

=cut
134
135sub encode_byte {
136
110
3384
  pack 'C', $_[0];
137}
138
139 - 145
=head2 C<decode_short( $data, \$offset )>

Returns a short (two bytes) by unpacking it from C<$data> starting at
the offset read from the scalar reference.  The offset reference is
subsequently incremented by the number of bytes processed.

=cut
146
147sub decode_short {
148
29
7651
  my ($data, $offset) = @_;
149
29
394
  croak 'decode_short: insufficient data' unless (length $data >= $$offset+2);
150
27
294
  my $res = unpack 'n', substr $data, $$offset, 2;
151
27
179
  $$offset += 2;
152
27
442
  $res;
153}
154
155 - 159
=head2 C<encode_short( $short )>

Returns a packed short (two bytes).

=cut
160
161sub encode_short {
162
24
756
  pack 'n', $_[0];
163}
164
165 - 172
=head2 C<decode_string( $data, \$offset )>

Returns a string (short length followed by length bytes) by unpacking
it from C<$data> starting at the offset read from the scalar
reference.  The offset reference is subsequently incremented by the
number of bytes processed.

=cut
173
174sub decode_string {
175
16
4319
  my ($data, $offset) = @_;
176
16
128
  my $len = decode_short($data, $offset);
177
15
171
  croak 'decode_string: insufficient data'
178    unless (length $data >= $$offset+$len);
179
14
90
  my $res = substr $data, $$offset, $len;
180
14
75
  $$offset += $len;
181
14
397
  $res;
182}
183
184 - 189
=head2 C<encode_string( $string )>

Returns a packed string (length as a short and then the bytes of the
string).

=cut
190
191sub encode_string {
192
28
901
  pack "n/a*", $_[0];
193}
194
195 - 199
=head2 C<qos_string( $qos_value )>

Returns a string describing the given QoS value.

=cut
200
201sub qos_string {
202
48
1974
  [qw/at-most-once at-least-once exactly-once reserved/]->[$_[0]]
203}
204
205 - 209
=head2 C<message_type_string( $message_type_value )>

Returns a string describing the given C<message_type> value.

=cut
210
211sub message_type_string {
212
42
2613
  [qw/Reserved0 Connect ConnAck Publish PubAck PubRec PubRel PubComp
213      Subscribe SubAck Unsubscribe UnsubAck PingReq PingResp Disconnect
214      Reserved15/]->[$_[0]];
215}
216
217 - 222
=head2 C<dump_string( $data )>

Returns a string representation of arbitrary data - as a string if it
contains only printable characters or as a hex dump otherwise.

=cut
223
224sub dump_string {
225
42
779
  my $data = shift || '';
226
42
763
  my $prefix = shift || '';
227
42
251
  $prefix .= ' ';
228
42
209
  my @lines;
229
42
425
  while (length $data) {
230
26
203
    my $d = substr $data, 0, 16, '';
231
26
274
    my $line = unpack 'H*', $d;
232
26
1982
    $line =~ s/([A-F0-9]{2})/$1 /ig;
233
26
300
    $d =~ s/[^ -~]/./g;
234
26
407
    $line = sprintf "%-48s %s", $line, $d;
235
26
320
    push @lines, $line
236  }
237
42
1578
  scalar @lines ? "\n".$prefix.(join "\n".$prefix, @lines) : ''
238}
239
240
241 - 245
=head2 C<connect_return_code_string( $return_code_value )>

Returns a string describing the given C<connect_return_code> value.

=cut
246
247sub connect_return_code_string {
248  [
249
4
316
   'Connection Accepted',
250   'Connection Refused: unacceptable protocol version',
251   'Connection Refused: identifier rejected',
252   'Connection Refused: server unavailable',
253   'Connection Refused: bad user name or password',
254   'Connection Refused: not authorized',
255  ]->[$_[0]] || 'Reserved'
256}