File Coverage

blib/lib/MikroTik/Client/Query.pm
Criterion Covered Total %
statement 62 62 100.0
branch 44 46 95.6
condition 18 25 72.0
subroutine 10 10 100.0
pod 1 1 100.0
total 135 144 93.7


line stmt bran cond sub pod time code
1             package MikroTik::Client::Query;
2 7     7   70051 use MikroTik::Client::Mo;
  7         49  
  7         42  
3              
4 7     7   48 use Exporter 'import';
  7         14  
  7         209  
5 7     7   48 use Scalar::Util 'blessed';
  7         15  
  7         7280  
6              
7             our @EXPORT_OK = ('build_query');
8              
9              
10             sub build_query {
11 20 50   20 1 10629 my $query = blessed $_[0] ? $_[1] : $_[0];
12              
13 20 100 66     79 return $$query if ref $query eq 'REF' && ref $$query eq 'ARRAY';
14              
15 19 100       50 if (my $type = ref $query) {
16 18         45 return [_block(_ref_op($type), $query)];
17             }
18 1         5 else { return [] }
19             }
20              
21             sub _block {
22 30     30   66 my ($logic, $items) = @_;
23              
24 30 100       114 @{($items = [])} = map { $_ => $items->{$_} } sort keys %$items
  19         51  
  32         78  
25             if ref $items eq 'HASH';
26 30         60 my ($count, @words) = (0, ());
27              
28 30         80 while (my $el = shift @$items) {
29              
30 60         80 my @expr;
31 60 100 66     243 if (ref $el eq 'REF' && ref $$el eq 'ARRAY') {
    100          
    100          
    100          
32 1         2 @expr = @{$$el};
  1         3  
33              
34             }
35             elsif (my $type = ref $el) {
36 5         11 @expr = _block(_ref_op($type), $el);
37              
38             }
39             elsif ($el =~ /^-(?:and|or)$/) {
40 7         15 @expr = _block(_ref_op($el), shift @$items);
41              
42             }
43             elsif ($el =~ /^-has(?:_not)?$/) {
44 2 100       10 push @words, '?' . ($el eq '-has_not' ? '-' : '') . (shift @$items);
45 2         4 $count++;
46 2         6 next;
47              
48             }
49             else {
50 45         88 @expr = _value($el, shift @$items);
51             }
52              
53 58 100 33     268 ++$count && push @words, @expr if @expr;
54             }
55              
56 30 100       84 push @words, '?#' . ($logic x ($count - 1)) if $count > 1;
57 30         181 return @words;
58             }
59              
60             sub _ref_op {
61             return
62 34 50 100 34   176 ($_[0] eq 'HASH' || $_[0] eq '-and') ? '&'
    100 66        
63             : ($_[0] eq 'ARRAY' || $_[0] eq '-or') ? '|'
64             : '';
65             }
66              
67             sub _value {
68 45     45   81 my ($name, $val) = @_;
69              
70 45         69 my $type = ref $val;
71 45 100       102 if ($type eq 'HASH') {
    100          
72 7         16 return _value_hash($name, $val);
73              
74             }
75             elsif ($type eq 'ARRAY') {
76 6         14 return _value_array($name, '=', $val);
77             }
78              
79             # SCALAR
80 32   100     113 return "?$name=" . ($val // '');
81             }
82              
83             sub _value_array {
84 10     10   22 my ($name, $op, $block) = @_;
85              
86 10 100       24 return () unless @$block;
87              
88 8         13 my $logic = '|';
89 8 100 100     36 $logic = _ref_op(shift @$block)
90             if @$block[0] eq '-and' || @$block[0] eq '-or';
91              
92 8         18 my ($count, @words) = (0, ());
93 8         17 for (@$block) {
94             my @expr
95 24 100       62 = ref $_ eq 'HASH'
96             ? _value_hash($name, $_)
97             : _value_scalar($name, $op, $_);
98              
99 24 100 33     87 ++$count && push @words, @expr if @expr;
100             }
101              
102 8 100       39 push @words, '?#' . ($logic x ($count - 1)) if $count > 1;
103 8         35 return @words;
104             }
105              
106             sub _value_hash {
107 12     12   20 my ($name, $block) = @_;
108              
109 12         21 my @words = ();
110              
111 12         36 for my $op (sort keys %$block) {
112 12         24 my $val = $block->{$op};
113 12 100       31 return _value_array($name, $op, $val) if ref $val eq 'ARRAY';
114 8         16 push @words, _value_scalar($name, $op, $val);
115             }
116              
117 8         19 my $count = keys %$block;
118 8 100       20 push @words, '?#' . ('&' x ($count - 1)) if $count > 1;
119 8         22 return @words;
120             }
121              
122             sub _value_scalar {
123 27   100 27   69 my ($name, $op, $val) = (shift, shift, shift // '');
124              
125 27 100       60 return ("?$name=$val", '?#!') if $op eq '-not';
126 23         63 return '?' . $name . $op . $val;
127             }
128              
129             1;
130              
131              
132             =encoding utf8
133              
134             =head1 NAME
135              
136             MikroTik::Client::Query - Build MikroTik queries from perl structures
137              
138             =head1 SYNOPSIS
139              
140             use MikroTik::Client::Query qw(build_query);
141              
142             # (a = 1 OR a = 2) AND (b = 3 OR c = 4 OR d = 5)
143             my $query = {
144             a => [1, 2],
145             [
146             b => 3,
147             c => 4,
148             d => 5
149             ]
150             };
151              
152              
153             # Some bizarre nested expressions.
154             # (a = 1 OR b = 2 OR (e = 5 AND f = 6 AND g = 7))
155             # OR
156             # (c = 3 AND d = 4)
157             # OR
158             # (h = 8 AND i = 9)
159             $query = [
160             -or => {
161             a => 1,
162             b => 2,
163             -and => {e => 5, f => 6, g => 7}
164             },
165              
166             # OR
167             -and => [
168             c => 3,
169             d => 4
170             ],
171              
172             # OR
173             {h => 8, i => 9}
174             ];
175              
176             =head1 DESCRIPTION
177              
178             Simple and supposedly intuitive way to build MikroTik API queries. Following
179             ideas of L.
180              
181             =head1 METHODS
182              
183             =head2 build_query
184              
185             use MikroTik::Client::Query qw(build_query);
186              
187             # (type = 'ipip-tunnel' OR type = 'gre-tunnel') AND running = 'true'
188             # $query
189             # = ['?type=ipip-tunnel', '?type=gre-tunnel', '?#|', '?running=true', '?#&'];
190             my $query
191             = build_query({type => ['ipip-tunnel', 'gre-tunnel'], running => 'true'});
192              
193             Builds a query and returns an arrayref with API query words.
194              
195             =head1 QUERY SYNTAX
196              
197             Basic idea is that everything in arrayrefs are C'ed and everything in hashrefs
198             are C'ed unless specified otherwise. Another thing is, where a C is
199             expected, you should be able to use a list to compare against a set of values.
200              
201             =head2 Key-value pairs
202              
203             # type = 'gre-tunnel' AND running = 'true'
204             my $query = {type => 'gre-tunnel', running => 'true'};
205              
206             # disabled = 'true' OR running = 'false'
207             $query = [disabled => 'true', running => 'false'];
208              
209             Simple attribute value comparison.
210              
211             =head2 List of values
212              
213             # type = 'ether' OR type = 'wlan'
214             my $query = {type => ['ether', 'wlan']};
215              
216             You can use arrayrefs for a list of possible values for an attribute. By default,
217             it will be expanded into an C statement.
218              
219             =head2 Comparison operators
220              
221             # comment isn't empty (more than empty string)
222             my $query = {comment => {'>', ''}};
223              
224             # mtu > 1000 AND mtu < 1500
225             $query = {mtu => {'<' => 1500, '>' => 1000}};
226              
227             Hashrefs can be used for specifying operator for comparison. Well, any of three
228             of them. :) You can put multiple operator-value pairs in one hashref and they
229             will be expanded into an C statement.
230              
231             # mtu < 1000 OR mtu > 1500
232             $query = {mtu => [{'<', 1000}, {'>', 1500}]};
233              
234             # Or like this
235             # mtu < 1000 OR (mtu > 1400 AND mtu < 1500)
236             $query = {mtu => [{'<', 1000}, {'>', 1400, '<', 1500}]};
237              
238             Hashrefs can be also put in lists. If you want them combined into an C
239             statement, for example.
240              
241             # status = 'active' OR status = 'inactive'
242             $query = {mtu => {'=', ['active', 'inactive']}};
243              
244             Or you can use list as a value in a hashref pair. B: In this case, every
245             other pair in the hash will be ignored.
246              
247             =head2 Negation
248              
249             # !(interface = 'ether5')
250             my $query = {interface => {-not => 'ether5'}};
251              
252             # !(interface = 'ether5') AND !(interface = 'ether1')
253             $query = {interface => {-not => [-and => 'ether5', 'ether1']}};
254              
255             Since MikroTik API does not have 'not equal' operator, it ends up been 'opposite
256             of a equals b' expressions.
257              
258             =head2 Checking for an attribute
259              
260             my $query = {-has => 'dafault-name'};
261              
262             $query = {-has_not => 'dafault-name'};
263              
264             Checks if an element has an attribute with specific name.
265              
266             =head2 Literal queries
267              
268             my $query = \['?type=ether', '?running=true', '?actual-mtu=1500', '?#&&'];
269              
270             $query = [
271             type => 'ipip-tunnel',
272             \['?type=ether', '?running=true', '?actual-mtu=1500', '?#&&']
273             ];
274              
275             Reference to an arrayref can be used to pass list of prepared words. Those will
276             be treated as blocks in nested expressions.
277              
278             =head2 Logic and nesting
279              
280             # (mtu = 1460 AND actual-mtu = 1460)
281             # AND
282             # (running = 'false' OR disabled = 'true')
283              
284             my $query = {
285             {mtu => 1460, 'actual-mtu' => 1460},
286             [running => 'false', disabled => 'true']
287             };
288              
289             Conditions can be grouped and nested if needed. It's like putting brackets around
290             them.
291              
292             # Same thing, but with prefixes
293             my $query = {
294             -and => [mtu => 1460, 'actual-mtu' => 1460],
295             -or => {running => 'false', disabled => 'true'}
296             };
297              
298             You can change logic applied to a block by using keywords. Those keywords
299             will go outside for blocks that affect multiple attributes, or ...
300              
301             # !(type = 'ether') AND !(type = 'wlan')
302              
303             # Will produce the same result
304             my $query = {type => [-and => {-not => 'ether'}, {-not => 'wlan'}]};
305             $query = {type => {-not => [-and => 'ether', 'wlan']}};
306              
307             # Wrong, second condition will replace first
308             $query = {type => {-not => 'ether', -not => 'wlan'}};
309              
310             ... inside for a list of values of a single attribute.
311              
312             # This is wrong
313             my $query = [
314             -and =>
315             {type => 'ether'},
316             {running => 'true'}
317             ];
318              
319             # It will actually results in
320             # type = 'ether' OR running = 'true'
321              
322             C<-and> will be treated as prefix for the first hashref and, since this hash has
323             only one element, won't affect anything at all.
324              
325             =cut
326