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