From 5975eccf775194db9dd3082d0c9ce0062cc88dca Mon Sep 17 00:00:00 2001 From: Leon Brocard Date: Mon, 23 Nov 2009 14:13:13 +0000 Subject: [PATCH] Import Net::VNC 0.36 --- Build.PL | 18 + CHANGES | 41 ++ MANIFEST | 11 + META.yml | 15 + Makefile.PL | 19 + README | 70 +++ bin/vnccapture | 108 +++++ lib/Net/VNC.pm | 1098 ++++++++++++++++++++++++++++++++++++++++++++++ t/pod.t | 6 + t/pod_coverage.t | 6 + 10 files changed, 1392 insertions(+) create mode 100644 Build.PL create mode 100644 CHANGES create mode 100644 MANIFEST create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100755 bin/vnccapture create mode 100644 lib/Net/VNC.pm create mode 100644 t/pod.t create mode 100644 t/pod_coverage.t diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..4a20c9e --- /dev/null +++ b/Build.PL @@ -0,0 +1,18 @@ +#!perl +use Module::Build; +use strict; +use warnings; + +my $build = Module::Build->new( + create_makefile_pl => 'traditional', + license => 'perl', + module_name => 'Net::VNC', + requires => { + 'Class::Accessor::Fast' => '0', + 'Crypt::DES' => '0', + 'Image::Imlib2' => '0', + 'Test::More' => '0', + }, + script_files => { 'bin/vnccapture' }, +); +$build->create_build_script; diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..aec3e40 --- /dev/null +++ b/CHANGES @@ -0,0 +1,41 @@ +Revision history for Perl module Net::VNC: + +0.36 Fri Jun 29 19:58:51 BST 2007 + - make vnccapture's outfile option work (patch by Owen Crow) + +0.35 Fri Jul 28 11:41:23 BST 2006 + - fix typo-d 'has_alpha' which breaks with recent Image::Imlib2 + +0.34 Thu Jul 27 12:12:57 BST 2006 + - fixed failing cursor bug with realvnc 3.3 + +0.33 Sun Jun 25 16:13:33 BST 2006 + - fixed a few cross-endian bugs (thanks to Chris Dolan again!) + +0.32 Tue Apr 25 20:03:09 BST 2006 + - many patches from Chris Dolan: + - Added optional support for the mouse cursor + - Support for CoRRE encoding + - performance enhancement: split out the 8/16/24 bit support into + their own modes + - rearchitected the encoding system: list all known, but flag them + as supported or not + - ... this will simplify the addition of new encodings + - ... this allows enabling/disabling classes of encodings (like cursor) + - bugfix for signedness of encoding type + - added skeletal support for the remaining server messages: cut-text and bell + +0.31 Mon Mar 13 20:05:27 GMT 2006 + - 24-bit truecolour support + - non-authenticated login + - incremental update + - all provided by Chris Dolan + +0.30 Mon Jan 23 10:12:05 GMT 2006 + - die with a more accurate reason if there was an error + connecting + - drop the connection timeout to 15 seconds + - reordered documentation to try and confuse Leo less + +0.29 Thu Jan 19 15:56:05 GMT 2006 + - first release \ No newline at end of file diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..c462410 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,11 @@ +bin/vnccapture +Build.PL +CHANGES +lib/Net/VNC.pm +Makefile.PL +MANIFEST This list of files +META.yml +README +t/pod.t +t/pod_coverage.t + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..3c3b03f --- /dev/null +++ b/META.yml @@ -0,0 +1,15 @@ +--- #YAML:1.0 +name: Net-VNC +version: 0.36 +abstract: ~ +license: ~ +generated_by: ExtUtils::MakeMaker version 6.32 +distribution_type: module +requires: + Class::Accessor::Fast: 0 + Crypt::DES: 0 + Image::Imlib2: 0 + Test::More: 0 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.2.html + version: 1.2 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..2147704 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,19 @@ +# Note: this file was auto-generated by Module::Build::Compat version 0.03 +use ExtUtils::MakeMaker; +WriteMakefile +( + 'NAME' => 'Net::VNC', + 'VERSION_FROM' => 'lib/Net/VNC.pm', + 'PREREQ_PM' => { + 'Class::Accessor::Fast' => '0', + 'Crypt::DES' => '0', + 'Image::Imlib2' => '0', + 'Test::More' => '0' + }, + 'INSTALLDIRS' => 'site', + 'EXE_FILES' => [ + 'bin/vnccapture' + ], + 'PL_FILES' => {} + ) +; diff --git a/README b/README new file mode 100644 index 0000000..0259321 --- /dev/null +++ b/README @@ -0,0 +1,70 @@ +NAME + Net::VNC - A simple VNC client + +SYNOPSIS + use Net::VNC; + + my $vnc = Net::VNC->new({hostname => $hostname, password => $password}); + $vnc->login; + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + + my $image = $vnc->capture; + $image->save("out.png"); + +DESCRIPTION + Virtual Network Computing (VNC) is a desktop sharing system which uses + the RFB (Remote FrameBuffer) protocol to remotely control another + computer. This module acts as a VNC client and communicates to a VNC + server using the RFB protocol, allowing you to capture the screen of the + remote computer. + + This module dies upon connection errors (with a timeout of 15 seconds) + and protocol errors. + +METHODS + new + The constructor. Given a hostname and a password returns a Net::VNC + object: + + my $vnc = Net::VNC->new({hostname => $hostname, password => $password}); + + login + Logs into the remote computer: + + $vnc->login; + + name + Returns the name of the remote computer: + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + + width + Returns the width of the remote screen: + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + + height + Returns the height of the remote screen: + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + + capture + Captures the screen of the remote computer, returning an Image::Imlib2 + object: + + my $image = $vnc->capture; + $image->save("out.png"); + +AUTHOR + Leon Brocard acme@astray.com + + Many thanks for Foxtons Ltd for giving me the opportunity to write this + module. + +COPYRIGHT + Copyright (C) 2006, Leon Brocard + + This module is free software; you can redistribute it or modify it under + the same terms as Perl itself. + diff --git a/bin/vnccapture b/bin/vnccapture new file mode 100755 index 0000000..5c2f6b6 --- /dev/null +++ b/bin/vnccapture @@ -0,0 +1,108 @@ +#!/usr/bin/perl -w + +use warnings; +use strict; +use Net::VNC; +use Getopt::Long; +use Pod::Usage; + +my %opts = ( + password => '', + host => 'localhost', + port => 5900, + depth => 24, + type => 'png', + cursor => 0, + outfile => '', + endian => undef, + verbose => 0, + help => 0, + version => 0, +); + +Getopt::Long::Configure('bundling'); +GetOptions('P|password=s' => \$opts{password}, + 'H|host=s' => \$opts{host}, + 'p|port=s' => \$opts{port}, + 'd|depth=s' => \$opts{depth}, + 't|type=s' => \$opts{type}, + 'C|cursor' => \$opts{cursor}, + 'o|outfile=s' => \$opts{outfile}, + 'e|endian' => \$opts{endian}, + 'v|verbose' => \$opts{verbose}, + 'h|help' => \$opts{help}, + 'V|version' => \$opts{version}, + ) or pod2usage(1); +if ($opts{help}) { + pod2usage(-exitstatus => 0, -verbose => 2); +} +if ($opts{version}) { + print "Net::VNC v$Net::VNC::VERSION\n"; + exit 0; +} +my $end = shift || 1; +$end = 1 if ($end =~ /\D/); + +my $vnc = Net::VNC->new({hostname => $opts{host}, + port => $opts{port}, + password => $opts{password}, + }); +$vnc->server_endian($opts{endian}); +$vnc->depth($opts{depth}); +$vnc->login(); +print "Logged in\n" if ($opts{verbose}); + +$vnc->hide_cursor(!$opts{cursor}); + +for my $n (1..$end) { + my $filename + = defined $opts{outfile} ? $opts{outfile}.($end == 1 ? q{} : q{.}.$n) + : sprintf 'snapshot%04d.%s', $n, $opts{type}; + $vnc->capture()->save($filename); + print "Wrote $filename\n" if ($opts{verbose}); +} + +__END__ + +=head1 NAME + +vnccapture - Capture a screenshot via VNC + +=head1 SYNOPSIS + + vnccapture [options] [numcaptures] + + Options: + -P --password=str password for the VNC server, if applicable + -H --host=str address of VNC server (default: 'localhost') + -p --port=num TCP port for VNC server (default: 5900) + -d --depth=8|16|24 screen depth for capture (default: 24) + -t --type=ext image type for output (default: 'png') + -C --cursor include the mouse cursor in the image + -o --outfile capture to the specified path + otherwise capture to "snapshot." + -v --verbose print status and diagnostics to STDOUT + -h --help verbose help message + -V --version print the Net::VNC version + +=head1 DESCRIPTION + +Connect to a VNC server and capture the screen one or more times. The +output is written to, for example, C. The number is +the sequence of captures and the extension is specified by the +C<--type> argument. + +The C<--type> argument can be any format that L can +support. + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Chris Dolan, I + +=cut diff --git a/lib/Net/VNC.pm b/lib/Net/VNC.pm new file mode 100644 index 0000000..606ffc6 --- /dev/null +++ b/lib/Net/VNC.pm @@ -0,0 +1,1098 @@ +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 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.36'; + +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, + blue_max => 3, + red_shift => 0, + green_shift => 3, + blue_shift => 6, + }, +); + +my @encodings = ( + # These ones are defined in rfbproto.pdf + { num => 0, + name => 'Raw', + supported => 1, + }, + { num => 1, + name => 'CopyRect', + supported => 1, + }, + { num => 2, + name => 'RRE', + supported => 1, + }, + { num => 4, + name => 'CoRRE', + supported => 1, + }, + { num => 5, + name => 'Hextile', + supported => 1, + bandwidth => 1, + }, + { num => 16, + name => 'ZRLE', + supported => 0, + bandwidth => 1, + }, + { num => -239, + name => 'Cursor', + supported => 1, + cursor => 1, + }, + { num => -223, + name => 'DesktopSize', + supported => 0, + }, + + # Learned about these from cvs://cotvnc.sf.net/cotvnc/Source/rfbproto.h + # None of them are currently used + map( { + { num => -256+$_, + name => 'CompressLevel'.$_, + supported => 0, + compress => 1, + } } 0 .. 9 ), + { num => -240, + name => 'XCursor', + supported => 0, + cursor => 1, + }, + { num => -224, + name => 'LastRect', + supported => 0, + }, + map( { + { num => -32+$_, + name => 'QualityLevel'.$_, + supported => 0, + quality => 1, + } } 0 .. 9 ), + + # Learned about this one from pyvnc2swf/rfb.py, but I don't understand where it comes from + # It doesn't seem to be documented in CotVNC or VNC 4.1.1 source code + { num => -232, + name => 'CursorPos', + supported => 1, + cursor => 1, + }, +); + +sub list_encodings +{ + my $pkg_or_self = shift; + + my %encmap = map {$_->{num} => $_->{name}} @encodings; + return %encmap; +} + +sub login { + my $self = shift; + my $hostname = $self->hostname; + my $port = $self->port; + my $socket = IO::Socket::INET->new( + PeerAddr => $hostname || 'localhost', + PeerPort => $port || '5900', + Proto => 'tcp', + ) + || die "Error connecting to $hostname: $!"; + $socket->timeout(15); + $self->socket($socket); + + eval { + $self->_handshake_protocol_version(); + $self->_handshake_security(); + $self->_client_initialization(); + $self->_server_initialization(); + }; + my $error = $@; # store so it doesn't get overwritten + if ($error) { + + # clean up so socket can be garbage collected + $self->socket(undef); + die $error; + } +} + +sub _handshake_protocol_version { + my $self = shift; + + my $socket = $self->socket; + $socket->read( my $protocol_version, 12 ) || die 'unexpected end of data'; + + # warn "prot: $protocol_version"; + + my $protocol_pattern = qr/\A RFB [ ] (\d{3}\.\d{3}) \s* \z/xms; + if ( $protocol_version !~ m/$protocol_pattern/xms ) { + die 'Malformed RFB protocol: ' . $protocol_version; + } + $self->_rfb_version($1); + + if ( $protocol_version gt $MAX_PROTOCOL_VERSION ) { + $protocol_version = $MAX_PROTOCOL_VERSION; + + # Repeat with the changed version + if ( $protocol_version !~ m/$protocol_pattern/xms ) { + die 'Malformed RFB protocol'; + } + $self->_rfb_version($1); + } + + if ( $self->_rfb_version lt '003.003' ) { + die 'RFB protocols earlier than v3.3 are not supported'; + } + + # let's use the same version of the protocol, or the max, whichever's lower + $socket->print($protocol_version); +} + +sub _handshake_security { + my $self = shift; + + my $socket = $self->socket; + + # Retrieve list of security options + my $security_type; + if ( $self->_rfb_version ge '003.007' ) { + $socket->read( my $number_of_security_types, 1 ) + || die 'unexpected end of data'; + $number_of_security_types = unpack( 'C', $number_of_security_types ); + + # warn "types: $number_of_security_types"; + + 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; + } + + for my $preferred_type ( 2, 1 ) { + 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"; + + my $key = $self->password; + $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 ) ); + } + + } else { + + die "no supported vnc authentication mechanism"; + + } + + if ( $self->_rfb_version ge '003.008' ) { + $socket->read( my $security_result, 4 ) + || die 'unexpected end of data'; + $security_result = unpack( 'I', $security_result ); + + # warn $security_result; + die 'login failed' if $security_result; + } + + #elsif (!$socket->connected) { + elsif ( $socket->eof ) { # XXX Should this be !$socket->connected?? + die 'login failed'; + } +} + +sub _client_initialization { + my $self = shift; + + my $socket = $self->socket; + + $socket->print( pack( 'C', 1 ) ); # share +} + +sub _server_initialization { + my $self = shift; + + my $socket = $self->socket; + $socket->read( my $server_init, 24 ) || die 'unexpected end of data'; + + my ( $framebuffer_width, $framebuffer_height, $bits_per_pixel, $depth, + $big_endian_flag, $true_colour_flag, %pixinfo, $name_length ); + ( $framebuffer_width, $framebuffer_height, $bits_per_pixel, + $depth, $big_endian_flag, $true_colour_flag, + $pixinfo{red_max}, $pixinfo{green_max}, $pixinfo{blue_max}, + $pixinfo{red_shift}, $pixinfo{green_shift}, $pixinfo{blue_shift}, + $name_length + ) + = unpack 'nnCCCCnnnCCCxxxN', $server_init; + + # warn "$framebuffer_width x $framebuffer_height"; + +# warn "$bits_per_pixel bpp / depth $depth / $big_endian_flag be / $true_colour_flag tc / $pixinfo{red_max},$pixinfo{green_max},$pixinfo{blue_max} / $pixinfo{red_shift},$pixinfo{green_shift},$pixinfo{blue_shift}"; + + # warn $name_length; + + if ( !$self->depth ) { + +# client did not express a depth preference, so check if the server's preference is OK + if ( !$supported_depths{$depth} ) { + die 'Unsupported depth ' . $depth; + } + if ( $bits_per_pixel != $supported_depths{$depth}->{bpp} ) { + die 'Unsupported bits-per-pixel value ' . $bits_per_pixel; + } + if ($true_colour_flag + ? !$supported_depths{$depth}->{true_colour} + : $supported_depths{$depth}->{true_colour} + ) + { + die 'Unsupported true colour flag'; + } + $self->depth($depth); + + # Use server's values for *_max and *_shift + + } elsif ( $depth != $self->depth ) { + for my $key ( + qw(red_max green_max blue_max red_shift green_shift blue_shift)) + { + $pixinfo{$key} = $supported_depths{ $self->depth }->{$key}; + } + } + + if ( !$self->width ) { + $self->width($framebuffer_width); + } + if ( !$self->height ) { + $self->height($framebuffer_height); + } + $self->_pixinfo( \%pixinfo ); + $self->_bpp( $supported_depths{ $self->depth }->{bpp} ); + $self->_true_colour( $supported_depths{ $self->depth }->{true_colour} ); + $self->_big_endian( $self->server_endian ? $big_endian_flag : $AM_BIG_ENDIAN ); + + $socket->read( my $name_string, $name_length ) + || die 'unexpected end of data'; + $self->name($name_string); + + # warn $name_string; + + # setpixelformat + $socket->print( + pack( + 'CCCCCCCCnnnCCCCCC', + 0, # message_type + 0, # padding + 0, # padding + 0, # padding + $self->_bpp, + $self->depth, + $self->_big_endian, + $self->_true_colour, + $pixinfo{red_max}, + $pixinfo{green_max}, + $pixinfo{blue_max}, + $pixinfo{red_shift}, + $pixinfo{green_shift}, + $pixinfo{blue_shift}, + 0, # padding + 0, # padding + 0, # padding + ) + ); + + # 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_pointer_event(); + $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_pointer_event { + my $self = shift; + + # pointer event - doesn't seem to work? + my $socket = $self->socket; + $socket->print( + pack( + 'CCnn', + 5, # message_type + 0, # button_mask + $self->width, # x + $self->height, # y + ) + ); +} + +sub _send_update_request { + my $self = shift; + + # frame buffer update request + my $socket = $self->socket; + my $incremental = $self->_framebuffer ? 1 : 0; + $socket->print( + pack( + 'CCnnnn', + 3, # message_type + $incremental, # incremental + 0, # x + 0, # y + $self->width, + $self->height, + ) + ); +} + +sub _receive_message { + my $self = shift; + + my $socket = $self->socket; + $socket->read( my $message_type, 1 ) || die 'unexpected end of data'; + $message_type = unpack( 'C', $message_type ); + + # warn $message_type; + + # This result is unused. It's meaning is different for the different methods + my $result = + !defined $message_type ? die 'bad message type received' + : $message_type == 0 ? $self->_receive_update() + : $message_type == 1 ? $self->_receive_colour_map() + : $message_type == 2 ? $self->_receive_bell() + : $message_type == 3 ? $self->_receive_cut_text() + : die 'unsupported message type received'; + + return $message_type; +} + +sub _receive_update { + my $self = shift; + + my $image = $self->_framebuffer; + if ( !$image ) { + $self->_framebuffer( $image + = Image::Imlib2->new( $self->width, $self->height ) ); + if ( $self->_image_format ) { + $image->image_set_format( $self->_image_format ); + } + if ( $CAN_CREATE_RAW_IMAGE ) { + # We're going to be splatting pixels, so make sure every pixel is opaque + $image->set_colour( 0, 0, 0, 255 ); + $image->fill_rectangle( 0, 0, $self->width, $self->height ); + } + } + + my $socket = $self->socket; + $socket->read( my $header, 3 ) || die 'unexpected end of data'; + my $number_of_rectangles = unpack( 'xn', $header ); + + # warn $number_of_rectangles; + + my $depth = $self->depth; + + my $big_endian = $self->_big_endian; + my $read_and_set_colour = + $depth == 24 ? ($big_endian ? \&_read_and_set_colour_24_be : \&_read_and_set_colour_24_le) + : $depth == 16 ? ($big_endian ? \&_read_and_set_colour_16_be : \&_read_and_set_colour_16_le) + : $depth == 8 ? \&_read_and_set_colour_8 + : die 'unsupported depth'; + + foreach ( 1 .. $number_of_rectangles ) { + $socket->read( my $data, 12 ) || die 'unexpected end of data'; + my ( $x, $y, $w, $h, $encoding_type ) = unpack 'nnnnN', $data; + + # unsigned -> signed conversion + $encoding_type = unpack 'l', pack 'L', $encoding_type; + + # warn "$x,$y $w x $h $encoding_type"; + + ### Raw encoding ### + if ( $encoding_type == 0 ) { + + if ( $CAN_CREATE_RAW_IMAGE && $depth == 24 + && $AM_BIG_ENDIAN == $self->_big_endian ) { + + # Performance boost: splat raw pixels into the image + $socket->read( my $data, $w * $h * 4 ); + my $raw = Image::Imlib2->new_using_data( $w, $h, $data ); + $raw->has_alpha( 0 ); + $image->blend( $raw, 0, 0, 0, $w, $h, $x, $y, $w, $h ); + + } else { + + for my $py ( $y .. $y + $h - 1 ) { + for my $px ( $x .. $x + $w - 1 ) { + $self->$read_and_set_colour(); + $image->draw_point( $px, $py ); + } + } + + } + + ### CopyRect encooding ### + } elsif ( $encoding_type == 1 ) { + + $socket->read( my $srcpos, 4 ) || die 'unexpected end of data'; + my ( $srcx, $srcy ) = unpack 'nn', $srcpos; + + my $copy = $image->crop( $srcx, $srcy, $w, $h ); + $image->blend( $copy, 0, 0, 0, $w, $h, $x, $y, $w, $h ); + + ### RRE and CoRRE encodings ### + } elsif ( $encoding_type == 2 || $encoding_type == 4 ) { + + $socket->read( my $num_sub_rects, 4 ) + || die 'unexpected end of data'; + $num_sub_rects = unpack 'N', $num_sub_rects; + + $self->$read_and_set_colour(); + $image->fill_rectangle( $x, $y, $w, $h ); + + # RRE is U16, CoRRE is U8 + my $geombytes = $encoding_type == 2 ? 8 : 4; + my $format = $encoding_type == 2 ? 'nnnn' : 'CCCC'; + + for my $i ( 1 .. $num_sub_rects ) { + + $self->$read_and_set_colour(); + $socket->read( my $subrect, $geombytes ) + || die 'unexpected end of data'; + my ( $sx, $sy, $sw, $sh ) = unpack $format, $subrect; + $image->fill_rectangle( $x + $sx, $y + $sy, $sw, $sh ); + + } + + ### Hextile encoding ### + } elsif ( $encoding_type == 5 ) { + + my $maxx = $x + $w; + my $maxy = $y + $h; + my $background; + my $foreground; + + # Step over 16x16 tiles in the target rectangle + for ( my $ry = $y; $ry < $maxy; $ry += 16 ) { + my $rh = $maxy - $ry > 16 ? 16 : $maxy - $ry; + for ( my $rx = $x; $rx < $maxx; $rx += 16 ) { + my $rw = $maxx - $rx > 16 ? 16 : $maxx - $rx; + $socket->read( my $mask, 1 ) + || die 'unexpected end of data'; + $mask = unpack 'C', $mask; + + if ( $mask & 0x1 ) { # Raw tile + for my $py ( $ry .. $ry + $rh - 1 ) { + for my $px ( $rx .. $rx + $rw - 1 ) { + $self->$read_and_set_colour(); + $image->draw_point( $px, $py ); + } + } + + } else { + + if ( $mask & 0x2 ) { # background set + $background = $self->$read_and_set_colour(); + } + if ( $mask & 0x4 ) { # foreground set + $foreground = $self->$read_and_set_colour(); + } + if ( $mask & 0x8 ) { # has subrects + + $socket->read( my $nsubrects, 1 ) + || die 'unexpected end of data'; + $nsubrects = unpack 'C', $nsubrects; + + if ( !$mask & 0x10 ) { # use foreground colour + $image->set_colour( @{$foreground} ); + } + for my $i ( 1 .. $nsubrects ) { + if ( $mask & 0x10 ) { # use per-subrect colour + $self->$read_and_set_colour(); + } + $socket->read( my $pos, 1 ) + || die 'unexpected end of data'; + $pos = unpack 'C', $pos; + $socket->read( my $size, 1 ) + || die 'unexpected end of data'; + $size = unpack 'C', $size; + my $sx = $pos >> 4; + my $sy = $pos & 0xff; + my $sw = 1 + ( $size >> 4 ); + my $sh = 1 + ( $size & 0xff ); + $image->fill_rectangle( $rx + $sx, $ry + $sy, + $sw, $sh ); + } + + } else { # no subrects + $image->set_colour( @{$background} ); + $image->fill_rectangle( $rx, $ry, $rw, $rh ); + } + } + } + } + + ### Cursor ### + } elsif ( $encoding_type == -239 ) { + + # realvnc 3.3 sends empty cursor messages, so skip + next unless $w || $h; + + my $cursordata = $self->_cursordata; + if ( !$cursordata ) { + $self->_cursordata( $cursordata = { } ); + } + $cursordata->{image} = Image::Imlib2->new( $w, $h ); + $cursordata->{hotspotx} = $x; + $cursordata->{hotspoty} = $y; + $cursordata->{width} = $w; + $cursordata->{height} = $h; + + my $cursor = $cursordata->{image} || die "Failed to create cursor buffer $w x $h"; + $cursor->has_alpha(1); + + my @pixbuf; + for my $i ( 1 .. $w*$h ) { + push @pixbuf, $self->$read_and_set_colour(); + } + my $masksize = int( ( $w + 7 ) / 8 ) * $h; + my $maskrowsize = int( ( $w + 7 ) / 8 ) * 8; + $socket->read( my $mask, $masksize ) || die 'unexpected end of data'; + $mask = unpack 'B*', $mask; + #print "masksize: $masksize\n"; + #print "maskrowsize: $maskrowsize\n"; + #print "mask: $mask\n"; + + #open my $fh, '>', $ENV{HOME}.'/Desktop/cursor.txt'; + $cursor->will_blend( 0 ) if ( $CAN_CHANGE_BLEND ); + for my $cy (0 .. $h-1) { + for my $cx (0 .. $w-1) { + my $pixel = shift @pixbuf; + $pixel || die 'not enough pixels'; + if (!substr($mask, $cx + $cy*$maskrowsize, 1)) { + @{$pixel} = (0, 0, 0, 0); + } + #print "$cx, $cy: @$pixel\n"; + #print $fh "$cx, $cy: @$pixel\n"; + $cursor->set_colour( @{$pixel} ); + $cursor->draw_point( $cx, $cy ); + } + } + $cursor->will_blend( 1 ) if ( $CAN_CHANGE_BLEND ); + #$cursor->save('vnccursor.png'); + #print "wrote cursor\n"; + + ### CursorPos ### + } elsif ( $encoding_type == -232 ) { + + my $cursordata = $self->_cursordata; + if ( !$cursordata ) { + $self->_cursordata( $cursordata = { } ); + } + $cursordata->{x} = $x; + $cursordata->{y} = $y; + #print "Cursor pos: $x, $y\n"; + + } else { + die 'unsupported update encoding ' . $encoding_type; + + } + } + + return $number_of_rectangles; +} + +sub _read_and_set_colour_8 { + my $self = shift; + + $self->socket->read( my $pixel, 1 ) || die 'unexpected end of data'; + + my $colours = $self->_colourmap; + my $index = unpack( 'C', $pixel ); + my $colour = $colours->[$index]; + my @colour = ( $colour->{r}, $colour->{g}, $colour->{b}, 255 ); + $self->_framebuffer->set_colour(@colour); + + return \@colour; +} + +sub _read_and_set_colour_16_le { + my $self = shift; + + $self->socket->read( my $pixel, 2 ) || die 'unexpected end of data'; + my $colour = unpack 'v', $pixel; + my @colour = ( + ($colour >> 10 & 31) << 3, + ($colour >> 5 & 31) << 3, + ($colour & 31) << 3, + 255 + ); + $self->_framebuffer->set_colour(@colour); + + return \@colour; +} + +sub _read_and_set_colour_16_be { + my $self = shift; + + $self->socket->read( my $pixel, 2 ) || die 'unexpected end of data'; + my $colour = unpack 'n', $pixel; + my @colour = ( + ($colour >> 10 & 31) << 3, + ($colour >> 5 & 31) << 3, + ($colour & 31) << 3, + 255 + ); + $self->_framebuffer->set_colour(@colour); + + return \@colour; +} + +sub _read_and_set_colour_24_le { + my $self = shift; + + $self->socket->read( my $pixel, 4 ) || die 'unexpected end of data'; + my $colour = unpack 'V', $pixel; + my @colour = ( + $colour >> 16 & 255, + $colour >> 8 & 255, + $colour & 255, + 255, + ); + $self->_framebuffer->set_colour(@colour); + + return \@colour; +} + +sub _read_and_set_colour_24_be { + my $self = shift; + + $self->socket->read( my $pixel, 4 ) || die 'unexpected end of data'; + my $colour = unpack 'N', $pixel; + my @colour = ( + $colour >> 16 & 255, + $colour >> 8 & 255, + $colour & 255, + 255, + ); + $self->_framebuffer->set_colour(@colour); + + return \@colour; +} + + +# The following is the full version that supports all 8, 16, and 32 +# bpp and arbitrary pixel formats. This version is only used when one +# of the faster functions declared above cannot be used due to +# specific VNC settings. + +sub _read_and_set_colour { + my $self = shift; + my $pixel = shift; + + my $colours = $self->_colourmap; + my $bytes_per_pixel = $self->_bpp / 8; + if ( !$pixel ) { + $self->socket->read( $pixel, $bytes_per_pixel ) + || die 'unexpected end of data'; + } + my @colour; + if ($colours) { # indexed colour, depth is 8 + my $index = unpack( 'C', $pixel ); + my $colour = $colours->[$index]; + @colour = ( $colour->{r}, $colour->{g}, $colour->{b}, 255 ); + } else { # true colour, depth is 24 or 16 + my $pixinfo = $self->_pixinfo; + my $format = + $bytes_per_pixel == 4 ? ($self->_big_endian ? 'N' : 'V') + : $bytes_per_pixel == 2 ? ($self->_big_endian ? 'n' : 'v') + : die 'Unsupported bits-per-pixel value'; + my $colour = unpack $format, $pixel; + my $r = $colour >> $pixinfo->{red_shift} & $pixinfo->{red_max}; + my $g = $colour >> $pixinfo->{green_shift} & $pixinfo->{green_max}; + my $b = $colour >> $pixinfo->{blue_shift} & $pixinfo->{blue_max}; + if ( $bytes_per_pixel == 4 ) { + @colour = ( $r, $g, $b, 255 ); + } else { + @colour = ( + $r * 255 / $pixinfo->{red_max}, + $g * 255 / $pixinfo->{green_max}, + $b * 255 / $pixinfo->{blue_max}, 255 + ); + } + } + $self->_framebuffer->set_colour(@colour); + return \@colour; +} + +sub _receive_colour_map { + my $self = shift; + + # set colour map entries + my $socket = $self->socket; + $socket->read( my $padding, 1 ) || die 'unexpected end of data'; + $socket->read( my $first_colour, 2 ) || die 'unexpected end of data'; + $first_colour = unpack( 'n', $first_colour ); + $socket->read( my $number_of_colours, 2 ) || die 'unexpected end of data'; + $number_of_colours = unpack( 'n', $number_of_colours ); + + # warn "colours: $first_colour.. ($number_of_colours)"; + + my @colours; + foreach my $i ( $first_colour .. $first_colour + $number_of_colours - 1 ) + { + $socket->read( my $r, 2 ) || die 'unexpected end of data'; + $r = unpack( 'n', $r ); + $socket->read( my $g, 2 ) || die 'unexpected end of data'; + $g = unpack( 'n', $g ); + $socket->read( my $b, 2 ) || die 'unexpected end of data'; + $b = unpack( 'n', $b ); + + # warn "$i $r/$g/$b"; + + # The 8-bit colours are in the top byte of each field + $colours[$i] = { r => $r >> 8, g => $g >> 8, b => $b >> 8 }; + } + $self->_colourmap( \@colours ); + return 1; +} + +sub _receive_bell { + my $self = shift; + + # And discard it... + + return 1; +} + +sub _receive_cut_text { + my $self = shift; + + my $socket = $self->socket; + $socket->read( my $cut_msg, 7 ) || die 'unexpected end of data'; + my $cut_length = unpack 'xxxN', $cut_msg; + $socket->read( my $cut_string, $cut_length ) || die 'unexpected end of data'; + # And discard it... + + return 1; +} + +1; + +__END__ + +=head1 NAME + +Net::VNC - A simple VNC client + +=head1 SYNOPSIS + + use Net::VNC; + + my $vnc = Net::VNC->new({hostname => $hostname, password => $password}); + $vnc->depth(24); + $vnc->login; + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + + my $image = $vnc->capture; + $image->save("out.png"); + +=head1 DESCRIPTION + +Virtual Network Computing (VNC) is a desktop sharing system which uses +the RFB (Remote FrameBuffer) protocol to remotely control another +computer. This module acts as a VNC client and communicates to a VNC +server using the RFB protocol, allowing you to capture the screen of +the remote computer. + +This module dies upon connection errors (with a timeout of 15 seconds) +and protocol errors. + +This implementation is based largely on the RFB Protocol +Specification, L. That +document has an error in the DES encryption description, which is +clarified via L. + +=head1 METHODS + +=head2 new + +The constructor. Given a hostname and a password returns a L object: + + my $vnc = Net::VNC->new({hostname => $hostname, password => $password}); + +Optionally, you can also specify a port, which defaults to 5900. + +=head2 login + +Logs into the remote computer: + + $vnc->login; + +=head2 name + +Returns the name of the remote computer: + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + +=head2 width + +Returns the width of the remote screen: + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + +=head2 height + +Returns the height of the remote screen: + + print $vnc->name . ": " . $vnc->width . ' x ' . $vnc->height . "\n"; + +=head2 capture + +Captures the screen of the remote computer, returning an L object: + + my $image = $vnc->capture; + $image->save("out.png"); + +You may call capture() multiple times. Each time, the C<$image> +buffer is overwritten with the updated screen. So, to create a +series of ten screen shots: + + for my $n (1..10) { + my $filename = sprintf 'snapshot%02d.png', $n++; + $vnc->capture()->save($filename); + print "Wrote $filename\n"; + } + +=head2 depth + +Specify the bit depth for the screen. The supported choices are 24, +16 or 8. If unspecified, the server's default value is used. This +property should be set before the call to login(). + +=head2 save_bandwidth + +Accepts a boolean, defaults to false. Specifies whether to use more +CPU-intensive algorithms to compress the VNC datastream. LAN or +localhost connections may prefer to leave this false. This property +should be set before the call to login(). + +=head2 list_encodings + +Returns a list of encoding number/encoding name pairs. This can be used as a class method like so: + + my %encodings = Net::VNC->list_encodings(); + +=head1 BUGS AND LIMITATIONS + +=head2 Bit depth + +We do not yet support 8-bit true-colour mode, which is commonly +supported by servers but is rarely employed by clients. + +=head2 Byte order + +We have currently tested this package against servers with the same +byte order as the client. This might break with a little-endian +server/big-endian client or vice versa. We're working on tests for +those latter cases. Testing and patching help would be appreciated. + +=head2 Efficiency + +We've implemented a subset of the data compression algorithms +supported by most VNC servers. We hope to add more of the +high-compression transfer encodings in the future. + +=head1 AUTHORS + +Leon Brocard acme@astray.com + +Chris Dolan clotho@cpan.org + +Many thanks for Foxtons Ltd for giving Leon the opportunity to write +the original version of this module. + +Copyright (C) 2006, Leon Brocard + +This module is free software; you can redistribute it or modify it +under the same terms as Perl itself. + diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..976d7cd --- /dev/null +++ b/t/pod.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..703f91d --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,6 @@ +#!perl -T + +use Test::More; +eval "use Test::Pod::Coverage 1.04"; +plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; +all_pod_coverage_ok();