File Coverage

consoles/VNC.pm
Criterion Covered Total %
statement 552 553 99.8
total 552 553 99.8


line stmt code
1    
2   use Mojo::Base -base, -signatures;
3 31 use bytes;
  31  
  31  
4 31 use IO::Socket::INET;
  31  
  31  
5 31 use bmwqemu qw(diag fctwarn);
  31  
  31  
6 31 use Time::HiRes qw( sleep gettimeofday time );
  31  
  31  
7 31 use List::Util 'min';
  31  
  31  
8 31 use Crypt::DES;
  31  
  31  
9 31 use Compress::Raw::Zlib;
  31  
  31  
10 31 use Carp qw(confess cluck carp croak);
  31  
  31  
11 31 use Data::Dumper 'Dumper';
  31  
  31  
12 31 use Scalar::Util 'blessed';
  31  
  31  
13 31 use OpenQA::Exceptions;
  31  
  31  
14 31  
  31  
  31  
15   has [qw(description hostname port username password socket name width height depth
16   no_endian_conversion _pixinfo _colourmap _framebuffer _rfb_version screen_on
17   _bpp _true_colour _do_endian_conversion absolute ikvm keymap _last_update_received
18   _last_update_requested check_vnc_stalls _vnc_stalled vncinfo old_ikvm dell)];
19    
20   our $VERSION = '0.40';
21    
22   my $MAX_PROTOCOL_VERSION = '003.008';
23   my $MAX_PROTOCOL_HANDSHAKE = 'RFB ' . $MAX_PROTOCOL_VERSION . chr(0x0a); # Max version supported
24    
25   # This line comes from perlport.pod
26   my $client_is_big_endian = unpack('h*', pack('s', 1)) =~ /01/ ? 1 : 0;
27    
28   # The numbers in the hashes below were acquired from the VNC source code
29   my %supported_depths = (
30   32 => { # same as 24 actually
31   bpp => 32,
32   true_colour => 1,
33   red_max => 255,
34   green_max => 255,
35   blue_max => 255,
36   red_shift => 16,
37   green_shift => 8,
38   blue_shift => 0,
39   },
40   24 => {
41   bpp => 32,
42   true_colour => 1,
43   red_max => 255,
44   green_max => 255,
45   blue_max => 255,
46   red_shift => 16,
47   green_shift => 8,
48   blue_shift => 0,
49   },
50   16 => { # same as 15
51   bpp => 16,
52   true_colour => 1,
53   red_max => 31,
54   green_max => 31,
55   blue_max => 31,
56   red_shift => 10,
57   green_shift => 5,
58   blue_shift => 0,
59   },
60   15 => {
61   bpp => 16,
62   true_colour => 1,
63   red_max => 31,
64   green_max => 31,
65   blue_max => 31,
66   red_shift => 10,
67   green_shift => 5,
68   blue_shift => 0
69   },
70   8 => {
71   bpp => 8,
72   true_colour => 0,
73   red_max => 8,
74   green_max => 8,
75   blue_max => 4,
76   red_shift => 5,
77   green_shift => 2,
78   blue_shift => 0,
79   },
80   );
81    
82   my @encodings = (
83    
84   # These ones are defined in rfbproto.pdf
85   {
86   num => 0,
87   name => 'Raw',
88   supported => 1,
89   },
90   {
91   num => 16,
92   name => 'ZRLE',
93   supported => 1,
94   },
95   {
96   num => -223,
97   name => 'DesktopSize',
98   supported => 1,
99   },
100   {
101   num => -257,
102   name => 'VNC_ENCODING_POINTER_TYPE_CHANGE',
103   supported => 1,
104   },
105   {
106   num => -261,
107   name => 'VNC_ENCODING_LED_STATE',
108   supported => 1,
109   },
110   {
111   num => -224,
112   name => 'VNC_ENCODING_LAST_RECT',
113   supported => 1,
114   },
115   );
116    
117   # arbitrary
118 9 my $connect_failure_limit = 2;
  9  
  9  
  9  
  9  
