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 |