view release on metacpan or  search on metacpan

lib/Net/VNC.pm  view on Meta::CPAN

    # set encodings

    my @encs = grep { $_->{supported} } @encodings;

    # Prefer the higher-numbered encodings
    @encs = reverse sort { $a->{num} <=> $b->{num} } @encs;

    if ( !$self->save_bandwidth ) {
        @encs = grep { !$_->{bandwidth} } @encs;
    }
    if ( $self->hide_cursor ) {
        @encs = grep { !$_->{cursor} } @encs;
    }

    $socket->print(
        pack(
            'CCn',
            2,               # message_type
            0,               # padding
            scalar @encs,    # number_of_encodings
        )
    );
    for my $enc (@encs) {

        # Make a big-endian, signed 32-bit value
        # method:
        #   pack as own-endian, signed      e.g. -239
        #   unpack as own-endian, unsigned  e.g. 4294967057
        #   pack as big-endian
        my $num = pack 'N', unpack 'L', pack 'l', $enc->{num};
        $socket->print($num);
    }
}

sub capture {
    my $self   = shift;
    my $socket = $self->socket;

    $self->_send_update_request();
    while ( ( my $message_type = $self->_receive_message() ) != 0 ) {

        #    warn $message_type;
    }

    return $self->_image_plus_cursor;
}

sub _image_plus_cursor {
    my $self = shift;

    my $image  = $self->_framebuffer;
    my $cursor = $self->_cursordata;
    if (  !$self->hide_cursor
        && $cursor
        && $cursor->{image}
        && defined $cursor->{x} )
    {

        #$cursor->{image}->save('cursor.png'); # temporary -- debugging
        $image
            = $image->clone(); # make a duplicate so we can overlay the cursor
        $image->blend(
            $cursor->{image},
            1,                 # don't modify destination alpha
            0, 0, $cursor->{width}, $cursor->{height},    # source dimensions
            $cursor->{x}, $cursor->{y}, $cursor->{width},
            $cursor->{height},    # destination dimensions
        );
    }
    return $image;
}

sub _send_key_event {
    my ( $self, $down_flag, $key ) = @_;

# A key press or release. Down-flag is non-zero (true) if the key is now pressed, zero
# (false) if it is now released. The key itself is specified using the “keysym” values
# defined by the X Window System.

    my $socket = $self->socket;
    $socket->print(
        pack(
            'CCnN',
            4,             # message_type
            $down_flag,    # down-flag
            0,             # padding
            $key,          # key
        )
    );
}

sub send_key_event_down {
    my ( $self, $key ) = @_;
    $self->_send_key_event( 1, $key );
}

sub send_key_event_up {
    my ( $self, $key ) = @_;
    $self->_send_key_event( 0, $key );
}

sub send_key_event {
    my ( $self, $key ) = @_;
    $self->send_key_event_down($key);
    $self->send_key_event_up($key);
}

sub send_key_event_string {
    my ( $self, $string ) = @_;
    foreach my $key ( map {ord} split //, $string ) {
        warn $key;
        $self->send_key_event($key);
    }
}

sub send_pointer_event {
    my ( $self, $button_mask, $x, $y ) = @_;

    $self->socket->print(
        pack(
            'CCnn',