119    
120 9 $self->width(0);
121   $self->height(0);
122 9 $self->screen_on(1);
123 9 # in a land far far before our time
124 9 $self->_last_update_received(0);
125   $self->_last_update_requested(0);
126 9 $self->_vnc_stalled(0);
127 9 $self->check_vnc_stalls(!$self->ikvm);
128 9 $self->{_inflater} = undef;
129 9  
130 9 my $hostname = $self->hostname || 'localhost';
131   my $port = $self->port || 5900;
132 9 my $description = $self->description || 'VNC server';
133 9 my $is_local = $hostname =~ qr/(localhost|127\.0\.0\.\d+|::1)/;
134 9 my $local_timeout = $bmwqemu::vars{VNC_TIMEOUT_LOCAL} // 10;
135 9 my $remote_timeout = $bmwqemu::vars{VNC_TIMEOUT_REMOTE} // 60;
136 9 my $local_connect_timeout = $bmwqemu::vars{VNC_CONNECT_TIMEOUT_LOCAL} // $local_timeout;
137 9 my $remote_connect_timeout = $bmwqemu::vars{VNC_CONNECT_TIMEOUT_REMOTE} // 240;
138 9 $connect_timeout //= $is_local ? $local_connect_timeout : $remote_connect_timeout;
139 9 $timeout //= $is_local ? $local_timeout : $remote_timeout;
140 9  
141 9 my $socket;
142   my $err_cnt = 0;
143 9 my $endtime = time + $connect_timeout;
144 9 while (!$socket) {
145 9 $socket = IO::Socket::INET->new(PeerAddr => $hostname, PeerPort => $port, Proto => 'tcp', Timeout => $timeout);
146 9 if (!$socket) {
147 268 $err_cnt++;
148 268 my $error_message = "Error connecting to $description <$hostname:$port>: $@";
149 263 OpenQA::Exception::VNCSetupError->throw(error => $error_message) if time > $endtime;
150 263 # we might be too fast trying to connect to the VNC host (e.g.
151 263 # qemu) so ignore the first occurrences of a failed
152   # connection attempt.
153   bmwqemu::fctwarn($error_message) if $err_cnt > $connect_failure_limit;
154   sleep 1;
155 259 next;
156 259 }
157 259 $socket->sockopt(Socket::TCP_NODELAY, 1); # turn off Naegle's algorithm for vnc
158    
159 5 # set timeout for receiving/sending as the timeout specified via c'tor only applies to connect/accept
160   # note: Using native code to set VNC socket timeout because from C++ we can simply include `struct timeval`
161   # from `#include <sys/time.h>` instead of relying on unportable manual packing.
162   tinycv::set_socket_timeout($socket->fileno, $timeout) or bmwqemu::fctwarn "Unable to set VNC socket timeout: $!";
163   }
164 5 $self->socket($socket);
165    
166 5 eval {
167   $self->_handshake_protocol_version();
168 5 $self->_handshake_security();
169 5 $self->_client_initialization();
170 3 $self->_server_initialization();
171 3 };
172 3 my $error = $@; # store so it doesn't get overwritten
173   return unless $error;
174 5 # clean up so socket can be garbage collected
175 5 $self->socket(undef);
176   die $error;
177 2 }
178 2  
179   my $socket = $self->socket;
180   $socket->read(my $protocol_version, 12) || die 'unexpected end of data';
181 6 my $protocol_pattern = qr/\A RFB [ ] (\d{3}\.\d{3}) \s* \z/xms;
  6  
  6  
182 6 die 'Malformed RFB protocol: ' . $protocol_version if $protocol_version !~ m/$protocol_pattern/xms;
183 6 $self->_rfb_version($1);
184 5  
185 5 if ($protocol_version gt $MAX_PROTOCOL_HANDSHAKE) {
186 4 $protocol_version = $MAX_PROTOCOL_HANDSHAKE;
187   # Repeat with the changed version
188 4 $self->_rfb_version($MAX_PROTOCOL_VERSION);
189 1 }
190    
191 1 die 'RFB protocols earlier than v3.3 are not supported' if $self->_rfb_version lt '003.003';
192    
193   # let's use the same version of the protocol, or the max, whichever's lower
194 4 $socket->print($protocol_version);
195   }
196    
197 4 my $socket = $self->socket;
198    
199   # Retrieve list of security options
200 7 my $security_type;
  7  
  7  
