--- /dev/null
+package VNC::Codec;\r
+\r
+require 5.002; # becase we use prototypes\r
+\r
+use Socket;\r
+use warnings;\r
+use strict;\r
+use vars qw(@ISA @EXPORT_OK);\r
+require Exporter;\r
+@ISA = qw(Exporter);\r
+@EXPORT_OK = qw(VNC_PIXELFORMAT_32BPP_RGB888 VNC_PIXELFORMAT_16BPP_RGB565 VNC_PIXELFORMAT_8BPP_RGB332);\r
+\r
+\r
+sub buffer2hex($) {\r
+ my ($t) = @_ ;\r
+\r
+ my $result = '';\r
+\r
+ my @b = split (//, $t) ;\r
+\r
+ foreach (@b) {\r
+ $result .= sprintf("%02X ", ord($_)) ;\r
+ }\r
+\r
+ return $result ;\r
+}\r
+\r
+########## \r
+#\r
+# helper function to build the PIXELFORMAT binary struct (please see VNC documentation\r
+#\r
+sub BUILD_PIXEL_FORMAT {\r
+ my ($bits_per_pixel, \r
+ $depth ,\r
+ $big_endian,\r
+ $true_color,\r
+ $red_max,$green_max,$blue_max,\r
+ $red_shift,$green_shift, $blue_shift) = @_ ;\r
+\r
+ my $buffer = pack ("CCCCnnnCCCCn", $bits_per_pixel, \r
+ $depth ,\r
+ $big_endian,\r
+ $true_color,\r
+ $red_max,$green_max,$blue_max,\r
+ $red_shift,$green_shift, $blue_shift ) ;\r
+\r
+ return $buffer;\r
+}\r
+\r
+sub VNC_PIXELFORMAT_32BPP_RGB888 {\r
+ return BUILD_PIXEL_FORMAT(32,24,1,1,255,255,255,16,8,0);\r
+}\r
+\r
+sub VNC_PIXELFORMAT_16BPP_RGB565 {\r
+ return BUILD_PIXEL_FORMAT(16,16,1,1,31,63,31,11,5,0);\r
+}\r
+\r
+sub VNC_PIXELFORMAT_8BPP_RGB332 {\r
+ return BUILD_PIXEL_FORMAT(8,8,1,1,7,7,3,0,3,6);\r
+}\r
+\r
+#######\r
+# Constructs a new VNC Codec object\r
+#\r
+sub new {\r
+ my $proto = shift;\r
+ my $class = $proto;\r
+\r
+ my $self = {};\r
+ bless ($self, $class);\r
+\r
+ #use default PIXELFORMAT of 32bpp, RGB888\r
+ $self->{RED_MAX} = 255 ;\r
+ $self->{GREEN_MAX} = 255 ;\r
+ $self->{BLUE_MAX} = 255 ;\r
+ $self->{RED_SHIFT} = 16;\r
+ $self->{GREEN_SHIFT} = 8 ;\r
+ $self->{BLUE_SHIFT} = 0 ;\r
+ $self->{BITS_PER_PIXEL} = 32; \r
+ $self->{DEPTH} = 24 ;\r
+ $self->{TRUE_COLOR} = 1 ;\r
+ $self->{BIG_ENDIAN} = 1 ;\r
+\r
+ \r
+ #This is used for the internal representation o RGB data\r
+ $self->{INTERNAL_RED_MAX} = 255 ;\r
+ $self->{INTERNAL_GREEN_MAX} = 255 ;\r
+ $self->{INTERNAL_BLUE_MAX} = 255 ;\r
+\r
+ return $self;\r
+}\r
+\r
+sub set_pixel_format {\r
+ my ($self, $bits_per_pixel, \r
+ $depth ,\r
+ $big_endian,\r
+ $true_color,\r
+ $red_max,$green_max,$blue_max,\r
+ $red_shift,$green_shift, $blue_shift) = @_ ;\r
+\r
+ $self->{RED_MAX} = $red_max ;\r
+ $self->{GREEN_MAX} = $green_max ;\r
+ $self->{BLUE_MAX} = $blue_max ;\r
+ $self->{RED_SHIFT} = $red_shift;\r
+ $self->{GREEN_SHIFT} = $green_shift ;\r
+ $self->{BLUE_SHIFT} = $blue_shift ;\r
+ $self->{BITS_PER_PIXEL} = $bits_per_pixel; \r
+ $self->{DEPTH} = $depth ;\r
+ $self->{TRUE_COLOR} = $true_color ;\r
+ $self->{BIG_ENDIAN} = $big_endian ;\r
+\r
+ return 1;\r
+}\r
+\r
+\r
+#############################\r
+#\r
+# This function builds a raw pixel, according to the specified format (bits/pixel,and max/shift values)\r
+# It returns a raw (binary) scalar with the encoded pixel\r
+#\r
+sub encode_pixel {\r
+ my ($self,$r,$g,$b) = @_ ;\r
+\r
+ warn "VNC::Codec::encode_pixel called with self=undef" unless (defined $self);\r
+ warn "VNC::Codec::encode_pixel called with r/g/b=undef" unless (defined $r and defined $g and defined $b);\r
+\r
+ my $red_max = $self->{RED_MAX};\r
+ my $green_max = $self->{GREEN_MAX};\r
+ my $blue_max = $self->{BLUE_MAX};\r
+\r
+ my $red_shift = $self->{RED_SHIFT};\r
+ my $green_shift = $self->{GREEN_SHIFT};\r
+ my $blue_shift = $self->{BLUE_SHIFT};\r
+\r
+ my $bits_per_pixel = $self->{BITS_PER_PIXEL};\r
+\r
+ my $z = ($r * ($red_max))/$self->{INTERNAL_RED_MAX} << $red_shift ;\r
+ $z += ($g * ($green_max))/$self->{INTERNAL_GREEN_MAX} << $green_shift;\r
+ $z += ($b * ($blue_max))/$self->{INTERNAL_BLUE_MAX} << $blue_shift;\r
+\r
+ my $raw;\r
+\r
+ if ($bits_per_pixel==8) {\r
+ $raw .= pack("C",$z) ;\r
+ } elsif ($bits_per_pixel==16) {\r
+ $raw .= pack("S",$z) ;\r
+ } elsif ($bits_per_pixel==32) {\r
+ $raw .= pack("i",$z) ;\r
+ }\r
+\r
+# print "encode_pixel($r,$g,$b) = ",buffer2hex($raw),"\n";\r
+\r
+ return $raw;\r
+}\r
+\r
+#############################\r
+#\r
+# This function builds a RAW encoded rectangle, with a singe RGB color\r
+# It returns a raw (binary) scalar with the encoded rect data\r
+#\r
+sub encode_raw_rect {\r
+ my ($self,$raw_pixel,$x,$y,$w,$h) = @_ ;\r
+\r
+ my $i;\r
+ my $j;\r
+ my $raw ;\r
+ \r
+ for ($i=0;$i<$h;$i++) {\r
+ for ($j=0;$j<$w;$j++) {\r
+ $raw .= $raw_pixel; \r
+ }\r
+ }\r
+\r
+ my $buffer = pack("nnnnN", $x,$y,$w,$h,0 ) . $raw ;\r
+ \r
+# print "encode_raw_rect = ",buffer2hex($buffer),"\n";\r
+ return $buffer;\r
+}\r
+\r
+#############################\r
+#\r
+# This function builds an RRE sub-rect\r
+# It returns a raw (binary) scalar with the encoded subrect data\r
+#\r
+sub encode_rre_subrect {\r
+ my ($self,$raw_pixel,$x,$y,$w,$h) = @_ ;\r
+\r
+ warn "VNC::Codec::encode_rre_subrect called with self=undef" unless (defined $self);\r
+ warn "VNC::Codec::encode_rre_subrect called with raw_pixel=undef" unless (defined $raw_pixel);\r
+ warn "VNC::Codec::encode_rre_subrect called with x/y/w/h=undef" unless (defined $x and defined $y and defined $w and defined $h);\r
+ \r
+ return $raw_pixel . pack("nnnn",$x,$y,$w,$h);\r
+}\r
+\r
+#############################\r
+#\r
+# This function builds an RRE sub-rect\r
+# It returns a raw (binary) scalar with the encoded subrect data\r
+#\r
+sub encode_rre {\r
+ my ($self,$raw_background_pixel,$x,$y,$w,$h,@subrects) = @_ ;\r
+\r
+ warn "VNC::Codec::encode_rre called with self=undef" unless (defined $self);\r
+ warn "VNC::Codec::encode_rre called with x/y/w/h=undef" unless (defined $x and defined $y and defined $w and defined $h);\r
+ warn "VNC::Codec::encode_rre called with raw_background_pixel=undef" unless (defined $raw_background_pixel);\r
+\r
+ my $count = scalar @subrects;\r
+ \r
+ return pack("nnnnNN",$x,$y,$w,$h,2,$count) . $raw_background_pixel . join('',@subrects); # 2 = RRE encoding\r
+}\r
+\r
+sub encode_framebuffer_update {\r
+ my ($self,@rectangles) = @_ ;\r
+\r
+ my $count = scalar @rectangles;\r
+ my $buffer = pack("CCn",0,0,$count) . join('',@rectangles) ;\r
+\r
+ return $buffer;\r
+}\r
+\r
+1;
\ No newline at end of file
--- /dev/null
+package VNC::Server;\r
+\r
+require 5.002; # becase we use prototypes\r
+\r
+use IO::Select;\r
+use IO::Socket;\r
+use IO::Socket::INET;\r
+use Socket;\r
+use warnings;\r
+use strict;\r
+use VNC::ServerConnection;\r
+use vars qw(@ISA @EXPORT_OK);\r
+require Exporter;\r
+@ISA = qw(Exporter);\r
+@EXPORT_OK = qw();\r
+\r
+sub new {\r
+ my $proto = shift;\r
+ my $class = $proto;\r
+\r
+ my %args = @_ ;\r
+\r
+ my $self = {};\r
+ bless ($self, $class);\r
+\r
+ # Get the port number\r
+ my $port = $args{Port} ||= 0 ;\r
+ # Port number less than 100 is treated as display number\r
+ if ($port < 100 ) {$port += 5900;}\r
+ $self->{PORT} = $port ;\r
+\r
+ # Get the idle Interval\r
+ $self->{IDLE_INTERVAL} = $args{Idle} || 1 ;\r
+ $self->{IdleHandler} = $args{IdleHandler};\r
+ $self->{KeyEventHandler} = $args{KeyEventHandler};\r
+ $self->{PointerEventHandler} = $args{PointerEventHandler};\r
+ $self->{CutTextHandler} = $args{CutTextHandler};\r
+ $self->{UpdateDisplayHandler} = $args{UpdateDisplayHandler};\r
+ $self->{PixelFormat} = $args{PixelFormat};\r
+ $self->{Caption} = $args{Caption};\r
+ $self->{Width} = $args{Width};\r
+ $self->{Height} = $args{Height};\r
+ $self->{ClientConnectHandler} = $args{ClientConnectHandler};\r
+ $self->{ClientDisconnectHandler} = $args{ClientDisconnectHandler};\r
+ $self->{Password} = $args{Password};\r
+\r
+ return $self;\r
+}\r
+\r
+sub update_all_displays {\r
+ my ($self) = @_ ;\r
+\r
+ my $vncref = $self->{VNC_CONNECTIONS} ;\r
+ my %vncs = %{$vncref} ;\r
+\r
+ foreach (values %vncs) {\r
+ $_->update_display ;\r
+ }\r
+}\r
+\r
+sub disconnect_client {\r
+ my ($self, $vnc, $sock_handle) = @_ ;\r
+\r
+ my $vncref = $self->{VNC_CONNECTIONS} ;\r
+ my %vncs = %{$vncref} ;\r
+\r
+ my $sel = $self->{SELECTOR};\r
+\r
+ shutdown($sock_handle,2);\r
+\r
+ delete $vncs{$sock_handle};\r
+ $sel->remove($sock_handle) ;\r
+ $vnc = undef ;\r
+ $sock_handle = undef ;\r
+\r
+ print "Client Disconnectd\n";\r
+}\r
+\r
+sub vnc_server_loop {\r
+ my ($self) = @_ ;\r
+\r
+ my $listen_sock = new IO::Socket::INET(Listen => 1, LocalPort => $self->{PORT} );\r
+ my $sel = new IO::Select( $listen_sock );\r
+\r
+ my %vncs = () ;\r
+\r
+ $self->{VNC_CONNECTIONS} = \%vncs;\r
+ $self->{SELECTOR} = $sel ;\r
+\r
+ while (1) {\r
+ my @ready_handles; \r
+ if (@ready_handles = $sel->can_read( $self->{IDLE_INTERVAL} ) ) {\r
+ foreach my $fh (@ready_handles) {\r
+ if ($fh == $listen_sock) {\r
+ #accept new connection from client\r
+\r
+ my $client_sock = $listen_sock->accept;\r
+ $client_sock->blocking(1);\r
+ \r
+ my $vnc = new VNC::ServerConnection( Server => $self,\r
+ Caption => $self->{Caption},\r
+ Socket => $client_sock,\r
+ Width => $self->{Width},\r
+ Height => $self->{Height},\r
+ Password => $self->{Password},\r
+ PixelFormat => $self->{PixelFormat},\r
+ KeyEventHandler => $self->{KeyEventHandler},\r
+ PointerEventHandler => $self->{PointerEventHandler},\r
+ CutTextHandler => $self->{CutTextHandler},\r
+ UpdateDisplayHandler => $self->{UpdateDisplayHandler}\r
+ \r
+ );\r
+ print "Accepted new connection from ",$client_sock->sockhost(),"\n" ;\r
+\r
+ my $ok = 1 ;\r
+ my $handler = $self->{ClientConnectHandler};\r
+ if (defined $handler) {\r
+ $ok = &$handler($self, $client_sock, $vnc);\r
+ }\r
+\r
+ if (defined $ok) {\r
+ $sel->add($client_sock);\r
+ $vnc->start_conversation();\r
+ $vncs{$client_sock} = $vnc ;\r
+ } else {\r
+ $vnc = undef ;\r
+ shutdown($client_sock,2) ;\r
+ $client_sock = undef; \r
+ }\r
+ } else {\r
+ my $vnc = $vncs{$fh} ;\r
+\r
+ die "Error! got data from un-connected socket" unless (defined $vnc);\r
+\r
+ if (!defined $vnc->handle_client_data()) {\r
+ $vnc->disconnect;\r
+ }\r
+ }\r
+ }\r
+ } else {\r
+ my $sub = $self->{IdleHandler};\r
+ if (defined $sub) {\r
+ &$sub($self) ;\r
+ }\r
+ }\r
+ }\r
+}\r
+\r
+1;
\ No newline at end of file
--- /dev/null
+package VNC::ServerConnection;\r
+\r
+require 5.002; # becase we use prototypes\r
+\r
+use Socket;\r
+use warnings;\r
+use strict;\r
+use VNC::Codec;\r
+use vars qw(@ISA @EXPORT_OK);\r
+require Exporter;\r
+@ISA = qw(Exporter);\r
+@EXPORT_OK = qw();\r
+\r
+\r
+sub STATE_UNINITIALIZED {0};\r
+sub STATE_WAIT_FOR_PROTOCOL {1};\r
+sub STATE_WAIT_FOR_AUTHENTICATION {2};\r
+sub STATE_WAIT_FOR_CLIENT_INIT_MSG {3};\r
+sub STATE_WAIT_FOR_MSG_HEADER {4};\r
+sub STATE_WAIT_FOR_FIXED_LEN_MSG {5};\r
+sub STATE_WAIT_FOR_TEXT_CUT_LENGTH {6};\r
+sub STATE_WAIT_FOR_TEXT_CUT_CONTENT {7};\r
+sub STATE_WAIT_FOR_ENCODING_COUNT {8};\r
+sub STATE_WAIT_FOR_ENCODING_DATA {9};\r
+\r
+sub MSG_SET_PIXEL_FORMAT {0};\r
+sub MSG_FIX_COLOR_MAP_ENTRIES {1};\r
+sub MSG_SET_ENCODING {2};\r
+sub MSG_FRAME_BUFFER_UPDATE_REQUEST {3};\r
+sub MSG_KEY_EVENT {4};\r
+sub MSG_POINTER_EVENT {5};\r
+sub MSG_CLIENT_CUT_TEXT {6};\r
+\r
+my @rfb_message_handlers =( [\&do_set_pixel_format, 20], #SetPixelFormat \r
+ [\&do_fix_color_map_entries, 4], #FixColorMapEntries\r
+ [\&do_set_encoding, -1], #SetEncoding\r
+ [\&do_frame_buffer_update_request,10], #FramebufferUpdateRequest \r
+ [\&do_key_event, 8], #KeyEvent\r
+ [\&do_pointer_event,6], #Pointer Event\r
+ [\&do_client_cut_text,-1]\r
+ );\r
+\r
+######################\r
+#\r
+# Helper function to build the ServerInitMessage binary struct (please see the VNC documentation)\r
+#\r
+sub BUILD_SERVER_INIT_MSG {\r
+ my ($width, $height, $pixel_format, $name) = @_ ;\r
+\r
+ my $buffer = pack ( "nn", $width, $height ) . $pixel_format . pack("N", length($name)) . $name; \r
+\r
+ return $buffer ;\r
+}\r
+\r
+\r
+#######\r
+# Constructs a new, VNC server object, connected to one client using socket handle\r
+#\r
+sub new {\r
+ my $proto = shift;\r
+ my $class = $proto;\r
+\r
+ my %args = @_ ;\r
+\r
+ my $sock_handle = $args{Socket}; \r
+ die "$proto->new called without any socket handle!" unless (defined $sock_handle );\r
+\r
+ my $self = {};\r
+ bless ($self, $class);\r
+\r
+ $self->{HANDLE} = $sock_handle;\r
+\r
+ $self->{STATE} = STATE_UNINITIALIZED ;\r
+ $self->{RECV_BUFFER} = '' ;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 0 ;\r
+\r
+ $self->{CODEC} = new VNC::Codec();\r
+\r
+ #if this is defined, a response will be sent immediatly\r
+ #when a FrameBufferUpdateRequest is received\r
+ #if this is UNDEFINED, no response will be sent, and UPDATE_REQUEST_PENDING will be set\r
+ $self->{SEND_UPDATE_RESPONSE} = 1 ;\r
+\r
+ #if this is defined, it means an update request was received, \r
+ #but a response was not sent.\r
+ #so the next time you call udpate_frame_buffer a response will be sent immediately\r
+ $self->{UPDATE_REQUEST_PENDING} = 1 ;\r
+\r
+ $self->{Server} = $args{Server} ;\r
+\r
+ #handlers\r
+ $self->{KeyEventHandler} = $args{KeyEventHandler};\r
+ $self->{PointerEventHandler} = $args{PointerEventHandler};\r
+ $self->{CutTextHandler} = $args{CutTextHandler};\r
+ $self->{UpdateDisplayHandler} = $args{UpdateDisplayHandler};\r
+\r
+ #Get the pixel format\r
+ #if none specified, default to 32Bits/Pixel 24bit depth, RGB888\r
+ my $pixel_format = $args{PixelFormat} || VNC::Codec::VNC_PIXELFORMAT_32BPP_RGB888;\r
+ $self->{PixelFormat} = $pixel_format;\r
+ \r
+ my (undef, $myaddr) = sockaddr_in(getsockname($sock_handle));\r
+ $self->{Caption} = $args{Caption} || "PerlVNC Server at " . scalar gethostbyaddr($myaddr, AF_INET) . " [" . inet_ntoa($myaddr). "]" ;\r
+\r
+\r
+ $self->{Width} = $args{Width} || 200;\r
+ $self->{Height} = $args{Height} || 200;\r
+\r
+ $self->{PENDING_UPDATE_REQUEST_BUFFER} = pack("CCnnnn",0,0,0,0,10,10);\r
+\r
+ $self->{Password} = $args{Password};\r
+\r
+ return $self;\r
+}\r
+\r
+##########################################3\r
+#\r
+# Helper function to send data to the socket\r
+#\r
+sub send_buffer($$) {\r
+ my $self = shift ;\r
+ my $a = shift ;\r
+ die "send_buffer called, when self is undef" unless (defined $self);\r
+ return unless (defined $self->{HANDLE});\r
+\r
+ if (!defined $a) {\r
+ warn "send_buffer called, buffer is empty";\r
+ return ;\r
+ }\r
+\r
+ my $count = send($self->{HANDLE}, $a,0);\r
+\r
+ die "Error sending buffer ($a) " unless ($count == length $a);\r
+\r
+ return $count;\r
+}\r
+\r
+\r
+###############################\r
+# Given a SET_PIXEL_FORMAT buffer (20 bytes long, see VNC documentation)\r
+# Sets the pixel format of this session\r
+sub do_set_pixel_format {\r
+ my $self = shift ;\r
+ my $buffer = shift ;\r
+\r
+ die "do_set_pixel_format called, when self is undef" unless (defined $self);\r
+ die "do_set_pixel_format, buffer isn't 20 bytes long" unless (length $buffer==20);\r
+\r
+ my (undef,undef,undef,undef,$bits_per_pixel, \r
+ $depth ,\r
+ $big_endian,\r
+ $true_color,\r
+ $red_max,$green_max,$blue_max,\r
+ $red_shift,$green_shift, $blue_shift) = \r
+ unpack("CCCCCCCCnnnCCC", $buffer) ;\r
+\r
+ #\r
+ # TODO: Let's do some sanity checks\r
+ #\r
+\r
+ $self->{CODEC}->set_pixel_format($bits_per_pixel, \r
+ $depth, $big_endian, $true_color,\r
+ $red_max,$green_max,$blue_max,\r
+ $red_shift,$green_shift, $blue_shift);\r
+ \r
+ return ;\r
+}\r
+\r
+sub do_fix_color_map_entries() {\r
+ my $self = shift ;\r
+ die "do_fix_color_map_entries called, when self is undef" unless (defined $self);\r
+\r
+ my $buffer = shift;\r
+ die "do_set_pixel_format, buffer isn't 6 bytes long" unless (length $buffer==6);\r
+\r
+ die "Client Sent rfbFixColourMapEntriesMsg - UNSUPPORTED\n";\r
+\r
+ my (undef,$pad,$first_color,$n_colors) = unpack("CCnn", $buffer) ;\r
+\r
+ print "color map, first color = $first_color, total colors = $n_colors\n" ;\r
+ return ;\r
+}\r
+\r
+sub do_set_encoding() {\r
+ my $self = shift ;\r
+ die "do_set_encoding called, when self is undef" unless (defined $self);\r
+ \r
+ my $buffer = shift;\r
+\r
+ my (undef,undef,$nEncoding,@encodings) = unpack("CCnN*", $buffer) ;\r
+\r
+ #\r
+ # Debug Only\r
+ #\r
+ print "Client supports $nEncoding encodings: ",join(' ', @encodings),"\n";\r
+\r
+ return ;\r
+}\r
+\r
+sub update_display {\r
+ my $self = shift ;\r
+ die "update_display called, when self is undef" unless (defined $self);\r
+\r
+ #if we received an update request but did not send response, we'll send a response immediately\r
+ if (defined $self->{UPDATE_REQUEST_PENDING}) {\r
+\r
+ my (undef,$incremental, $x,$y,$w,$h) = unpack("CCnnnn", $self->{PENDING_UPDATE_REQUEST_BUFFER}) ;\r
+\r
+ my $handler = $self->{UpdateDisplayHandler};\r
+ if (defined $handler) {\r
+ my $data = &$handler($self, $incremental, $x, $y, $w, $h);\r
+\r
+ $self->send_buffer($data);\r
+ }\r
+\r
+ $self->{UPDATE_REQUEST_PENDING} = undef;\r
+ $self->{SEND_UPDATE_RESPONSE} = undef;\r
+ } else {\r
+\r
+ #if now update request is pending, \r
+ #we'll simply signal the next request to be answered immediately\r
+ $self->{SEND_UPDATE_RESPONSE} = 1 ;\r
+ }\r
+}\r
+sub disconnect {\r
+ my $self = shift;\r
+ \r
+ my $server = $self->{Server} ;\r
+\r
+ die "server=undef" unless (defined $server);\r
+\r
+ return unless $self->{HANDLE};\r
+\r
+ $server->disconnect_client($self,$self->{HANDLE}) ;\r
+\r
+ $self->{HANDLE} = undef ;\r
+ $self = undef ;\r
+}\r
+\r
+sub do_frame_buffer_update_request() {\r
+ my $self = shift ;\r
+ die "do_frame_buffer_update_request called, when self is undef" unless (defined $self);\r
+\r
+ my $buffer = shift;\r
+ die "do_frame_buffer_update_request, buffer isn't 10 bytes long" unless (length $buffer==10);\r
+\r
+ my (undef,$incremental, $x,$y,$w,$h) = unpack("CCnnnn", $buffer) ;\r
+\r
+\r
+# print "UpdateRequest: Incremental=$incremental, X,Y=($x,$y) WxH = ($w x $h)\n";\r
+\r
+ if (defined $self->{SEND_UPDATE_RESPONSE}) {\r
+ my $codec = $self->{CODEC};\r
+\r
+ # my $data = $codec->encode_framebuffer_update($codec->encode_raw_rect($codec->encode_pixel(0,0,255), $x,$y,$w,$h) ) ;\r
+\r
+# my $data = $codec->encode_framebuffer_update( $codec->encode_rre($codec->encode_pixel(0,255,0), $x,$y,$w,$h,\r
+# $codec->encode_rre_subrect( $codec->encode_pixel(255,255,255), 10,10,20,10),\r
+# $codec->encode_rre_subrect( $codec->encode_pixel(0,128,128), 10,20,10,20)\r
+# )\r
+# ) ; \r
+\r
+ my $handler = $self->{UpdateDisplayHandler};\r
+ if (defined $handler) {\r
+ my $data = &$handler($self, $incremental, $x, $y, $w, $h);\r
+\r
+ $self->send_buffer($data);\r
+ }\r
+\r
+ $self->{UPDATE_REQUEST_PENDING} = undef;\r
+ $self->{SEND_UPDATE_RESPONSE} = undef;\r
+\r
+ } else {\r
+\r
+ $self->{PENDING_UPDATE_REQUEST_BUFFER} = $buffer ;\r
+\r
+ $self->{UPDATE_REQUEST_PENDING} = 1;\r
+ }\r
+\r
+ return ;\r
+}\r
+\r
+sub do_key_event() {\r
+ my $self = shift ;\r
+ die "do_key_event called, when self is undef" unless (defined $self);\r
+\r
+ my $buffer = shift;\r
+ die "do_key_event, buffer isn't 8 bytes long" unless (length $buffer==8);\r
+\r
+ my (undef,$down,$pad,$key) = unpack("CCnN", $buffer) ;\r
+\r
+ my $handler = $self->{KeyEventHandler};\r
+ if (defined $handler) {\r
+ &$handler($self, $down, $key);\r
+ }\r
+ return ;\r
+}\r
+\r
+sub do_pointer_event() {\r
+ my $self = shift ;\r
+ die "do_pointer_event called, when self is undef" unless (defined $self);\r
+\r
+ my $buffer = shift;\r
+ die "do_pointer_event, buffer isn't 6 bytes long" unless (length $buffer==6);\r
+\r
+ my (undef,$mask,$x,$y) = unpack("CCnn", $buffer) ;\r
+\r
+ my $handler = $self->{PointerEventHandler};\r
+ if (defined $handler) {\r
+ &$handler($self, $mask, $x,$y);\r
+ }\r
+ return ;\r
+}\r
+\r
+sub do_client_cut_text() {\r
+ my $self = shift ;\r
+ die "do_client_cut_text called, when self is undef" unless (defined $self);\r
+\r
+ my $buffer = shift;\r
+ print "Client Sent client cut text\n";\r
+\r
+ my (undef,undef,$length,$text) = unpack("CnNA*", $buffer) ;\r
+\r
+ my $handler = $self->{CutTextHandler};\r
+ if (defined $handler) {\r
+ &$handler($self, $text);\r
+ }\r
+ return ;\r
+}\r
+\r
+sub start_conversation() {\r
+ my $self = shift ;\r
+ die "handle_client_data called, when self is undef" unless (defined $self);\r
+\r
+ my $fh = $self->{HANDLE};\r
+ die "start_convertsion, handle is undef" unless (defined $fh);\r
+\r
+ $self->send_buffer("RFB 003.003\n");\r
+ $self->{STATE} = STATE_WAIT_FOR_PROTOCOL ;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 12 ;\r
+}\r
+\r
+sub handle_client_data() {\r
+ my $self = shift ;\r
+ die "handle_client_data called, when self is undef" unless (defined $self);\r
+\r
+ my $fh = $self->{HANDLE};\r
+ die "start_convertsion, handle is undef" unless (defined $fh);\r
+\r
+ #Read data from the socket\r
+ my $data ;\r
+ my $read_rc = $fh->sysread($data, 32786) ;\r
+ \r
+ if (defined $read_rc) {\r
+ if ($read_rc > 0) {\r
+\r
+ #data read OK\r
+ #add it to our buffer, check if we got enough data for the current state\r
+ $self->{RECV_BUFFER} .= $data ;\r
+\r
+ while ( length $self->{RECV_BUFFER} >= $self->{EXPECTED_BUFFER_SIZE} ) {\r
+ #got enough data from current state, so handle the state\r
+ \r
+ #debug\r
+# print "Handle Buffer: expected size = ",$self->{EXPECTED_BUFFER_SIZE}," recv_buffer size = ", length($self->{RECV_BUFFER}),"\n";\r
+ \r
+ #take just the needed number of byte\r
+ my $buffer = substr $self->{RECV_BUFFER},0,$self->{EXPECTED_BUFFER_SIZE};\r
+\r
+ #leave the remaining bytes in the buffe\r
+ $self->{RECV_BUFFER} = substr ($self->{RECV_BUFFER}, $self->{EXPECTED_BUFFER_SIZE}, length($self->{RECV_BUFFER})-$self->{EXPECTED_BUFFER_SIZE} ); \r
+ \r
+ #debug\r
+# print "After Buffer Split: buffer size = ", length($buffer), " recv_buffer size = ",length($self->{RECV_BUFFER}),"\n" ;\r
+ \r
+ $self->handle_state($buffer);\r
+ }\r
+ } else {\r
+ #read_rc == 0\r
+ #it means the socket was closed by the client\r
+ \r
+ \r
+ return undef;\r
+ }\r
+ } else { \r
+# die "Errro while reading socket";\r
+ \r
+ return undef; \r
+ }\r
+ \r
+ return 1;\r
+}\r
+\r
+sub handle_state {\r
+ my $self = shift ;\r
+ die "handle_state called, when self is undef" unless (defined $self);\r
+ \r
+ my $buffer = shift ;\r
+ die "handle_state called, when buffer is undef" unless (defined $buffer);\r
+ \r
+ my $current_state = $self->{STATE};\r
+\r
+ #\r
+ # Got protocol version string from the cilent\r
+ # \r
+ if ($current_state==STATE_WAIT_FOR_PROTOCOL) {\r
+ if (length($buffer) != 12) {\r
+ warn "Error: WAIT_FOR_PROTOCOL state, buffer != 12 bytes" ;\r
+ return undef;\r
+ };\r
+ \r
+ my ($major, $minor) = $buffer =~ m/^RFB (\d{3})\.(\d{3})$/ ;\r
+ die "unknown protocol version ($buffer)" unless (defined $major && defined $minor);\r
+ if ($major != 3) {\r
+ $self->send_buffer("Uknown version. i need major protocol version = 3\nBye Bye\n");\r
+ return undef;\r
+ }\r
+ print "Client requested protocol version $major.$minor\n";\r
+ \r
+ #\r
+ # Next step:\r
+ # Ask for password, if needed\r
+ #\r
+\r
+ if (defined $self->{Password}) {\r
+ $self->{STATE} = STATE_WAIT_FOR_AUTHENTICATION ;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 16 ;\r
+ \r
+ $self->send_buffer(pack("N",2));\r
+\r
+ # TODO:\r
+ # send a challange and check the resonse using DES\r
+ $self->send_buffer("0123456789abcdef");\r
+ }\r
+ else {\r
+ # no password needed\r
+ $self->{STATE} = STATE_WAIT_FOR_CLIENT_INIT_MSG ;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 1 ;\r
+ \r
+ $self->send_buffer(pack("N",1));\r
+ }\r
+ } \r
+ elsif\r
+ #\r
+ # Got Authentication response from the client\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_AUTHENTICATION) {\r
+ if (length($buffer) != 16) {\r
+ warn "Error: WAIT_FOR_AUTHENTICATION state, buffer != 16 bytes" ;\r
+ return undef;\r
+ };\r
+ \r
+ #for now, accept any password\r
+ $self->send_buffer(pack("N",0));\r
+\r
+ #\r
+ # Next Stap:\r
+ # Client Init Msg\r
+ $self->{STATE} = STATE_WAIT_FOR_CLIENT_INIT_MSG;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 1 ;\r
+ }\r
+ elsif\r
+ #\r
+ # Got client Init Message from the client\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_CLIENT_INIT_MSG) {\r
+ if (length($buffer) != 1) {\r
+ warn "Error: WAIT_FOR_CLIENT_INIT_MSG state, buffer != 1 bytes" ;\r
+ return undef;\r
+ };\r
+ my $srvr_init_msg = BUILD_SERVER_INIT_MSG( $self->{Width}, \r
+ $self->{Height},\r
+ $self->{PixelFormat},\r
+ $self->{Caption} );\r
+ $self->send_buffer($srvr_init_msg);\r
+ \r
+ #\r
+ # Next Step\r
+ # client normal messages\r
+ $self->{STATE} = STATE_WAIT_FOR_MSG_HEADER;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 1 ;\r
+ }\r
+ elsif\r
+ #\r
+ # Got Message header from the client\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_MSG_HEADER) {\r
+ if (length($buffer) != 1) {\r
+ warn "Error: STATE_WAIT_FOR_MSG_HEADER state, buffer != 1 bytes" ;\r
+ return undef;\r
+ };\r
+ \r
+ my $msg = ord($buffer) ;\r
+ \r
+ my ($subroutine, $byte_count) = @{$rfb_message_handlers[$msg]};\r
+ \r
+ die "Error: unknown message $msg" unless (defined $subroutine && defined $byte_count); \r
+\r
+ # These are FixedLength messages, we can handle them all in the same way\r
+ if ( $msg==MSG_SET_PIXEL_FORMAT\r
+ or \r
+ $msg==MSG_FRAME_BUFFER_UPDATE_REQUEST\r
+ or\r
+ $msg==MSG_KEY_EVENT\r
+ or \r
+ $msg==MSG_POINTER_EVENT ) \r
+ {\r
+ #\r
+ # Next Step\r
+ # client normal messages\r
+ $self->{STATE} = STATE_WAIT_FOR_FIXED_LEN_MSG;\r
+ $self->{EXPECTED_BUFFER_SIZE} = $byte_count ;\r
+ \r
+ #re-insert this byte into the buffer\r
+ $self->{RECV_BUFFER} = pack("C",$msg) . $self->{RECV_BUFFER} ;\r
+ $self->{CURRENT_MSG} = $msg ;\r
+ \r
+ } elsif \r
+ ($msg==MSG_SET_ENCODING) {\r
+ $self->{STATE} = STATE_WAIT_FOR_ENCODING_COUNT;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 3 ;\r
+ \r
+ $self->{ENCODING_BUFFER} = $buffer;\r
+ } elsif\r
+ ($msg==MSG_CLIENT_CUT_TEXT) {\r
+ $self->{STATE} = STATE_WAIT_FOR_TEXT_CUT_LENGTH;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 7 ;\r
+ $self->{CUT_TEXT_BUFFER} = $buffer;\r
+ }\r
+ }\r
+ elsif\r
+ #\r
+ # Got Message header from the client\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_FIXED_LEN_MSG) {\r
+ my $msg = $self->{CURRENT_MSG};\r
+ my ($subroutine, $byte_count) = @{$rfb_message_handlers[ $msg ]};\r
+ die "Error: unknown message $msg" unless (defined $subroutine && defined $byte_count); \r
+\r
+ if (length($buffer) != $byte_count) {\r
+ warn "Error: STATE_WAIT_FOR_FIXED_LEN_MSG state (msg=$msg), buffer != $byte_count bytes" ;\r
+ return undef;\r
+ };\r
+\r
+ #\r
+ # Next Step\r
+ # Execute the client's request\r
+ &$subroutine($self,$buffer);\r
+\r
+ $self->{STATE} = STATE_WAIT_FOR_MSG_HEADER;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 1 ;\r
+ } elsif\r
+ #\r
+ # Got Encoding Count\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_ENCODING_COUNT) {\r
+ if (length($buffer) != 3) {\r
+ warn "Error: STATE_WAIT_FOR_ENCODING_COUNT state, buffer != 3 bytes" ;\r
+ return undef;\r
+ };\r
+ \r
+ my (undef,$nEncoding) = unpack("Cn", $buffer) ;\r
+ print "Client supports $nEncoding encodings\n" ;\r
+ \r
+ $self->{STATE} = STATE_WAIT_FOR_ENCODING_DATA;\r
+ $self->{EXPECTED_BUFFER_SIZE} = $nEncoding*4 ;\r
+ $self->{ENCODING_BUFFER} .= $buffer;\r
+ } elsif\r
+ #\r
+ # Got Encoding Data\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_ENCODING_DATA) {\r
+ $self->{ENCODING_BUFFER} .= $buffer;\r
+ \r
+ $self->do_set_encoding($self->{ENCODING_BUFFER});\r
+\r
+ $self->{STATE} = STATE_WAIT_FOR_MSG_HEADER;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 1 ;\r
+ } elsif\r
+ #\r
+ # Got Client Cut Text Length\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_TEXT_CUT_LENGTH) {\r
+ if (length($buffer) != 7) {\r
+ warn "Error: STATE_WAIT_FOR_TEXT_CUT_LENGTH state, buffer != 7 bytes" ;\r
+ return undef;\r
+ };\r
+ \r
+ my (undef,undef,$length) = unpack("CnN", $buffer) ;\r
+ print "Client Cut Text: $length characters \n" ;\r
+ \r
+ $self->{STATE} = STATE_WAIT_FOR_TEXT_CUT_CONTENT;\r
+ $self->{EXPECTED_BUFFER_SIZE} = $length ;\r
+ $self->{TEXT_CUT_BUFFER} .= $buffer;\r
+ } elsif\r
+ #\r
+ # Got Client Cut text content\r
+ #\r
+ ($current_state==STATE_WAIT_FOR_TEXT_CUT_CONTENT) {\r
+ $self->{TEXT_CUT_BUFFER} .= $buffer;\r
+ \r
+ $self->do_client_cut_text($self->{TEXT_CUT_BUFFER});\r
+ $self->{TEXT_CUT_BUFFER} = undef;\r
+\r
+ $self->{STATE} = STATE_WAIT_FOR_MSG_HEADER;\r
+ $self->{EXPECTED_BUFFER_SIZE} = 1 ;\r
+ } ;\r
+}\r
+\r
+1;
\ No newline at end of file
--- /dev/null
+use strict;\r
+use warnings;\r
+use VNC::Server;\r
+\r
+\r
+my $life_cell_pixel_size = 5 ;\r
+my $life_cells_per_col = 20 ;\r
+my $life_cells_per_row = 20;\r
+\r
+my $running = 0;\r
+\r
+#\r
+# Init the life data\r
+#\r
+my @life_data;\r
+\r
+foreach my $i (0..$life_cells_per_row-1) {\r
+ foreach my $j (0..$life_cells_per_col-1) {\r
+ $life_data[$i][$j] = int(rand(2));\r
+ }\r
+}\r
+\r
+sub count_neighbors {\r
+ my ($i,$j) = @_ ;\r
+\r
+ my $count =0 ;\r
+ \r
+ foreach my $q ( ($i-1)..($i+1)) {\r
+ foreach my $w ( ($j-1)..($j+1)) {\r
+ if ( ($q>=0) && ($q<$life_cells_per_row) && \r
+ ($w>=0) && ($w<$life_cells_per_col) &&\r
+ (($q!=$i) || ($w!=$j))\r
+ ) {\r
+ if ($life_data[$q][$w]==1) {\r
+ $count++ ;\r
+ }\r
+ }\r
+ }\r
+ }\r
+ return $count;\r
+}\r
+\r
+\r
+my $s = new VNC::Server( Port=>2, \r
+ Idle=>1, \r
+ Caption=>'Game of VNCLife',\r
+ Width => $life_cell_pixel_size * $life_cells_per_row, \r
+ Height => $life_cell_pixel_size * $life_cells_per_col,\r
+ IdleHandler => \&next_turn,\r
+ KeyEventHandler => \&keyboard, \r
+ PointerEventHandler => \&pointer,\r
+ UpdateDisplayHandler => \&updater\r
+ );\r
+\r
+$s->vnc_server_loop;\r
+\r
+sub keyboard {\r
+ my ($vnc, $down, $key) = @_ ;\r
+\r
+ #act only on key released\r
+ if ($down==0) {\r
+\r
+ # R = randomize\r
+ if ($key==ord('R') || $key==ord('r')) {\r
+ foreach my $i (0..$life_cells_per_row-1) {\r
+ foreach my $j (0..$life_cells_per_col-1) {\r
+ $life_data[$i][$j] = int(rand(2));\r
+ }\r
+ }\r
+ $s->update_all_displays;\r
+ }\r
+\r
+ # C = clear\r
+ if ($key==ord('C') || $key==ord('c')) {\r
+ foreach my $i (0..$life_cells_per_row-1) {\r
+ foreach my $j (0..$life_cells_per_col-1) {\r
+ $life_data[$i][$j] = 0;\r
+ }\r
+ }\r
+ $s->update_all_displays;\r
+ }\r
+\r
+ # Q = Quit\r
+ if ($key==ord('Q') || $key==ord('q')) {\r
+ $vnc->disconnect();\r
+ }\r
+\r
+ # S = Start/Stop\r
+ if ($key==ord('S') || $key==ord('s')) {\r
+ if ($running) {\r
+ print "Stoping!\n";\r
+ $running = undef ;\r
+ } else {\r
+ print "Starting!\n";\r
+ $running = 1;\r
+ }\r
+ }\r
+ }\r
+}\r
+\r
+sub pointer {\r
+ my ($vnc,$mask,$x,$y) = @_ ;\r
+\r
+ if ($mask!=0) {\r
+ my $i = $x / $life_cell_pixel_size ;\r
+ my $j = $y / $life_cell_pixel_size ;\r
+\r
+ $life_data[$i][$j] = ($mask==1) ? 1 : 0 ;\r
+\r
+ $s->update_all_displays;\r
+ }\r
+}\r
+\r
+\r
+sub updater {\r
+ my ($vnc, $inc, $x,$y,$w,$h) = @_ ;\r
+ my $codec = $vnc->{CODEC};\r
+\r
+ my @rects ;\r
+ my $red_pixel = $codec->encode_pixel(255,0,0);\r
+ my $white_pixel = $codec->encode_pixel(255,255,255);\r
+\r
+ foreach my $i (0..$life_cells_per_row-1) {\r
+ foreach my $j (0..$life_cells_per_col-1) {\r
+ if ($life_data[$i][$j]==1) {\r
+ push @rects, $codec->encode_rre_subrect( $red_pixel ,$i*$life_cell_pixel_size, $j*$life_cell_pixel_size,$life_cell_pixel_size,$life_cell_pixel_size);\r
+ }\r
+ }\r
+ }\r
+ my $data = $codec->encode_framebuffer_update( $codec->encode_rre($white_pixel, $x,$y,$w,$h, @rects));\r
+\r
+ return $data ;\r
+}\r
+\r
+sub next_turn {\r
+ #not running, exit immediately\r
+ return unless ($running);\r
+\r
+ #calculate the next life phase\r
+ my @new_life_data;\r
+\r
+ foreach my $i (0..$life_cells_per_row-1) {\r
+ foreach my $j (0..$life_cells_per_col-1) {\r
+ $new_life_data[$i][$j] = 0;\r
+ }\r
+ }\r
+\r
+ foreach my $i (0..$life_cells_per_row-1) {\r
+ foreach my $j (0..$life_cells_per_col-1) {\r
+ my $current = $life_data[$i][$j];\r
+ my $count = count_neighbors($i,$j);\r
+ \r
+ if ($current==1){\r
+ if ($count<2 || $count>3) {\r
+ $new_life_data[$i][$j] = 0 ;\r
+ } else {\r
+ $new_life_data[$i][$j] = 1 ;\r
+ }\r
+ }else{\r
+ if ($count==3) {\r
+ $new_life_data[$i][$j] = 1 ;\r
+ } else {\r
+ $new_life_data[$i][$j] = 0 ;\r
+ }\r
+ }\r
+ }\r
+ }\r
+ @life_data = @new_life_data;\r
+ \r
+ $s->update_all_displays;\r
+}\r
projects / vncperl.git / commitdiff