File Coverage

blib/lib/MikroTik/Client/Sentence.pm
Criterion Covered Total %
statement 62 62 100.0
branch 32 34 94.1
condition 13 15 86.6
subroutine 11 11 100.0
pod 4 4 100.0
total 122 126 96.8


line stmt bran cond sub pod time code
1             package MikroTik::Client::Sentence;
2 6     6   67961 use MikroTik::Client::Mo;
  6         13  
  6         35  
3              
4 6     6   39 use Exporter 'import';
  6         23  
  6         333  
5             our @EXPORT_OK = qw(encode_sentence);
6              
7 6     6   2670 use MikroTik::Client::Query 'build_query';
  6         16  
  6         5099  
8              
9             has words => [];
10              
11             sub encode_sentence {
12 55 50   55 1 465335 shift if ref $_[0];
13 55   50     233 my ($command, $attr, $query, $tag)
      100        
14             = (shift // '', shift // {}, shift, shift);
15              
16 55         114 my $sentence = _encode_word($command);
17              
18 55   100     276 $sentence .= _encode_word("=$_=" . ($attr->{$_} // '')) for keys %$attr;
19              
20 55 100       134 if ($query) {
21 1         2 $sentence .= _encode_word($_) for @{build_query($query)};
  1         5  
22             }
23              
24 55 100       172 $sentence .= _encode_word(".tag=$tag") if $tag;
25              
26             # Closing empty word.
27 55         101 $sentence .= "\x00";
28              
29 55         162 return $sentence;
30             }
31              
32             sub fetch {
33 58     58 1 1797 my ($self, $buf) = @_;
34              
35 58 100       121 my $words = $self->is_incomplete ? $self->words : ($self->{words} = []);
36              
37 58         165 while (my $w = $self->_fetch_word($buf)) { push @$words, $w }
  175         470  
38 58         131 return $words;
39             }
40              
41             sub is_incomplete {
42 118   66 118 1 1523 return exists $_[0]->{expecting_bytes} || exists $_[0]->{partial};
43             }
44              
45             sub reset {
46 2     2 1 289 delete @{$_[0]}{qw(words expecting_bytes partial)};
  2         8  
47 2         7 return $_[0];
48             }
49              
50             sub _encode_length {
51 175     175   2638 my $len = shift;
52              
53 175         271 my $packed;
54              
55             # Screw you, mikrotik engineers, just pack length as 4 bytes. >_<
56 175 100       325 if ($len < 0x80) {
    100          
    100          
    100          
57 166         350 $packed = pack 'C', $len;
58             }
59             elsif ($len < 0x4000) {
60 6         20 $packed = pack 'n', ($len | 0x8000) & 0xffff;
61             }
62             elsif ($len < 0x200000) {
63 1         2 $len |= 0xc00000;
64 1         7 $packed = pack 'Cn', (($len >> 16) & 0xff), ($len & 0xffff);
65             }
66             elsif ($len < 0x10000000) {
67 1         5 $packed = pack 'N', ($len | 0xe0000000);
68             }
69             else {
70 1         4 $packed = pack 'CN', 0xf0, $len;
71             }
72              
73 175         568 return $packed;
74             }
75              
76             sub _encode_word {
77 170     170   832 return _encode_length(length($_[0])) . $_[0];
78             }
79              
80             sub _fetch_word {
81 235     235   958 my ($self, $buf) = @_;
82              
83 235 100       458 return $self->{expecting_bytes} = 0 unless my $buf_bytes = length $$buf;
84 234 100 100     518 if ($buf_bytes < 5 && $$buf ne "\x00") { $self->{partial} = 1; return '' }
  1         2  
  1         4  
85              
86             my $len
87             = delete $self->{partial}
88             ? _strip_length($buf)
89 233 100 100     648 : delete $self->{expecting_bytes} // _strip_length($buf);
90 233 100       451 if (length $$buf < $len) { $self->{expecting_bytes} = $len; return '' }
  3         7  
  3         10  
91              
92 230         718 return substr $$buf, 0, $len, '';
93             }
94              
95             sub _strip_length {
96 236     236   345 my $buf = shift;
97              
98 236         605 my $len = unpack 'C', substr $$buf, 0, 1, '';
99              
100 236 100       522 if (($len & 0x80) == 0x00) {
    100          
    100          
    100          
    50          
101 215         543 return $len;
102             }
103             elsif (($len & 0xc0) == 0x80) {
104 18         25 $len &= ~0x80;
105 18         28 $len <<= 8;
106 18         35 $len += unpack 'C', substr $$buf, 0, 1, '';
107             }
108             elsif (($len & 0xe0) == 0xc0) {
109 1         2 $len &= ~0xc0;
110 1         2 $len <<= 16;
111 1         5 $len += unpack 'n', substr $$buf, 0, 2, '';
112             }
113             elsif (($len & 0xf0) == 0xe0) {
114 1         5 $len = unpack 'N', pack('C', ($len & ~0xe0)) . substr($$buf, 0, 3, '');
115             }
116             elsif (($len & 0xf8) == 0xf0) {
117 1         3 $len = unpack 'N', substr $$buf, 0, 4, '';
118             }
119              
120 21         55 return $len;
121             }
122              
123             1;
124              
125             =encoding utf8
126              
127             =head1 NAME
128              
129             MikroTik::Client::Sentence - Encode and decode API sentences
130              
131             =head1 SYNOPSIS
132              
133             use MikroTik::Client::Sentence qw(encode_sentence);
134              
135             my $command = '/interface/print';
136             my $attr = {'.proplist' => '.id,name,type'};
137             my $query = {type => ['ipip-tunnel', 'gre-tunnel'], running => 'true'};
138             my $tag = 1;
139              
140             my $bytes = encode_sentence($command, $attr, $query, $tag);
141              
142             my $sentence = MikroTik::Client::Sentence->new();
143             my $words = $sentence->fetch(\$bytes);
144             say $_ for @$words;
145              
146             =head1 DESCRIPTION
147              
148             Provides subroutines for encoding API sentences and parsing them back into words.
149              
150             =head1 METHODS
151              
152             =head2 encode_sentence
153              
154             my $bytes = encode_sentence($command, $attr, $query, $tag);
155              
156             Encodes sentence. Attributes is a hashref with attribute-value pairs. Query will
157             be parsed with L.
158              
159             Can be also called as an object method.
160              
161             =head2 fetch
162              
163             my $words = $sentence->fetch(\$buf);
164              
165             Fetches a sentence from a buffer and parses it into a list of API words. It
166             will return empty list and set L flag if amount of data in
167             a buffer is unsufficient for parsing full sentence.
168              
169             =head2 is_incomplete
170              
171             my $done = !$sentence->is_incomplete;
172              
173             Indicates that a processed buffer was incomplete and remaining amount of data was
174             insufficient to complete a sentence.
175              
176             =head2 reset
177              
178             my $sentence->reset;
179              
180             Clears an incomplete status and removes data from previous L call.
181              
182             =head1 SEE ALSO
183              
184             L
185              
186             =cut
187