201 7 if ($self->_rfb_version ge '003.007') {
202   my $number_of_security_types = 0;
203   my $r = $socket->read($number_of_security_types, 1);
204 7 $number_of_security_types = unpack('C', $number_of_security_types) if $r;
205 7 die 'Error authenticating' if $number_of_security_types == 0;
206 4  
207 4 my @security_types;
208 4 foreach (1 .. $number_of_security_types) {
209 4 $socket->read(my $security_type, 1)
210   || die 'unexpected end of data';
211 4 $security_type = unpack('C', $security_type);
212 4  
213 4 push @security_types, $security_type;
214   }
215 4  
216   my @pref_types = (1, 2);
217 4 @pref_types = (30, 1, 2) if $self->username;
218   @pref_types = (16) if $self->ikvm;
219    
220 4 for my $preferred_type (@pref_types) {
221 4 if (0 < grep { $_ == $preferred_type } @security_types) {
222 4 $security_type = $preferred_type;
223   last;
224 4 }
225 5 }
  5  
226 4 }
227 4 else {
228    
229   # In RFB 3.3, the server dictates the security type
230   $socket->read($security_type, 4) || die 'unexpected end of data';
231   $security_type = unpack('N', $security_type);
232   }
233    
234 3 if ($security_type == 1) {
235 3 # No authorization needed!
236   $socket->print(pack('C', 1)) if $self->_rfb_version ge '003.007';
237   }
238 7 elsif ($security_type == 2) {
239   # DES-encrypted challenge/response
240 4  
241   $socket->print(pack('C', 2)) if $self->_rfb_version ge '003.007';
242    
243   # # VNC authentication is to be used and protocol data is to be
244   # # sent unencrypted. The server sends a random 16-byte
245 1 # # challenge:
246    
247   # # No. of bytes Type [Value] Description
248   # # 16 U8 challenge
249    
250   $socket->read(my $challenge, 16) || die 'unexpected end of data';
251    
252   # the RFB protocol only uses the first 8 characters of a password
253   my $key = substr($self->password, 0, 8);
254 1 $key = '' unless defined $key;
255   $key .= pack('C', 0) until (length($key) % 8) == 0;
256    
257 1 my $realkey;
258 1  
259 1 foreach my $byte (split //, $key) {
260   $realkey .= pack('b8', scalar reverse unpack('b8', $byte));
261 1 }
262    
263 1 # # The client encrypts the challenge with DES, using a password
264 8 # # supplied by the user as the key, and sends the resulting
265   # # 16-byte response:
266   # # No. of bytes Type [Value] Description
267   # # 16 U8 response
268    
269   my $cipher = Crypt::DES->new($realkey);
270   my $response;
271   my $i = 0;
272    
273 1 while ($i < 16) {
274 1 my $word = substr($challenge, $i, 8);
275 1  
276   $response .= $cipher->encrypt($word);
277 1 $i += 8;
278 2 }
279   $socket->print($response);
280 2  
281 2 }
282   elsif ($security_type == 16) { # ikvm
283 1  
284   $socket->print(pack('C', 16)); # accept
285   $socket->write(pack('Z24', $self->username));
286   $socket->write(pack('Z24', $self->password));
287   $socket->read(my $num_tunnels, 4);
288 1  
289 1 $num_tunnels = unpack('N', $num_tunnels);
290 1 # found in https://github.com/kanaka/noVNC
291 1 $self->old_ikvm($num_tunnels > 0x1000000 ? 1 : 0);
292   $socket->read(my $ikvm_session, 20) || die 'unexpected end of data';
293 1 my @bytes = unpack("C20", $ikvm_session);
294   print "Session info: ";
295 1 for my $byte (@bytes) {
296 1 printf "%02x ", $byte;
297 1 }
298 1 print "\n";
299 1 # examples
300 20 # af f9 ff bc 50 0d 02 00 20 a3 00 00 84 4c e3 be 00 80 41 40 d0 24 01 00
301   # af f9 1f bd 00 06 02 00 20 a3 00 00 84 4c e3 be 00 80 41 40 d0 24 01 00
302 1 # af f9 bf bc 08 03 02 00 20 a3 00 00 84 4c e3 be 00 80 41 40 d0 24 01 00
303   # af f9 ff bd 40 19 02 00 b0 a4 00 00 84 8c b1 be 00 60 43 40 f0 29 01 00
304   # ab f9 1f be 08 13 02 00 e0 a5 00 00 74 a8 82 be 00 00 4b 40 d8 2d 01 00
305   $socket->read(my $security_result, 4) || die 'Failed to login';
306   $security_result = unpack('C', $security_result);
307   print "Security Result: $security_result\n";
308   die 'Failed to login' unless $security_result == 0;
309 1 }
310 1 else {
311 1 die 'VNC Server wants security, but we have no password';
312 1 }
313    
314   # the RFB protocol always returns a result for type 2,
315 1 # but type 1, only for 003.008 and up
316   if (($self->_rfb_version ge '003.008' && $security_type == 1)
317   || $security_type == 2)
318   {
319   $socket->read(my $security_result, 4)
320 6 || die 'unexpected end of data';
321   $security_result = unpack('N', $security_result);
322    
323 3 die 'login failed' if $security_result;
324   }
325 3 elsif (!$socket->connected) {
326   die 'login failed';
327 3 }
328   }
329    
330 1 my $socket = $self->socket;
331   $socket->print(pack('C', !$self->ikvm)); # share
332   }
333    
334 3 my $socket = $self->socket;
  3  
  3  
