File Coverage

blib/lib/MikroTik/API.pm
Criterion Covered Total %
statement 26 262 9.9
branch 0 126 0.0
condition 0 25 0.0
subroutine 9 27 33.3
pod 9 10 90.0
total 44 450 9.7


line stmt bran cond sub pod time code
1             package MikroTik::API;
2              
3 1     1   54346 use 5.006;
  1         3  
4 1     1   4 use strict;
  1         2  
  1         19  
5 1     1   4 use warnings FATAL => 'all';
  1         2  
  1         51  
6              
7             =head1 NAME
8              
9             MikroTik::API - Client to MikroTik RouterOS API
10              
11             =head1 VERSION
12              
13             Version 1.1.0
14              
15             =cut
16              
17             our $VERSION = '1.1.0';
18              
19              
20             =head1 SYNOPSIS
21              
22             use MikroTik::API;
23              
24             my $api = MikroTik::API->new({
25             host => 'mikrotik.example.org',
26             username => 'whoami',
27             password => 'SECRET',
28             use_ssl => 1,
29             });
30              
31             my ( $ret_get_identity, @aoh_identity ) = $api->query( '/system/identity/print', {}, {} );
32             print "Name of router: $aoh_identity[0]->{name}\n";
33              
34             $api->logout();
35              
36             =head1 DESCRIPTION
37              
38             =cut
39              
40 1     1   493 use Moose;
  1         383790  
  1         5  
41 1     1   6614 use namespace::autoclean;
  1         6664  
  1         3  
42              
43 1     1   53 use Digest::MD5;
  1         2  
  1         28  
44 1     1   425 use IO::Socket::INET;
  1         17597  
  1         7  
45 1     1   1029 use IO::Socket::SSL;
  1         52366  
  1         6  
46 1     1   590 use Time::Out qw{ timeout };
  1         472  
  1         2550  
