view release on metacpan or  search on metacpan

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

package Net::VNC;
use strict;
use warnings;
use base qw(Class::Accessor::Fast);
use Crypt::DES;
use Image::Imlib2;
use IO::Socket::INET;
use bytes;
__PACKAGE__->mk_accessors(
    qw(hostname port username password socket name width height depth save_bandwidth
        hide_cursor server_endian
        _pixinfo _colourmap _framebuffer _cursordata _rfb_version
        _bpp _true_colour _big_endian _image_format
        )
);
our $VERSION = '0.40';

my $MAX_PROTOCOL_VERSION = 'RFB 003.008' . chr(0x0a);  # Max version supported

# Precompute booleans for specific Image::Imlib2 features
my $CAN_CREATE_RAW_IMAGE = Image::Imlib2->can('new_using_data');
my $CAN_CHANGE_BLEND     = Image::Imlib2->can('will_blend');

# This line comes from perlport.pod
my $AM_BIG_ENDIAN = unpack( 'h*', pack( 's', 1 ) ) =~ /01/ ? 1 : 0;

# The numbers in the hashes below were acquired from the VNC source code
my %supported_depths = (
    '24' => {
        bpp         => 32,
        true_colour => 1,
        red_max     => 255,
        green_max   => 255,
        blue_max    => 255,
        red_shift   => 16,
        green_shift => 8,
        blue_shift  => 0,
    },
    '16' => {
        bpp         => 16,
        true_colour => 1,
        red_max     => 31,
        green_max   => 31,
        blue_max    => 31,
        red_shift   => 10,
        green_shift => 5,
        blue_shift  => 0,
    },
    '8' => {
        bpp         => 8,
        true_colour => 0,
        red_max     => 255,
        green_max   => 255,
        blue_max    => 255,
        red_shift   => 16,
        green_shift => 8,
        blue_shift  => 0,
    },

    # Unused right now, but supportable
    '8t' => {
        bpp         => 8,
        true_colour => 1,    #!!!
        red_max     => 7,
        green_max   => 7,

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

        if ( $number_of_security_types == 0 ) {
            die 'Error authenticating';
        }

        my @security_types;
        foreach ( 1 .. $number_of_security_types ) {
            $socket->read( my $security_type, 1 )
                || die 'unexpected end of data';
            $security_type = unpack( 'C', $security_type );

            #        warn "sec: $security_type";
            push @security_types, $security_type;
        }

        my @pref_types = ( 1, 2 );
        @pref_types = ( 30, 1, 2 ) if $self->username;

        for my $preferred_type (@pref_types) {
            if ( 0 < grep { $_ == $preferred_type } @security_types ) {
                $security_type = $preferred_type;
                last;
            }
        }
    } else {

        # In RFB 3.3, the server dictates the security type
        $socket->read( $security_type, 4 ) || die 'unexpected end of data';
        $security_type = unpack( 'N', $security_type );
    }

    if ( !$security_type ) {

        die 'Connection failed';

    } elsif ( $security_type == 2 ) {

        # DES-encrypted challenge/response

        if ( $self->_rfb_version ge '003.007' ) {
            $socket->print( pack( 'C', 2 ) );
        }

        $socket->read( my $challenge, 16 ) || die 'unexpected end of data';

        #    warn "chal: " . unpack('h*', $challenge) . "\n";

        # the RFB protocol only uses the first 8 characters of a password
        my $key = substr( $self->password, 0, 8 );
        $key = '' if ( !defined $key );
        $key .= pack( 'C', 0 ) until ( length($key) % 8 ) == 0;

        my $realkey;

        #    warn unpack('b*', $key);
        foreach my $byte ( split //, $key ) {
            $realkey .= pack( 'b8', scalar reverse unpack( 'b8', $byte ) );
        }

        #    warn unpack('b*', $realkey);

        my $cipher = Crypt::DES->new($realkey);
        my $response;
        my $i = 0;
        while ( $i < 16 ) {
            my $word = substr( $challenge, $i, 8 );

            #        warn "$i: " . length($word);
            $response .= $cipher->encrypt($word);
            $i += 8;
        }

        #    warn "resp: " . unpack('h*', $response) . "\n";

        $socket->print($response);

    } elsif ( $security_type == 1 ) {

        # No authorization needed!
        if ( $self->_rfb_version ge '003.007' ) {
            $socket->print( pack( 'C', 1 ) );
        }

    } elsif ( $security_type == 30 ) {

        require Crypt::GCrypt::MPI;
        require Crypt::Random;

        # ARD - Apple Remote Desktop - authentication
        $socket->print( pack( 'C', 30 ) );    # use ARD
        $socket->read( my $gen, 2 ) || die 'unexpected end of data';
        $socket->read( my $len, 2 ) || die 'unexpected end of data';
        my $keylen = $self->_bin_int($len);
        $socket->read( my $mod,  $keylen ) || die 'unexpected end of data';
        $socket->read( my $resp, $keylen ) || die 'unexpected end of data';

        my $genmpi = Crypt::GCrypt::MPI::new(
            secure => 0,
            value  => $self->_bin_int($gen),
            format => Crypt::GCrypt::MPI::FMT_USG()
        );
        my $modmpi = Crypt::GCrypt::MPI::new(
            secure => 0,
            value  => $mod,
            format => Crypt::GCrypt::MPI::FMT_USG()
        );
        my $respmpi = Crypt::GCrypt::MPI::new(
            secure => 0,
            value  => $resp,
            format => Crypt::GCrypt::MPI::FMT_USG()
        );
        my $privmpi = $self->_mpi_randomize($keylen);

        my $pubmpi = $genmpi->copy()->powm( $privmpi, $modmpi );
        my $keympi = $respmpi->copy()->powm( $privmpi, $modmpi );
        my $pub = $self->_mpi_2_bytes( $pubmpi, $keylen );
        my $key = $self->_mpi_2_bytes( $keympi, $keylen );
        my $md5 = Crypt::GCrypt->new( type => 'digest', algorithm => 'md5' );
        $md5->write($key);
        my $shared  = $md5->read();
        my $passlen = length( $self->password ) + 1;
        my $userlen = length( $self->username ) + 1;