335 3 $socket->read(my $server_init, 24) || die 'unexpected end of data';
336 3  
337   my ($framebuffer_width, $framebuffer_height,
338   $bits_per_pixel, $depth, $server_is_big_endian, $true_colour_flag,
339 4 %pixinfo,
  4  
  4  
340 4 $name_length);
341 4 ($framebuffer_width, $framebuffer_height,
342   $bits_per_pixel, $depth, $server_is_big_endian, $true_colour_flag,
343 4 $pixinfo{red_max}, $pixinfo{green_max}, $pixinfo{blue_max},
344   $pixinfo{red_shift}, $pixinfo{green_shift}, $pixinfo{blue_shift},
345   $name_length
346   ) = unpack 'nnCCCCnnnCCCxxxN', $server_init;
347    
348   if (!$self->depth) {
349    
350   # client did not express a depth preference, so check if the server's preference is OK
351 4 die 'Unsupported depth ' . $depth unless $supported_depths{$depth};
352   die 'Unsupported bits-per-pixel value ' . $bits_per_pixel unless $bits_per_pixel == $supported_depths{$depth}->{bpp};
353   die 'Unsupported true colour flag' if ($true_colour_flag ? !$supported_depths{$depth}->{true_colour} : $supported_depths{$depth}->{true_colour});
354 4 $self->depth($depth);
355    
356   # Use server's values for *_max and *_shift
357 3  
358 3 }
359 3 elsif ($depth != $self->depth) {
360 3 for my $key (qw(red_max green_max blue_max red_shift green_shift blue_shift)) {
361   $pixinfo{$key} = $supported_depths{$self->depth}->{$key};
362   }
363   }
364   $self->absolute($self->ikvm // 0);
365    
366 1 $self->width($framebuffer_width) if !$self->width && !$self->ikvm;
367 6 $self->height($framebuffer_height) if !$self->height && !$self->ikvm;
368   $self->_pixinfo(\%pixinfo);
369   $self->_bpp($supported_depths{$self->depth}->{bpp});
370 4 $self->_true_colour($supported_depths{$self->depth}->{true_colour});
371   $self->_do_endian_conversion($self->no_endian_conversion ? 0 : $server_is_big_endian != $client_is_big_endian);
372 4  
373 4 if ($name_length) {
374 4 $socket->read(my $name_string, $name_length)
375 4 || die 'unexpected end of data';
376 4 $self->name($name_string);
377 4 }
378    
379 4 if ($self->ikvm) {
380 2 $socket->read(my $ikvm_init, 12) || die 'unexpected end of data';
381    
382 2 my ($current_thread, $ikvm_video_enable, $ikvm_km_enable, $ikvm_kick_enable, $v_usb_enable) = unpack 'x4NCCCC', $ikvm_init;
383   print "IKVM specifics: $current_thread $ikvm_video_enable $ikvm_km_enable $ikvm_kick_enable $v_usb_enable\n";
384   die "Can't use keyboard and mouse. Is another ipmi vnc viewer logged in?" unless $ikvm_km_enable;
385 4 return; # the rest is kindly ignored by ikvm anyway
386 1 }
387    
388 1 my $info = tinycv::new_vncinfo(
389 1 $self->_do_endian_conversion, $self->_true_colour, $self->_bpp / 8, $pixinfo{red_max}, $pixinfo{red_shift},
390 1 $pixinfo{green_max}, $pixinfo{green_shift}, $pixinfo{blue_max}, $pixinfo{blue_shift});
391 1 $self->vncinfo($info);
392    
393   # setpixelformat
394   $socket->print(
395   pack(
396 3 'CCCCCCCCnnnCCCCCC',
397 3 0, # message_type
398   0, # padding
399   0, # padding
400   0, # padding
401   $self->_bpp,
402   $self->depth,
403   $self->_do_endian_conversion,
404   $self->_true_colour,
405   $pixinfo{red_max},
406   $pixinfo{green_max},
407   $pixinfo{blue_max},
408   $pixinfo{red_shift},
409   $pixinfo{green_shift},
410   $pixinfo{blue_shift},
411   0, # padding
412   0, # padding
413   0, # padding
414   ));
415    
416   # set encodings
417 3  
418   my @encs = grep { $_->{supported} } @encodings;
419    
420   # Prefer the higher-numbered encodings
421   @encs = reverse sort { $a->{num} <=> $b->{num} } @encs;
422    
423   if ($self->dell) {
424 3 # idrac's ZRLE implementation even kills tigervnc, they duplicate
  18  
425   # frames under certain conditions. Raw works ok
426   @encs = grep { $_->{name} ne 'ZRLE' } @encs;
427 3 }
  24  
428   $socket->print(
429 3 pack(
430   'CCn',
431   2, # message_type
432 1 0, # padding
  6  
433   scalar @encs, # number_of_encodings
434   ));
435 3 for my $enc (@encs) {
436    
437   # Make a big-endian, signed 32-bit value
438   # method:
439   # pack as own-endian, signed e.g. -239
440   # unpack as own-endian, unsigned e.g. 4294967057
441 3 # pack as big-endian
442   my $num = pack 'N', unpack 'L', pack 'l', $enc->{num};
443   $socket->print($num);
444   }
445   }
446    
447   # A key press or release. Down-flag is non-zero (true) if the key is now pressed, zero
448 17 # (false) if it is now released. The key itself is specified using the "keysym" values
449 17 # defined by the X Window System.
450    
451   my $socket = $self->socket;
452   my $template = 'CCnN';
453 5991 # for a strange reason ikvm has a lot more padding
  5991  
  5991  
  5991  
  5991  