47              
48             =head1 PUBLIC METHODS
49              
50             =head2 new( \%config )
51              
52             my $api = MikroTik::API->new({
53             host => 'mikrotik.example.org',
54             username => 'whoami',
55             password => 'SECRET',
56             autoconnect => 1, # optional (set to 0 if you do not want to connect during construction, default: 1)
57             use_ssl => 1, # optional (0 for non ssl / 1 for ssl)
58             port => 8729, # optonal (needed if you use another port then 8728 for non-ssl or 8729 for ssl)
59             debug => 0, # optional (set beween 0 (none) and 5 (most) for debug messages)
60             timeout => 3, # optional (timeout after 3 seconds during connect)
61             probe_before_talk => 3, # optional (probe connection before each actual command)
62             reconnect_after_failed_probe => 1, # optional (reconnect if probe failed)
63              
64             });
65              
66             =cut
67              
68             sub BUILD {
69 0     0 0   my ($self) = @_;
70 0 0 0       if ( $self->get_autoconnect() && $self->get_host() ) {
71 0           $self->connect();
72 0 0 0       if ( $self->get_username() && defined( $self->get_password() ) ) {
73 0           $self->login();
74             }
75             }
76 0           return $self;
77             }
78              
79             =head2 $api->connect()
80              
81             Connect happens on construction if you provide host address
82              
83             my $api = MikroTik::API->new();
84              
85             $api->set_host('mikrotik.example.org');
86             $api->set_port(1234);
87             $api->set_use_ssl(1);
88              
89             $api->connect();
90              
91             =cut
92              
93             sub connect {
94 0     0 1   my ( $self ) = @_;
95              
96 0 0         if ( ! $self->get_host() ) {
97 0           die 'host must be set before connect()'
98             }
99              
100 0 0         if ( $self->get_use_ssl() ) {
101 0   0       $self->set_socket(
102             IO::Socket::SSL->new(
103             PeerAddr => $self->get_host(),
104             PeerPort => $self->get_port(),
105             Proto => 'tcp',
106             SSL_cipher_list => 'HIGH',
107             SSL_verify_mode => $self->get_ssl_verify(),
108             Timeout => $self->get_timeout(),
109             ) or die "failed connect or ssl handshake ($!: ". IO::Socket::SSL::errstr() .')'
110             );
111             }
112             else {
113 0   0       $self->set_socket(
114             IO::Socket::INET->new(
115             PeerAddr => $self->get_host(),
116             PeerPort => $self->get_port(),
117             Proto => 'tcp',
118             Timeout => $self->get_timeout(),
119             ) or die "failed connect ($!)"
120             );
121             }
122 0 0         if ( ! $self->get_socket() ) {
123 0           die "socket creation failed ($!)";
124             }
125 0           $self->get_socket()->sockopt(SO_KEEPALIVE,1);
126 0           $self->get_socket()->sockopt(SO_RCVTIMEO,$self->get_timeout());
127 0           $self->get_socket()->sockopt(SO_SNDTIMEO,$self->get_timeout());
128 0           return $self;
129             }
130              
131             =head2 $api->login()
132              
133             Connect happens on construction if you provide host address, username and password
134              
135             my $api = MikroTik::API->new({ host => 'mikrotik.example.org' });
136              
137             $api->set_username('whoami');
138             $api->set_password('SECRET');
139              
140             $api->login();
141              
142             =cut
143              
144             sub login {
145 0     0 1   my ( $self ) = @_;
146              
147 0 0 0       if ( ! $self->get_username() && defined( $self->get_password() ) ) {
148 0           die 'username and password must be set before connect()';
149             }
150 0 0         if ( ! $self->get_socket() ) {
151 0           $self->connect();
152             }
153              
154             # RouterOS post v6.43 has new authentication method, thus pushing login/pass in the very first request.
155 0           my @command = ('/login');
156 0           push( @command, '=name=' . $self->get_username() );
157 0           push( @command, '=password=' . $self->get_password() );
158 0           my ( $retval, @results ) = $self->talk( \@command );
159 0 0         die 'disconnected while logging in' if !defined $retval;
160 0 0         if ( $retval > 1 ) {
161 0           die 'error during establishing login: ' . $results[0]{'message'};
162             }
163              
164             # if we got "=ret=" in response - then assuming this is old style AUTH
165 0 0         if ( exists $results[0]{'ret'} ) {
166 0           my $challenge = pack("H*",$results[0]{'ret'});
167 0           my $md5 = Digest::MD5->new();
168 0           $md5->add( chr(0) );
169 0           $md5->add( $self->get_password() );
170 0           $md5->add( $challenge );
171              
172 0           @command = ('/login');
173 0           push( @command, '=name=' . $self->get_username() );
174 0           push( @command, '=response=00' . $md5->hexdigest() );
175 0           ( $retval, @results ) = $self->talk( \@command );
176             }
177 0 0         die 'disconnected while logging in' if !defined $retval;
178 0 0         if ( $retval > 1 ) {
179 0           die 'error during establishing login: ' . $results[0]{'message'};
180             }
181              
182 0 0         if ( $self->get_debug() > 0 ) {
183 0           print 'Logged in to '. $self->get_host() .' as '. $self->get_username() ."\n";
184             }
185 0           return $self;
186             }
187              
188             =head2 $api->logout()
189              
190             $api->logout();
191              
192             =cut
193              
194             sub logout {
195 0     0 1   my ($self) = @_;
196 0           $self->get_socket()->close();
197 0           $self->set_socket( undef );
198             }
199              
200             =head2 $api->cmd( $command, \%attributes )
201              
202             # Set with no key required
203             # /system identity set name=MyNewMikroTik
204             my $returnvalue = $api->cmd( '/system/identity/set', { 'name' => 'MyNewMikroTik' } );
205             print "Name set\n" if ($returnvalue < 2);
206              
207             # Set keyed on the name "local"
208             # /interface bridge set local fast-forward=no
209             my $returnvalue = $api->cmd( '/interface/bridge/set', { '.id' => 'local', 'fast-forward' => 'no' } );
210             print "Bridge fast-forward turned off\n" if ($returnvalue < 2);
211              
212             # Set keyed on internal key
213             # /interface bridge set *cc fast-forward=no
214             my $returnvalue = $api->cmd( '/interface/bridge/set', { '.id' => '*cc', 'fast-forward' => 'no' } );
215             print "Bridge fast-forward turned off\n" if ($returnvalue < 2);
216              
217             # Reset a value
218             # /routing bgp peer set testpeer !keepalive-time
219             my $returnvalue = $api->cmd( '/routing/bgp/peer/set', { '.id' => 'testpeer', 'keepalive-time' => undef } );
220             print "Reset keepalive-time on testpeer\n" if ($returnvalue < 2);
221              
222             =cut
223              
224             sub cmd {
225 0     0 1   my ( $self, $cmd, $attrs_href ) = @_;
226 0           my @command = ($cmd);
227              
228 0           foreach my $attr ( keys %{$attrs_href} ) {
  0            
229 0 0         if (defined($attrs_href->{$attr})) {
230 0           push( @command, '='. $attr .'='. $attrs_href->{$attr} );
231             } else {
232 0           push( @command, '=!'. $attr );
233             }
234             }
235 0           my ( $retval, @results ) = $self->talk( \@command );
236 0           return ( $retval, @results );
237             }
238              
239             =head2 $api->query( $command, \%attributes, \%conditions )
240              
241             # Get all interfaces of type ether
242             my ( $ret_interface_print, @interfaces ) = $api->query('/interface/print', { '.proplist' => '.id,name' }, { type => 'ether' } );
243             foreach my $interface ( @interfaces ) {
244             print "$interface->{name}\n";
245             }
246              
247             # get all default routes that don't have the dynamic attribute
248             my ( $ret_route_print, @routes ) = $api->query('/ip/route', { '.proplist' => '.id,dst-address' }, { 'dst-address' => '0.0.0.0/0', 'dynamic'=>undef } );
249             foreach my $route ( @routes ) {
250             print "$route->{'dst-address'}\n";
251             }
252              
253             # get all default routes that don't have the dynamic attribute (alternate using array ref)
254             my ( $ret_route_print, @routes ) = $api->query('/ip/route', { '.proplist' => '.id,dst-address' }, [ 'dst-address=0.0.0.0/0', '-dynamic' ] );
255             foreach my $route ( @routes ) {
256             print "$route->{'dst-address'}\n";
257             }
258              
259             # get all default routes along with those with the dynamic attribute (note 'or' operator as last arg)
260             my ( $ret_route_print, @routes ) = $api->query('/ip/route', { '.proplist' => '.id,dst-address' }, [ 'dst-address=0.0.0.0/0', 'dynamic', '#|' ] );
261             foreach my $route ( @routes ) {
262             print "$route->{'dst-address'}\n";
263             }
264              
265             =cut
266              
267             sub query {
268 0     0 1   my ( $self, $cmd, $attrs_href, $queries_ref ) = @_;
269              
270 0           my @command = ($cmd);
271 0           foreach my $attr ( keys %{$attrs_href} ) {
  0            
272 0 0         push( @command, '='. $attr .'='. (defined($attrs_href->{$attr}) ? $attrs_href->{$attr} : ''));
273             }
274 0 0         if (defined($queries_ref)) {
275 0 0         if (ref($queries_ref) eq 'HASH') {
    0          
276 0           foreach my $query (keys %{$queries_ref} ) {
  0            
277 0 0         if (defined($queries_ref->{$query})) {
278 0           push( @command, '?'. $query .'='. $queries_ref->{$query} );
279             } else {
280 0           push( @command, '?-'. $query);
281             }
282             }
283             } elsif (ref($queries_ref) eq 'ARRAY') {
284 0           foreach my $query (@{$queries_ref} ) {
  0            
285 0           push( @command, '?'. $query);
286             }
287             }
288             }
289 0           my ( $retval, @results ) = $self->talk( \@command );
290 0           return ( $retval, @results );
291             }
292              
293             =head2 $api->get_by_key( $command, $keycolumn )
294              
295             my %interface = $api->get_by_key('/interface/ethernet/print', 'name' );
296             print "$interface{'ether1'}->{running}\n";
297              
298             =cut
299              
300             sub get_by_key {
301 0     0 1   my ( $self, $cmd, $id ) = @_;
302 0   0       $id ||= '.id';
303 0           my @command = ($cmd);
304 0           my %ids;
305 0           my ( $retval, @results ) = $self->talk( \@command );
306 0 0         die 'disconnected' if !defined $retval;
307 0 0         if ($retval > 1) {
308 0           die $results[0]{'message'};
309             }
310 0           foreach my $attrs ( @results ) {
311 0           my $key = '';
312 0           foreach my $attr ( keys %{ $attrs } ) {
  0            
313 0           my $val = $attrs->{$attr};
314 0 0         if ($attr eq $id) {
315 0           $key = $val;
316             }
317             }
318 0 0         if ( $key ) {
319 0           $ids{$key} = $attrs;
320             }
321             }
322 0           return %ids;
323             }
324              
325             =head1 ACCESSORS
326              
327             =head2 $api->get_host(), $api->set_host( $hostname )
328              
329             =cut
330              
331             has 'host' => ( is => 'rw', reader => 'get_host', writer => 'set_host', isa => 'Str' );
332              
333             =head2 $api->get_port(), $api->set_port( $portnumber )
334              
335             =cut
336              
337             has 'port' => ( is => 'ro', reader => '_get_port', writer => 'set_port', isa => 'Int' );
338              
339             =head2 $api->get_username(), $api->set_username( $username )
340              
341             =cut
342              
343             has 'username' => ( is => 'rw', reader => 'get_username', writer => 'set_username', isa => 'Str' );
344              
345             =head2 $api->get_password(), $api->set_password( $password )
346              
347             =cut
348              
349             has 'password' => ( is => 'rw', reader => 'get_password', writer => 'set_password', isa => 'Str' );
350              
351             =head2 $api->get_use_ssl(), $api->set_use_ssl( $zero_or_one )
352              
353             =cut
354              
355             has 'use_ssl' => ( is => 'rw', reader => 'get_use_ssl', writer => 'set_use_ssl', isa => 'Bool' );
356              
357             =head2 $api->get_ssl_verify(), $api->set_ssl_verify( $zero_or_one )
358              
359             =cut
360              
361             has 'ssl_verify' => ( is => 'rw', reader => 'get_ssl_verify', writer => 'set_ssl_verify', isa => 'Int', default => 1 );
362              
363             =head2 $api->get_new_auth_method(), $api->set_new_auth_method( $zero_or_one )
364              
365             DEPRECATED: does not have any effect any longer. Login looks up wether new method is possible and falls back to old method. This parameter will be removed in future.
366             Auth method changed in RouterOS v6.43+ (https://wiki.mikrotik.com/wiki/Manual:API#Initial_login) and reduces login by one call but sends password in plaintext.
367              
368             =cut
369              
370             has 'new_auth_method' => ( is => 'rw', reader => 'get_new_auth_method', writer => 'set_new_auth_method', isa => 'Bool', default => 0 );
371              
372             =head2 $api->get_autoconnect(), $api->set_autoconnect( $zero_or_one )
373              
374             =cut
375              
376             has 'autoconnect' => ( is => 'rw', reader => 'get_autoconnect', writer => 'set_autoconnect', isa => 'Bool', default => 1 );
377              
378             =head2 $api->get_socket(), $api->set_socket( $io_socket )
379              
380             If you need to use an existing socket for the API connection.
381              
382             my $socket = IO::Socket::INET->new();
383             $api->set_socket( $socket );
384              
385             =cut
386              
387             has 'socket' => ( is => 'rw', reader => 'get_socket', writer => 'set_socket', isa => 'Maybe[IO::Socket]' );
388              
389             =head2 $api->get_debug(), $api->set_debug( $int )
390              
391             $api->set_debug(0); # no debug
392             $api->set_debug(5); # verbose debug to STDOUT
393              
394             =cut
395              
396             has 'debug' => ( is => 'rw', reader => 'get_debug', writer => 'set_debug', isa => 'Int', default => 0 );
397              
398             =head2 $api->get_timeout(), $api->set_timeout( $seconds )
399              
400             Abort connect after $seconds of no reply from MikroTik. This _will not_ affect lost connections. Use probe_before_talk for this.
401              
402             =cut
403              
404             has 'timeout' => ( is => 'rw', reader => 'get_timeout', writer => 'set_timeout', isa => 'Int', default => 5 );
405              
406             =head2 $api->get_probe_before_talk(), $api->set_probe_before_talk( $seconds )
407              
408             Use this attribute to enable a test command with timeout to ensure that the connection is still alive before sending the actual command.
409             This is very useful for long lasting connections that may get disconnected while idling. A broken connection will not be recognized otherwise,
410             because the socket still exists and the command will last forever. The advantage over a common timeout for all commands is that long lasting
411             commands are still possible. Set this to 0 if you use many consequent commands and reenable it after completion.
412              
413             $api->set_probe_before_talk(0); # no probing of connection before sending command and read reply
414             $api->set_probe_before_talk(5); # a simple command will be sent and after 5 seconds of no reply, the connection is assumed as broken
415              
416             =cut
417              
418             has 'probe_before_talk' => ( is => 'rw', reader => 'get_probe_before_talk', writer => 'set_probe_before_talk', isa => 'Int', default => 0 );
419              
420             =head2 $api->get_reconnect_after_failed_probe(), $api->set_reconnect_after_failed_probe( $zero_or_one )
421              
422             If connection is recognized as broken then either reconnect or die otherwise.
423              
424             =cut
425              
426             has 'reconnect_after_failed_probe' => ( is => 'rw', reader => 'get_reconnect_after_failed_probe', writer => 'set_reconnect_after_failed_probe', isa => 'Bool', default => 1 );
427              
428             =head1 SEMI-PUBLIC METHODS
429              
430             can be useful for advanced users, but too complex for daily use
431              
432             =head2 $api->talk( \@sentence )
433              
434             =cut
435              
436             # Send a sentence (command) and then read sentences back until we
437             # get a '!done' sentence
438             # returns 1 on success or 2 on trap, 3 on fatal
439             # along with an array of hashref for the results
440             sub talk {
441 0     0 1   my ( $self, $sentence_aref ) = @_;
442              
443 0 0         if( $self->get_probe_before_talk() ) {
444 0           my $seconds = $self->get_probe_before_talk();
445 0           $self->set_probe_before_talk(0);
446             timeout $seconds => sub {
447 0     0     $self->talk( ['/login'] );
448 0           };
449 0           $self->set_probe_before_talk($seconds);
450 0 0         if( $@ ) {
451 0 0         if( $self->get_reconnect_after_failed_probe() ) {
452 0           $self->connect();
453 0           $self->login();
454             }
455             else {
456 0           return( 3, {message => 'could not talk to MikroTik'});
457             }
458             }
459             }
460              
461 0           $self->_write_sentence( $sentence_aref );
462 0           my ( @reply, @attrs );
463 0           my $retval;
464              
465             # Keep reading sentences until we get one that begins with '!done'
466             # Put each sentence into a hashref
467 0           while ( @reply = $self->_read_sentence()) {
468 0 0         if ($reply[0] eq '!done') {
    0          
    0          
    0          
469 0   0       $retval //= 1; # Set this if it has not already been set
470             } elsif ($reply[0] eq '!re') {
471 0           $retval = 1;
472             } elsif ($reply[0] eq '!trap') {
473 0           $retval = 2;
474             } elsif ($reply[0] eq '!fatal') {
475 0           $retval = 3;
476             }
477 0           my %dataset;
478 0           foreach my $line ( @reply ) {
479             # Only consider words of the form "=var=value"
480 0 0         if ( my ($key, $value) = ( $line =~ /^=([^=]+)=(.*)/s ) ) {
481 0           $dataset{$key} = $value;
482             }
483             }
484 0 0         push( @attrs, \%dataset ) if (keys %dataset);
485 0 0         last if ($reply[0] eq '!done');
486             }
487 0 0         if (!@reply) {
488             # network error
489 0           return( 3, {message => 'disconnected'});
490             }
491 0           return ( $retval, @attrs );
492             }
493              
494             =head2 $api->raw_talk( \@sentence )
495              
496             =cut
497              
498             sub raw_talk {
499 0     0 1   my ( $self, $sentence_aref ) = @_;
500              
501 0           $self->_write_sentence( $sentence_aref );
502 0           my ( @reply, @response );
503 0           my $retval;
504              
505 0           while ( @reply = $self->_read_sentence() ) {
506 0 0         if ($reply[0] eq '!done') {
    0          
    0          
    0          
507 0   0       $retval //= 0;
508             } elsif ($reply[0] eq '!re') {
509 0           $retval = 1;
510             } elsif ($reply[0] eq '!trap') {
511 0           $retval = 2;
512             } elsif ($reply[0] eq '!fatal') {
513 0           $retval = 3;
514             }
515 0           foreach my $line ( @reply ) {
516 0           push ( @response, $line );
517             }
518 0 0         last if ($reply[0] eq '!done');
519             }
520 0           return ( $retval, @response );
521             }
522              
523             ### ACCESSORS (overrridden extended functionality)
524              
525             sub get_port {
526 0     0 1   my ( $self ) = @_;
527 0 0         $self->_get_port()
    0          
528             ? $self->_get_port()
529             : $self->get_use_ssl()
530             ? 8729
531             : 8728
532             ;
533             }
534              
535             ### INTERNAL METHODS
536              
537             sub _write_sentence {
538 0     0     my ( $self, $sentence_aref ) = @_;
539              
540 0           foreach my $word ( @{$sentence_aref} ) {
  0            
541 0           $self->_write_word( $word );
542 0 0         if ( $self->get_debug() > 2 ) {
543 0           print ">>> $word\n";
544             }
545             }
546 0           $self->_write_word('');
547             }
548              
549             sub _write_word {
550 0     0     my ( $self, $word ) = @_;
551 0           $self->_write_len( length $word );
552 0           my $socket = $self->get_socket();
553 0           print $socket $word;
554             }
555              
556             sub _write_len {
557 0     0     my ( $self, $len ) = @_;
558              
559 0           my $socket = $self->get_socket();
560 0 0         if ( $len < 0x80 ) {
    0          
    0          
    0          
561 0           print $socket chr($len);
562             }
563             elsif ($len < 0x4000) {
564 0           $len |= 0x8000;
565 0           print $socket chr(($len >> 8) & 0xFF);
566 0           print $socket chr($len & 0xFF);
567             }
568             elsif ($len < 0x200000) {
569 0           $len |= 0xC00000;
570 0           print $socket chr(($len >> 16) & 0xFF);
571 0           print $socket chr(($len >> 8) & 0xFF);
572 0           print $socket chr($len & 0xFF);
573             }
574             elsif ($len < 0x10000000) {
575 0           $len |= 0xE0000000;
576 0           print $socket chr(($len >> 24) & 0xFF);
577 0           print $socket chr(($len >> 16) & 0xFF);
578 0           print $socket chr(($len >> 8) & 0xFF);
579 0           print $socket chr($len & 0xFF);
580             }
581             else {
582 0           print $socket chr(0xF0);
583 0           print $socket chr(($len >> 24) & 0xFF);
584 0           print $socket chr(($len >> 16) & 0xFF);
585 0           print $socket chr(($len >> 8) & 0xFF);
586 0           print $socket chr($len & 0xFF);
587             }
588             }
589              
590             # Read words until we get a word with zero length. All sentences
591             # begin with a word that begins with '!'
592             # Returns an array of words
593             sub _read_sentence {
594 0     0     my ( $self ) = @_;
595              
596 0           my ( @reply );
597              
598 0           my $word = $self->_read_word();
599 0 0         return if (!$word);
600              
601 0 0         die "Protocol error (sentence word does being with \"!\"\n" if ($word !~ /^!/);
602              
603 0           do {
604 0           push( @reply, $word );
605 0 0         if ( $self->get_debug() > 2 ) {
606 0           print "<<< $word\n"
607             }
608             } while ( $word = $self->_read_word() );
609 0           return (@reply );
610             }
611              
612             # Read a word from the Mikrotik
613             # Return the word read (maybe zero length string), or undef on EOF or error
614             sub _read_word {
615 0     0     my ( $self ) = @_;
616              
617 0           my $ret_line = '';
618 0           my $len = eval { $self->_read_len(); }; # catch EOF
  0            
619 0 0         return if !defined($len);
620 0 0         if ( $len > 0 ) {
621 0 0         if ( $self->get_debug() > 3 ) {
622 0           print "recv $len\n";
623             }
624 0           my $length_received = 0;
625 0           while ( $length_received < $len ) {
626 0           my $line = '';
627 0           $self->get_socket()->read( $line, $len );
628 0 0 0       last if !defined($line) || $line eq ''; # EOF
629 0           $ret_line .= $line; # append to $ret_line, in case we didn't get the whole word and are going round again
630 0           $length_received += length $line;
631             }
632 0 0         return if length($ret_line) != $len; # EOF or a protocol error
633             }
634 0           return $ret_line;
635             }
636              
637             # Read the length of the next word
638             sub _read_len {
639 0     0     my ( $self ) = @_;
640              
641 0 0         if ( $self->get_debug() > 4 ) {
642 0           print "start read_len\n";
643             }
644              
645 0           my $len = $self->_read_byte();
646              
647 0 0         if ( ($len & 0x80) == 0x00 ) {
    0          
    0          
    0          
    0          
648 0 0         if ( $self->get_debug() > 4 ) {
649 0           print "read_len got $len\n";
650             }
651 0           return $len
652             }
653             elsif ( ($len & 0xC0) == 0x80 ) {
654 0           $len &= ~0x80;
655 0           $len <<= 8;
656 0           $len += $self->_read_byte();
657             }
658             elsif ( ($len & 0xE0) == 0xC0 ) {
659 0           $len &= ~0xC0;
660 0           $len <<= 8;
661 0           $len += $self->_read_byte();
662 0           $len <<= 8;
663 0           $len += $self->_read_byte();
664             }
665             elsif ( ($len & 0xF0) == 0xE0 ) {
666 0           $len &= ~0xE0;
667 0           $len <<= 8;
668 0           $len += $self->_read_byte();
669 0           $len <<= 8;
670 0           $len += $self->_read_byte();
671 0           $len <<= 8;
672 0           $len += $self->_read_byte();
673             }
674             elsif ( ($len & 0xF8) == 0xF0 ) {
675 0           $len = $self->_read_byte();
676 0           $len <<= 8;
677 0           $len += $self->_read_byte();
678 0           $len <<= 8;
679 0           $len += $self->_read_byte();
680 0           $len <<= 8;
681 0           $len += $self->_read_byte();
682             }
683              
684 0 0         if ( $self->get_debug() > 4 ) {
685 0           print "read_len got $len\n";
686             }
687              
688 0           return $len;
689             }
690              
691             sub _read_byte{
692 0     0     my ( $self ) = @_;
693 0           my $line = '';
694 0           $self->get_socket()->read( $line, 1 );
695 0 0 0       die 'EOF' if !defined($line) || length($line) != 1;
696 0           return ord($line);
697             }
698              
699             =head1 ABOUT
700              
701             =head2 Contributors
702              
703             Object-Orientated Rebuild of prior contributions, based on:
704              
705             =over 4
706              
707             =item *
708              
709             initial release from cheesegrits in MikroTik forum: http://forum.mikrotik.com/viewtopic.php?p=108530#p108530
710              
711             =item *
712              
713             added C<timeout parameter> and fixes by elcamlost: https://github.com/elcamlost/mikrotik-perl-api/commit/10e5da1fd0ccb4a249ed3047c1d22c97251f666e
714              
715             =item *
716              
717             SSL support by akschu: https://github.com/akschu/MikroTikPerl/commit/9b689a7d7511a1639ffa2118c8e549b5cec1290d
718              
719             =back
720              
721             =head2 Design decisions
722              
723             =over 4
724              
725             =item *
726              
727             Use of Moose for OO
728              
729             =item *
730              
731             higher compilation time of Moose based lib negligible because of slow I/O operations
732              
733             =item *
734              
735             Moose is more common than Moo or similar
736              
737             =back
738              
739             =head1 AUTHOR
740              
741             Martin Gojowsky, C<martin at gojowsky.de>
742              
743             =head1 BUGS
744              
745             Please report any bugs or feature requests to C<bug-mikrotik-api at rt.cpan.org>, or through
746             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MikroTik-API>. I will be notified, and then you'll
747             automatically be notified of progress on your bug as I make changes.
748              
749             =head2 Known issues
750              
751             =over 4
752              
753             =item *
754              
755             Quite high compile time because of using Moose. Use of a persistent running framework recommended.
756              
757             =item *
758              
759             Login to RouterOS v6.43rc* not possible because of a changed auth method using plaintext passwords
760              
761             =back
762              
763             =head1 TODO
764              
765             =over 4
766              
767             =item *
768              
769             Add a parameter talk_timeout as an alternative for probe_before_talk that enables an actual timeout for each command.
770              
771             =back
772              
773             =head1 SUPPORT
774              
775             You can find documentation for this module with the perldoc command.
776              
777             perldoc MikroTik::API
778              
779             You can also look for information at:
780              
781             =over 4
782              
783             =item * RT: CPAN's request tracker (report bugs here)
784              
785             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MikroTik-API>
786              
787             =item * AnnoCPAN: Annotated CPAN documentation
788              
789             L<http://annocpan.org/dist/MikroTik-API>
790              
791             =item * CPAN Ratings
792              
793             L<http://cpanratings.perl.org/d/MikroTik-API>
794              
795             =item * Search CPAN
796              
797             L<http://search.cpan.org/dist/MikroTik-API/>
798              
799             =back
800              
801              
802             =head1 ACKNOWLEDGEMENTS
803              
804              
805             =head1 LICENSE AND COPYRIGHT
806              
807             Copyright 2015 Martin Gojowsky.
808              
809             This program is distributed under the MIT (X11) License:
810             L<http://www.opensource.org/licenses/mit-license.php>
811              
812             Permission is hereby granted, free of charge, to any person
813             obtaining a copy of this software and associated documentation
814             files (the "Software"), to deal in the Software without
815             restriction, including without limitation the rights to use,
816             copy, modify, merge, publish, distribute, sublicense, and/or sell
817             copies of the Software, and to permit persons to whom the
818             Software is furnished to do so, subject to the following
819             conditions:
820              
821             The above copyright notice and this permission notice shall be
822             included in all copies or substantial portions of the Software.
823              
824             THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
825             EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
826             OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
827             NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
828             HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
829             WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
830             FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
831             OTHER DEALINGS IN THE SOFTWARE.
832              
833              
834             =cut
835              
836             1; # End of MikroTik::API