454   $template = 'CxCnNx9' if $self->ikvm;
455   $socket->print(
456   pack(
457   $template,
458 5991 4, # message_type
459 5991 $down_flag, # down-flag
460   0, # padding
461 5991 $key, # key
462 5991 ));
463   }
464    
465    
466    
467   ## no critic (HashKeyQuotes)
468    
469   my $keymap_x11 = {
470   'esc' => 0xff1b,
471   'down' => 0xff54,
472 2996 'right' => 0xff53,
  2996  
  2996  
  2996  
  2996  
473   'up' => 0xff52,
474 2994 'left' => 0xff51,
  2994  
  2994  
  2994  
  2994  
475   'equal' => ord('='),
476   'spc' => ord(' '),
477   'minus' => ord('-'),
478   'shift' => 0xffe1,
479   'ctrl' => 0xffe3, # left, right is e4
480   'caps' => 0xffe5,
481   'meta' => 0xffe7, # left, right is e8
482   'alt' => 0xffe9, # left one, right is ea
483   'ret' => 0xff0d,
484   'tab' => 0xff09,
485   'backspace' => 0xff08,
486   'end' => 0xff57,
487   'delete' => 0xffff,
488   'home' => 0xff50,
489   'insert' => 0xff63,
490   'pgup' => 0xff55,
491   'pgdn' => 0xff56,
492   'sysrq' => 0xff15,
493   'super' => 0xffeb, # left, right is ec
494   };
495    
496   # ikvm aka USB: https://www.win.tue.nl/~aeb/linux/kbd/scancodes-14.html
497   my $keymap_ikvm = {
498   'ctrl' => 0xe0,
499   'shift' => 0xe1,
500   'alt' => 0xe2,
501   'meta' => 0xe3,
502   'caps' => 0x39,
503   'sysrq' => 0x9a,
504   'end' => 0x4d,
505   'delete' => 0x4c,
506   'home' => 0x4a,
507   'insert' => 0x49,
508   'super' => 0xe3,
509    
510   # {NSPrintScreenFunctionKey, 0x46},
511   # {NSScrollLockFunctionKey, 0x47},
512   # {NSPauseFunctionKey, 0x48},
513    
514   'pgup' => 0x4b,
515   'pgdn' => 0x4e,
516    
517   'left' => 0x50,
518   'right' => 0x4f,
519   'up' => 0x52,
520   'down' => 0x51,
521    
522   '0' => 0x27,
523   'ret' => 0x28,
524   'esc' => 0x29,
525   'backspace' => 0x2a,
526   'tab' => 0x2b,
527   ' ' => 0x2c,
528   'spc' => 0x2c,
529   'minus' => 0x2d,
530   '=' => 0x2e,
531   '[' => 0x2f,
532   ']' => 0x30,
533   '\\' => 0x31,
534   ';' => 0x33,
535   '\'' => 0x34,
536   '`' => 0x35,
537   ',' => 0x36,
538   '.' => 0x37,
539   '/' => 0x38,
540   };
541    
542   # see http://en.wikipedia.org/wiki/IBM_PC_keyboard
543   return {
544   '~' => '`',
545   '!' => '1',
546   '@' => '2',
547   '#' => '3',
548   '$' => '4',
549   '%' => '5',
550   '^' => '6',
551 3 '&' => '7',
  3  
552   '*' => '8',
553   '(' => '9',
554 3 ')' => '0',
555   '_' => 'minus',
556   '+' => '=',
557    
558   # second line
559   '{' => '[',
560   '}' => ']',
561   '|' => '\\',
562    
563   # third line
564   ':' => ';',
565   '"' => '\'',
566    
567   # fourth line
568   '<' => ',',
569   '>' => '.',
570   '?' => '/',
571   };
572   }
573    
574   ## use critic
575    
576   return if $self->keymap;
577   # create a deep copy - we want to reuse it in other instances
578   my %keymap = %$keymap_x11;
579    
580   for my $key (30 .. 255) {
581   $keymap{chr($key)} ||= $key;
582   }
583   for my $key (1 .. 12) {
584   $keymap{"f$key"} = 0xffbd + $key;
585   }
586 2791 for my $key ("a" .. "z") {
  2791  
  2791  
587 2791 $keymap{$key} = ord($key);
588   # shift-H looks strange, but that's how VNC works
589 2 $keymap{uc $key} = [$keymap{shift}, ord(uc $key)];
590   }
591 2 # VNC doesn't use the unshifted values, only prepends a shift key
592 452 for my $key (keys %{shift_keys()}) {
593   die "no map for $key" unless $keymap{$key};
594 2 $keymap{$key} = [$keymap{shift}, $keymap{$key}];
595 24 }
596   $self->keymap(\%keymap);
597 2 }
598 52  
599   return if $self->keymap;
600 52 my %keymap = %$keymap_ikvm;
601   for my $key ("a" .. "z") {
602   my $code = 0x4 + ord($key) - ord('a');
603 2 $keymap{$key} = $code;
  2  
604 42 $keymap{uc $key} = [$keymap{shift}, $code];
605 42 }
606   for my $key ("1" .. "9") {
607 2 $keymap{$key} = 0x1e + ord($key) - ord('1');
608   }
609   for my $key (1 .. 12) {
610 2 $keymap{"f$key"} = 0x3a + $key - 1,;
  2  
  2  
611 2 }
612 1 my %map = %{shift_keys()};
613 1 while (my ($key, $shift) = each %map) {
614 26 die "no map for $key" unless $keymap{$shift};
615 26 $keymap{$key} = [$keymap{shift}, $keymap{$shift}];
616 26 }
617   $self->keymap(\%keymap);
618 1 }
619 9  
620    
621 1 die "need delay" unless $press_release_delay;
622 12  
623   if ($self->ikvm) {
624 1 $self->init_ikvm_keymap;
  1  
625 1 }
626 21 else {
627 21 $self->init_x11_keymap;
628   }
629 1  
630   my @events;
631    
632   for my $key (split('-', $keys)) {
633 2793 if (defined($self->keymap->{$key})) {
  2793  
  2793  
  2793  
  2793  
  2793  
634 2793 if (ref($self->keymap->{$key}) eq 'ARRAY') {
635   push(@events, @{$self->keymap->{$key}});
636 2793 }
637 2 else {
638   push(@events, $self->keymap->{$key});
639   }
640 2791 next;
641   }
642   else {
643 2793 die "No map for '$key'";
644   }
645 2793 }
646 2794  
647 2793 if ($self->ikvm && @events == 1) {
648 204 $self->_send_key_event(2, $events[0]);
  204  
649   return;
650   }
651 2589  
652   if (!defined $down_flag || $down_flag == 1) {
653 2793 for my $key (@events) {
654   $self->send_key_event_down($key);
655   sleep($press_release_delay);
656 1 }
657   }
658   if (!defined $down_flag || $down_flag == 0) {
659   for my $key (reverse @events) {
660 2792 $self->send_key_event_up($key);
661 1 sleep($press_release_delay);
662 1 }
663   }
664   }
665 2791  
666 2791 bmwqemu::diag "send_pointer_event $button_mask, $x, $y, " . $self->absolute;
667 2996  
668 2996 my $template = 'CCnn';
669   $template = 'CxCnnx11' if ($self->ikvm);
670    
671 2791 $self->socket->print(
672 2790 pack(
673 2994 $template,
674 2994 5, # message type
675   $button_mask, # button-mask
676   $x, # x-position
677   $y, # y-position
678   ));
679 5 }
  5  
  5  
  5  
  5  
  5  
680 5  
681   # drain the VNC socket from all pending incoming messages
682 5 # return truthy value if there was a screen update
683 5 my $have_recieved_update = 0;
684   eval {
685 5 local $SIG{__DIE__} = undef;
686   while (defined(my $message_type = $self->_receive_message())) {
687   $have_recieved_update = 1 if $message_type == 0;
688   }
689   };
690   if (my $e = $@) {
691   die $e unless blessed $e && $e->isa('OpenQA::Exception::VNCProtocolError');
692   bmwqemu::fctwarn "Error in VNC protocol - relogin: " . $e->error;
693   $self->login;
694   }
695   return $have_recieved_update;
696   }
697 986  
  986  
  986  
698 986 use POSIX ':errno_h';
699 986  
700 986 return $self->socket->print(
701 986 pack(
702 588 'CCnnnn',
703   3, # message_type: frame buffer update request
704   $args->{incremental},
705 986 $args->{x},
706 4 $args->{y},
707 1 $args->{width},
708 1 $args->{height}));
709   }
710 983  
711   # frame buffer update request
712   my $time_after_vnc_is_considered_stalled = $bmwqemu::vars{VNC_STALL_THRESHOLD} // 4;
713 31 # after 2 seconds: send forced update
  31  
  31  
714   # after 4 seconds: turn off screen
715 658 my $time_since_last_update = time - $self->_last_update_received;
  658  
  658  
  658  
716    
717   # if there were no updates, send a forced update request
718   # to get a defined live sign. If that doesn't help, reconnect
719   if ($self->_framebuffer && $self->check_vnc_stalls) {
720   if ($self->_vnc_stalled && $time_since_last_update > $time_after_vnc_is_considered_stalled) {
721   $self->_last_update_received(0);
722   # return black image - screen turned off
723   bmwqemu::diag sprintf("considering VNC stalled, no update for %.2f seconds", $time_since_last_update);
724 658 $self->socket->close;
725   $self->socket(undef);
726   return $self->login;
727   }
728 652 if ($time_since_last_update > 2) {
  652  
  652  
  652  
729 652 $self->send_forced_update_request;
730   $self->_vnc_stalled(1) unless $self->_vnc_stalled;
731   }
732 652 }
733    
734   # if we have a black screen, we need a full update
735   $incremental = $self->_framebuffer && $self->_last_update_received ? 1 : 0 unless defined $incremental;
736 652 return $self->_send_frame_buffer(
737 651 {
738 1 incremental => $incremental,
739   x => 0,
740 1 y => 0,
741 1 width => $self->width,
742 1 height => $self->height
743 1 });
744   }
745 650  
746 8 # to check if VNC connection is still alive
747 8 # just force an update to the upper 16x16 pixels
748   # to avoid checking old screens if VNC goes down
749   $self->_last_update_requested(time);
750   return $self->_send_frame_buffer(
751   {
752 651 incremental => 0,
753 651 x => 0,
754   y => 0,
755   width => 16,
756   height => 16
757   });
758   }
759    
760   my $socket = $self->socket;
761   $socket or die 'socket does not exist. Probably your backend instance could not start or died.';
762   $socket->blocking(0);
763   my $ret = $socket->read(my $message_type, 1);
764   $socket->blocking(1);
765   return unless $ret;
766 8 $self->_vnc_stalled(0);
  8  
  8  
767 8  
768 8 die "socket closed: $ret\n${\Dumper $self}" unless $ret > 0;
769    
770   $message_type = unpack('C', $message_type);
771    
772   # This result is unused. It's meaning is different for the different methods
773   my $result
774   = !defined $message_type ? die 'bad message type received'
775   : $message_type == 0 ? $self->_receive_update()
776   : $message_type == 1 ? $self->_receive_colour_map()
777   : $message_type == 2 ? $self->_receive_bell()
778 1572 : $message_type == 3 ? $self->_receive_cut_text()
  1572  
  1572  
779 1572 : $message_type == 0x39 ? $self->_receive_ikvm_session()
780 1572 : $message_type == 0x04 ? $self->_discard_ikvm_message($message_type, 20)
781 1572 : $message_type == 0x16 ? $self->_discard_ikvm_message($message_type, 1)
782 1572 : $message_type == 0x33 ? $self->_discard_ikvm_message($message_type, 4)
783 1572 : $message_type == 0x37 ? $self->_discard_ikvm_message($message_type, $self->old_ikvm ? 2 : 3)
784 1572 : $message_type == 0x3c ? $self->_discard_ikvm_message($message_type, 8)
785 592 : die 'unsupported message type received';
786   return $message_type;
787 592 }
  0  
788    
789 592 $self->_last_update_received(time);
790   my $image = $self->_framebuffer;
791   if (!$image && $self->width && $self->height) {
792 592 $image = tinycv::new($self->width, $self->height);
793   $self->_framebuffer($image);
794   }
795    
796   my $socket = $self->socket;
797   my $hlen = $socket->read(my $header, 3) || die 'unexpected end of data';
798   my $number_of_rectangles = unpack('xn', $header);
799   my $depth = $self->depth;
800   my $do_endian_conversion = $self->_do_endian_conversion;
801    
802   foreach (my $i = 0; $i < $number_of_rectangles; ++$i) {
803   $socket->read(my $data, 12) || die 'unexpected end of data';
804   my ($x, $y, $w, $h, $encoding_type) = unpack 'nnnnN', $data;
805 588  
806   # unsigned -> signed conversion
807   $encoding_type = unpack 'l', pack 'L', $encoding_type;
808 589  
  589  
  589  
809 589 # work around buggy addrlink VNC
810 589 next if $encoding_type > 0 && $w * $h == 0;
811 589  
812 4 if ($encoding_type == 0 && !$self->ikvm) { # Raw
813 4 $socket->read(my $data, $w * $h * $self->_bpp / 8) || die 'unexpected end of data';
814   $image->map_raw_data($data, $x, $y, $w, $h, $self->vncinfo);
815   }
816 589 elsif ($encoding_type == 16) { # ZRLE
817 589 $self->_receive_zrle_encoding($x, $y, $w, $h);
818 589 }
819 589 elsif ($encoding_type == -223) { # DesktopSize pseudo-encoding
820 589 $self->width($w);
821   $self->height($h);
822 589 $image = tinycv::new($self->width, $self->height);
823 27316 $self->_framebuffer($image);
824 27316 }
825   elsif ($encoding_type == -257) {
826   bmwqemu::diag("pointer type $x $y $w $h $encoding_type");
827 27316 $self->absolute($x);
828   }
829   elsif ($encoding_type == -261) {
830 27316 my $led_data;
831   $socket->read($led_data, 1) || die "unexpected end of data";
832 27316 my @bytes = unpack("C", $led_data);
833 1 # 100 CapsLock is on, NumLock and ScrollLock are off
834 1 # 010 NumLock is on, CapsLock and ScrollLock are off
835   # 111 CapsLock, NumLock and ScrollLock are on
836   bmwqemu::diag("led state $bytes[0] $w $h $encoding_type");
837 27301 }
838   elsif ($encoding_type == -224) {
839   last;
840 2 }
841 2 elsif ($self->ikvm) {
842 2 $self->_receive_ikvm_encoding($encoding_type, $x, $y, $w, $h);
843 2 }
844   else {
845   die 'unsupported update encoding ' . $encoding_type;
846 2 }
847 2 }
848    
849   return $number_of_rectangles;
850 2 }
851 2  
852 2 # we don't care for the content
853   $self->socket->read(my $dummy, $bytes);
854   print "discarding $bytes bytes for message $type\n";
855    
856 2 # when 0x04
857   # bytes "front-ground-event", 20
858   # when 0x16
859 1 # bytes "keep-alive-event", 1
860   # when 0x33
861   # bytes "video-get-info", 4
862 6 # when 0x37
863   # bytes "mouse-get-info", 2
864   # when 0x3c
865 1 # bytes "get-viewer-lang", 8
866   }
867    
868   my $socket = $self->socket;
869 586 my $image = $self->_framebuffer;
870    
871   my $pi = $self->_pixinfo;
872 1  
  1  
  1  
  1  
  1  
873   my $stime = time;
874 1 $socket->read(my $data, 4)
875 1 or OpenQA::Exception::VNCProtocolError->throw(error => 'short read for length');
876   my ($data_len) = unpack('N', $data);
877   my $read_len = 0;
878   while ($read_len < $data_len) {
879   my $len = read($socket, $data, $data_len - $read_len, $read_len);
880   OpenQA::Exception::VNCProtocolError->throw(error => "short read for zrle data $read_len - $data_len") unless $len;
881   $read_len += $len;
882   }
883   diag sprintf("read $data_len in %fs\n", time - $stime) if (time - $stime > 0.1);
884   # the zlib header is only sent once per session
885   $self->{_inflater} ||= Compress::Raw::Zlib::Inflate->new;
886   my $out;
887   my $old_total_out = $self->{_inflater}->total_out;
888   my $status = $self->{_inflater}->inflate($data, $out, 1);
889 27301 OpenQA::Exception::VNCProtocolError->throw(error => "inflation failed $status") unless $status == Z_OK;
  27301  
  27301  
  27301  
  27301  
  27301  
  27301  
890 27301 my $res = $image->map_raw_data_zrle($x, $y, $w, $h, $self->vncinfo, $out, $self->{_inflater}->total_out - $old_total_out);
891 27301 OpenQA::Exception::VNCProtocolError->throw(error => "not read enough data") if $old_total_out + $res != $self->{_inflater}->total_out;
892   return $res;
893 27301 }
894    
895 27301 my $socket = $self->socket;
896 27301 my $image = $self->_framebuffer;
897    
898 27300 # ikvm specific
899 27300 $socket->read(my $aten_data, 8);
900 27300 my ($data_prefix, $data_len) = unpack('NN', $aten_data);
901 27300  
902 27300 $self->screen_on($w < 33000); # screen is off is signaled by negative numbers
903 27300  
904   # ikvm doesn't bother sending screen size changes
905 27300 if ($w != $self->width || $h != $self->height) {
906   if ($self->screen_on) {
907 27300 my $newimg = tinycv::new($w, $h);
908 27300 if ($image) {
909 27300 $image = $image->copyrect(0, 0, min($image->xres(), $w), min($image->yres(), $h));
910 27300 $newimg->blend($image, 0, 0);
911 27300 }
912 27300 $self->width($w);
913 27300 $self->height($h);
914 27300 $image = $newimg;
915   $self->_framebuffer($image);
916   }
917 6 else {
  6  
  6  
  6  
  6  
  6  
  6  
  6  
918 6 $self->_framebuffer(undef);
919 6 }
920   # resync mouse (magic)
921   $self->socket->print(pack('Cn', 7, 1920));
922 6 }
923 6  
924   if ($encoding_type == 89) {
925 6 return if $data_len == 0;
926   my $required_data = $w * $h * 2;
927   my $data;
928 6 print "Additional Bytes: ";
929 3 while ($data_len > $required_data) {
930 2 $socket->read($data, 1) || OpenQA::Exception::VNCProtocolError->throw(error => "unexpected end of data");
931 2 $data_len--;
932 2 my @bytes = unpack("C", $data);
933 2 printf "%02x ", $bytes[0];
934   }
935 2 print "\n";
936 2  
937 2 $socket->read($data, $required_data);
938 2 my $img = tinycv::new($w, $h);
939   $img->map_raw_data_rgb555($data);
940   $image->blend($img, $x, $y);
941 1 }
942   elsif ($encoding_type == 0) {
943   # ikvm manages to redeclare raw to be something completely different ;(
944 3 $socket->read(my $data, 10) || OpenQA::Exception::VNCProtocolError->throw(error => "unexpected end of data");
945   my ($type, $segments, $length) = unpack('CxNN', $data);
946   while ($segments--) {
947 6 $socket->read(my $data, 6) || OpenQA::Exception::VNCProtocolError->throw(error => "unexpected end of data");
948 1 my ($dummy_a, $dummy_b, $y, $x) = unpack('nnCC', $data);
949 1 $socket->read($data, 512) || OpenQA::Exception::VNCProtocolError->throw(error => "unexpected end of data");
950 1 my $img = tinycv::new(16, 16);
951 1 $img->map_raw_data_rgb555($data);
952 1  
953 1 if ($x * 16 + $img->xres() > $image->xres()) {
954 1 my $nxres = $image->xres() - $x * 16;
955 1 next if $nxres < 0;
956 1 $img = $img->copyrect(0, 0, $nxres, $img->yres());
957    
958 1 }
959   if ($y * 16 + $img->yres() > $image->yres()) {
960 1 my $nyres = $image->yres() - $y * 16;
961 1 next if $nyres < 0;
962 1 $img = $img->copyrect(0, 0, $img->xres(), $nyres);
963 1 }
964   $image->blend($img, $x * 16, $y * 16);
965   }
966   }
967 2 elsif ($encoding_type == 87) {
968 2 return if $data_len == 0;
969 2 die "we guessed wrong - this is a new board!" if $self->old_ikvm;
970 2 $socket->read(my $data, $data_len);
971 2 # enforce high quality to simplify our decoder
972 2 if (substr($data, 0, 4) ne pack('CCn', 11, 11, 444)) {
973 2 print "fixing quality\n";
974 2 my $template = 'CCCn';
975   $self->socket->print(
976 2 pack(
977 2 $template,
978 2 0x32, # message type
979 2 0, # magic number
980   11, # highest possible quality
981   444, # no sub sampling
982 2 ));
983 2 }
984 2 else {
985 2 $image->map_raw_data_ast2100($data, $data_len);
986   }
987 2 }
988   else {
989   die "unsupported encoding $encoding_type";
990   }
991 2 }
992 2  
993 2 $self->socket->read(my $map_infos, 5);
994   my ($padding, $first_colour, $number_of_colours) = unpack('Cnn', $map_infos);
995 2  
996 1 for (0 .. $number_of_colours - 1) {
997 1 $self->socket->read(my $colour, 6);
998 1 my ($red, $green, $blue) = unpack('nnn', $colour);
999   tinycv::set_colour($self->vncinfo, $first_colour + $_, $red / 256, $green / 256, $blue / 256);
1000   }
1001   return 1;
1002   }
1003    
1004   # Discard the bell signal
1005    
1006   $self->socket->read(my $ikvm_session_infos, 264);
1007    
1008 1 my ($msg1, $msg2, $str) = unpack('NNZ256', $ikvm_session_infos);
1009   print "IKVM Session Message: $msg1 $msg2 $str\n";
1010   return 1;
1011   }
1012 1  
1013   my $socket = $self->socket;
1014   $socket->read(my $cut_msg, 7) || OpenQA::Exception::VNCProtocolError->throw(error => 'unexpected end of data');
1015   my $cut_length = unpack 'xxxN', $cut_msg;
1016 1 $socket->read(my $cut_string, $cut_length)
  1  
  1  
1017 1 || OpenQA::Exception::VNCProtocolError->throw(error => 'unexpected end of data');
1018 1  
1019   # And discard it...
1020 1  
1021 1 return 1;
1022 1 }
1023 1  
1024   $self->send_pointer_event(0, $x, $y);
1025 1 }
1026    
1027   $self->send_pointer_event(1, $x, $y);
1028   $self->send_pointer_event(0, $x, $y);
1029 1 }
  1  
  1  
  1  
1030    
1031 1 $self->send_pointer_event(4, $x, $y);
  1  
  1  
1032 1 $self->send_pointer_event(0, $x, $y);
1033   }
1034 1  
1035 1 1;
1036 1  
1037    
1038    
1039 1 =head1 AUTHORS
  1  
  1  
1040 1  
1041 1 Leon Brocard acme@astray.com
1042 1  
1043 1 Chris Dolan clotho@cpan.org
1044    
1045   Apple Remote Desktop authentication based on LibVNCServer
1046    
1047   Maurice Castro maurice@ipexchange.com.au
1048 1  
1049   Many thanks for Foxtons Ltd for giving Leon the opportunity to write
1050   the original version of this module.
1051 1  
  1  
  1  
  1  
  1  
1052 1 Copyright 2006, Leon Brocard
1053    
1054   Copyright 2014-2017 Stephan Kulow (coolo@suse.de)
1055 1 adapted to be purely useful for qemu/openqa
  1  
  1  
  1  
  1  
1056 1  
1057 1 Copyright 2017-2021 SUSE LLC
1058    
1059   SPDX-License-Identifier: Artistic-1.0 OR GPL-1.0-or-later