PureBasic Forums - English

Code: Select all

;
; RFB Protocol V 3.3
;
; translated to PB by infratec
;


; Set this For the endian of your machine. 0 = big, 1 = little
#rfbEndianTest = 1


;
; Macro To compare pixel formats.
;
Macro PF_EQ(x,y)
  ((x\bitsPerPixel = y\bitsPerPixel) And (x\depth = y\depth) And (x\trueColour = y\trueColour) And ((x\bigEndian = y\bigEndian) Or (x\bitsPerPixel = 8)) And ( Not x\trueColour Or ((x\redMax = y\redMax) And (x\greenMax = y\greenMax) And (x\blueMax = y\blueMax) And (x\redShift = y\redShift) And (x\greenShift = y\greenShift) And (x\blueShift = y\blueShift))))
EndMacro


;
; Macros For endian swapping.
;
Macro Swap16(s)
  ((((s) & $ff) << 8) | (((s) >> 8) & $ff))
EndMacro

Macro Swap32(l) 
  (((l) >> 24) | (((l) & $00ff0000) >> 8)  | (((l) & $0000ff00) << 8)  | ((l) << 24))
EndMacro

CompilerIf #rfbEndianTest = 1
  Macro Swap16IfLE(s)
    Swap16(s)
  EndMacro
CompilerElse
  Macro Swap16IfLE(s)
    (s)
  EndMacro
CompilerEndIf

CompilerIf #rfbEndianTest = 1
  Macro Swap32IfLE(l)
    Swap32(l)
  EndMacro
CompilerElse
  Macro Swap32IfLE(l)
    (l)
  EndMacro
CompilerEndIf



;*****************************************************************************
;*
;* Structures used in several messages
;*
;*****************************************************************************

Structure rfbRectangle
  x.u
  y.u
  w.u
  h.u
EndStructure
#sz_rfbRectangle = 8


Structure rfbPixelFormat
  bitsPerPixel.a ;		/* 8,16,32 only */
  depth.a;		/* 8 to 32 */
  bigEndian.a;		/* True if multi-byte pixels are interpreted as big endian
  trueColour.a;		/* If false then we need a "colour map" to
  ; the following fields are only meaningful If trueColour is true */

  redMax.u
  greenMax.u
  blueMax.u
  
  redShift.a
  greenShift.a
  blueShift.a

  pad1.a
  pad2.u
EndStructure
#sz_rfbPixelFormat = 16


#rfbProtocolMajorVersion = "003"
#rfbProtocolMinorVersion = "003"

#sz_rfbProtocolVersionMsg = 12


Enumeration
  #rfbConnFailed
  #rfbNoAuth
  #rfbVncAuth
EndEnumeration

Enumeration
  #rfbVncAuthOK
  #rfbVncAuthFailed
  #rfbVncAuthTooMany
EndEnumeration



Structure rfbClientInitMsg
  Shared.l
EndStructure
#sz_rfbClientInitMsg = 1


Structure rfbServerInitMsg
  framebufferWidth.u
  framebufferHeight.u
  format.rfbPixelFormat
  nameLength.l
EndStructure
#sz_rfbServerInitMsg = (8 + #sz_rfbPixelFormat)


;*****************************************************************************
;*
;* Message types
;*
;*****************************************************************************/

;* server -> client *
Enumeration
  #rfbFramebufferUpdate
  #rfbSetColourMapEntries
  #rfbBell
  #rfbServerCutText
EndEnumeration


;* client -> server *
Enumeration
  #rfbSetPixelFormat
  #rfbFixColourMapEntries
  #rfbSetEncodings
  #rfbFramebufferUpdateRequest
  #rfbKeyEvent
  #rfbPointerEvent
  #rfbClientCutText

  #rfbEnableExtensionRequest = 10
  #rfbExtensionData
EndEnumeration



;*****************************************************************************
;*
;* Encoding types
;*
;*****************************************************************************
 Enumeration
  #rfbEncodingRaw
  #rfbEncodingCopyRect
  #rfbEncodingRRE
  #rfbEncodingCoRRE = 4
  #rfbEncodingHextile
  #rfbEncodingZlib
  #rfbEncodingTight
  #rfbEncodingZlibHex
  #rfbEncodingZRLE = 16
  #rfbEncodingLzo = 21 
EndEnumeration


;*****************************************************************************
;*
;* Server -> client message definitions
;*
;*****************************************************************************

Structure rfbFramebufferUpdateMsg
  type.a;			/* always rfbFramebufferUpdate */
  pad.a
  nRects.u
  ; followed by nRects rectangles
EndStructure
#sz_rfbFramebufferUpdateMsg = 4


Structure rfbFramebufferUpdateRectHeader
  r.rfbRectangle
  encoding.l;	/* one of the encoding types rfbEncoding... */
EndStructure
#sz_rfbFramebufferUpdateRectHeader = #sz_rfbRectangle + 4


Structure  rfbCopyRect
  srcX.u
  srcY.u
EndStructure
#sz_rfbCopyRect = 4


Structure rfbRREHeader
  nSubrects.l
EndStructure
#sz_rfbRREHeader = 4


Structure rfbCoRRERectangle
  x.a
  y.a
  w.a
  h.a
EndStructure
#sz_rfbCoRRERectangle = 4


Macro rfbHextileRaw
  (1 << 0)
EndMacro

Macro rfbHextileBackgroundSpecified
  (1 << 1)
EndMacro

Macro rfbHextileForegroundSpecified
  (1 << 2)
EndMacro

Macro rfbHextileAnySubrects
  (1 << 3)
EndMacro

Macro rfbHextileSubrectsColoured
  (1 << 4)
EndMacro

Macro rfbHextilePackXY(x,y) 
  (((x) << 4) | (y))
EndMacro

Macro rfbHextilePackWH(w,h) 
  ((((w)-1) << 4) | ((h)-1))
EndMacro

Macro rfbHextileExtractX(byte) 
  ((byte) >> 4)
EndMacro

Macro rfbHextileExtractY(byte)
  ((byte) & 0xf)
EndMacro

Macro rfbHextileExtractW(byte)
  (((byte) >> 4) + 1)
EndMacro

Macro rfbHextileExtractH(byte)
  (((byte) & 0xf) + 1)
EndMacro
 


Structure rfbSetColourMapEntriesMsg
  type.a;			/* always rfbSetColourMapEntries */
  pad.a
  firstColour.u
  nColours.u
  ; /* Followed by nColours * 3 * CARD16
  ;     r1, g1, b1, r2, g2, b2, r3, g3, b3, ..., rn, bn, gn */
EndStructure
#sz_rfbSetColourMapEntriesMsg = 6


Structure rfbBellMsg
  type.a
EndStructure
#sz_rfbBellMsg = 1


Structure rfbServerCutTextMsg
  type.a
  pad1.a
  pad2.u
  length.l
  ; followed by char text[length] */
EndStructure
#sz_rfbServerCutTextMsg = 8


Structure rfbEnableExtensionRequestMsg
  type.a;         /* always rfbEnableExtensionRequest */
  new_msg.a
  flags.a
  pad1.a
  length.l
  ; Followed by <length> bytes of Data */
EndStructure 


Structure rfbExtensionDataMsg
  type.a
  pad1.a
  pad2.u
  length.l;      /* Must be correct if used
  ; Followed by <length> bytes of Data
EndStructure


Structure rfbServerToClientMsg
  StructureUnion
    fu.rfbFramebufferUpdateMsg
    scme.rfbSetColourMapEntriesMsg
    b.rfbBellMsg
    sct.rfbServerCutTextMsg
    eer.rfbEnableExtensionRequestMsg
    ed.rfbExtensionDataMsg
  EndStructureUnion
EndStructure


;*****************************************************************************
;*
;* Message definitions (client -> server)
;*
;*****************************************************************************

Structure rfbSetPixelFormatMsg
  type.a;			/* always rfbSetPixelFormat */
  pad1.a
  pad2.u
  format.rfbPixelFormat
EndStructure
#sz_rfbSetPixelFormatMsg = (#sz_rfbPixelFormat + 4)


Structure rfbFixColourMapEntriesMsg
  type.a;			/* always rfbFixColourMapEntries */
  pad.a
  firstColour.u
  nColours.u
  ; Followed by nColours * 3 * CARD16
  ; r1, g1, b1, r2, g2, b2, r3, g3, b3, ..., rn, bn, gn */
EndStructure
#sz_rfbFixColourMapEntriesMsg = 6


Structure rfbSetEncodingsMsg
  type.a;			/* always rfbSetEncodings */
  pad.a
  nEncodings.u
  ; followed by nEncodings * CARD32 encoding types */
EndStructure
#sz_rfbSetEncodingsMsg = 4


Structure rfbFramebufferUpdateRequestMsg
  type.a;			/* always rfbFramebufferUpdateRequest */
  incremental.a
  x.u
  y.u
  w.u
  h.u
EndStructure
#sz_rfbFramebufferUpdateRequestMsg = 10


Structure rfbKeyEventMsg
  type.a;			/* always rfbKeyEvent */
  down.a;			/* true if down (press), false if up */
  pad.u;
  key.l;			/* key is specified as an X keysym */
EndStructure
#sz_rfbKeyEventMsg = 8


#rfbButton1Mask = 1
#rfbButton2Mask = 2
#rfbButton3Mask = 4

Structure rfbPointerEventMsg
  type.a;			/* always rfbPointerEvent */
  buttonMask.a;		/* bits 0-7 are buttons 1-8, 0=up, 1=down */
  x.u
  y.u
EndStructure
#sz_rfbPointerEventMsg = 6


Structure rfbClientCutTextMsg
  type.a;			/* always rfbClientCutText */
  pad1.a
  pad2.u
  length.l
  ; followed by char text[length] */
EndStructure
#sz_rfbClientCutTextMsg = 8


Structure rfbClientToServerMsg
  StructureUnion
    spf.rfbSetPixelFormatMsg
    fcme.rfbFixColourMapEntriesMsg
    se.rfbSetEncodingsMsg
    fur.rfbFramebufferUpdateRequestMsg
    ke.rfbKeyEventMsg
    pe.rfbPointerEventMsg
    cct.rfbClientCutTextMsg
    eer.rfbEnableExtensionRequestMsg
    ed.rfbExtensionDataMsg
  EndStructureUnion
EndStructure

Code: Select all

#rfbMaxClientWait = 20000   ;	time (ms) after which we decide client has
				                    ; gone away - needed To stop us hanging */


IncludeFile "rfb.pbi"

Declare.i ListenAtTcpAddr(port.i)
Declare do_client(sock.i)
Declare.i draw_digit(sock.i, digit.i, segl.i, segw.i, fg.i, bg.i, xoffset.i, yoffset.i)
Declare.i draw_counter(sock.i, value.i, numdigits.i, segl.i, segw.i, fg.i, bg.i)
Declare putSubrect(*buf.a, *lenp.i, colour.i, x.i, y.i, w.i, h.i)

Declare.i ReadExact(*sock, *buf, len.i)
Declare.i WriteExact(*sock, *buf, len.i)


Global BGR233Format.rfbPixelFormat
BGR233Format\bitsPerPixel = 8
BGR233Format\depth = 8
BGR233Format\bigEndian = 1
BGR233Format\trueColour = 1
BGR233Format\redMax = 7
BGR233Format\greenMax = 7
BGR233Format\blueMax = 3
BGR233Format\redShift = 0
BGR233Format\greenShift = 3
BGR233Format\blueShift = 6


Global screenWidth.i, screenHeight.i
Global fg.i = 0
Global bg.i = $ff
Global segmentWidth.i, segmentLength.i
Global numdigits.i = 4
Global segment_aspect.i = 3 ; length = 3 * width
Global digit_spacing.i = 2  ; space is two segment widths
Global border.i
Global clockmode.i = #False


; Set the segments that make up each digit
#bottom = 1
#bottomLeft = 2
#bottomRight = 4
#middle = 8
#topLeft = 16
#topRight = 32
#top = 64
#all = 127

Global Dim digits.a(10)
digits(0) = #all & ~#middle
digits(1) = #bottomRight | #topRight
digits(2) = #all & ~(#topLeft| #bottomRight)
digits(3) = #all & ~(#topLeft| #bottomLeft)
digits(4) = #topLeft | #middle | #topRight | #bottomRight
digits(5) = #all & ~(#topRight | #bottomLeft)
digits(6) = #all & ~#topRight
digits(7) = #top | #topRight | #bottomRight
digits(8) = #all
digits(9) = #all & ~#bottomLeft


#PROGNAME = "rfbcounter"

Procedure.i main()
  
  Protected s.i, sock.i
  Protected port.u
  
  Protected addrlen.i
  Protected appname.s
  
  Protected argc.i, argv.i
  
  OpenConsole()
  
  appname = GetFilePart(ProgramFilename())
  
  argc = CountProgramParameters()
  
  If argc < 2
	  MessageRequester("Info", "usage: " + appname + " [-clock] server-number dispwidth [fg] [bg]")
	  End
  EndIf
  
  
  argv = -1
  If FindString(ProgramParameter(0), "-clock")
    clockmode = #True
    argv + 1
    argc + 1
  EndIf
  
	
  port = Val(ProgramParameter(argv + 1))
  If port < 100 : port + 5900 : EndIf
  
  screenWidth = Val(ProgramParameter(argv + 2))
  border = screenWidth / 20

  ; Each char is 2 segment widths + one length wide.
  ; There are (numdigits-1) spaces between digits.
  segmentWidth = (screenWidth - 2 * border) / ((numdigits * (2 + segment_aspect) + (numdigits - 1) * digit_spacing))
  segmentLength = segmentWidth * segment_aspect
  screenHeight = segmentWidth * (3 + 2 * segment_aspect)  + 2 * border
	
  If argc >= 4 : fg = Val(ProgramParameter(argv + 3)) : EndIf
  If argc >= 5 : bg = Val(ProgramParameter(argv + 4)) : EndIf
  
  If InitNetwork() = 0
    End
  EndIf

	
  s = ListenAtTcpAddr(port)
  If s = 0
	  End 1
  EndIf
	
  PrintN(appname + ": listening on port " + Str(port))
  
  While #True
	  Protected one.i = 1
	  Protected pv.s
	  Protected auth.l
	  Protected cim.rfbClientInitMsg
	  Protected sim.rfbServerInitMsg
	  Protected Dim textbuf.a(1024)
		
	  ; Wait For an incoming connection
	  Repeat
	    Delay(3)
	  Until NetworkServerEvent() = #PB_NetworkEvent_Connect
	  
	  sock = EventClient()
	  
	  PrintN(appname + ": accepted connection")
		
	  ; Send our protocol version & Read the client's - we ignore it
    pv = "RFB " + #rfbProtocolMajorVersion + "." + #rfbProtocolMinorVersion + #LF$
		
    If WriteExact(@sock, @pv, #sz_rfbProtocolVersionMsg) < 0
      PrintN("Error: Writing protocol version")
	    CloseNetworkServer(s)
	    End 1
	  EndIf
		
	  If ReadExact(@sock, @pv, #sz_rfbProtocolVersionMsg) < 0	    
	    PrintN("Error: Reading client protocol version");
	    CloseNetworkServer(s)
	    End 1
	  EndIf
		
	  ; No authentication
	  auth = Swap32IfLE(#rfbNoAuth)
	  If WriteExact(@sock, @auth, SizeOf(auth)) < 0
	    PrintN("Error: Writing NoAuth")
	    CloseNetworkServer(s)
	    End 1
	  EndIf
		
	  ; Read & ignore client Init msg
	  If ReadExact(@sock, @cim, #sz_rfbClientInitMsg) < 0
	    PrintN("Error: Reading client init msg")
	    CloseNetworkServer(s)
	    End 1
	  EndIf
		
	  ; Server Init msg
	  sim\framebufferWidth = Swap16IfLE(screenWidth)
	  sim\framebufferHeight = Swap16IfLE(screenHeight)
	  ;sim\format = BGR233Format
	  CopyStructure(BGR233Format, sim\format, rfbPixelFormat)
	  sim\format\redMax = Swap16IfLE(sim\format\redMax)
	  sim\format\greenMax = Swap16IfLE(sim\format\greenMax)
	  sim\format\blueMax = Swap16IfLE(sim\format\blueMax)
	  sim\nameLength = Len(#PROGNAME)
	  sim\nameLength = Swap32IfLE(sim\nameLength)
	  ;strcpy(textbuf, #PROGNAME)
	  PokeS(@textbuf(0), #PROGNAME)
	  If WriteExact(@sock, @sim, #sz_rfbServerInitMsg) < 0
	    PrintN("Error: Sending server init msg")
	    CloseNetworkServer(s)
	    End 1
	  EndIf
		
	  If WriteExact(@sock, @textbuf, Len(#PROGNAME)) < 0
	    PrintN("Error: Sending server name")
	    CloseNetworkServer(s)
	    End 1
	  EndIf
		
	  ; Then process this client
    do_client(s)
    
  Wend
  
  CloseNetworkServer(s)
  
  ProcedureReturn 0
    
EndProcedure




main()

End




Procedure do_client(s.i)
  
  While #True
    
	  Protected n.i
	  Protected msgType.a
	  
	  ; Peek the first byte of the message To find its type
	  
	  ; thats not possible with PB, so we have to read the first byte
	  ; and later we have to read only the rest (one byte less)
	  n = ReadExact(@sock, @msgType, 1)
	  If n <= 0
	    PrintN("Error: recv")
	    ProcedureReturn
	  EndIf
	  
;	  Debug msgType
	  
	  Select msgType
			
	    Case #rfbSetPixelFormat
	      
        ; We Read the client's pixel format, but in this simple 
        ; program we are Not going To do any translation, so If
        ; the client doesn't either accept what we gave it, or 
        ; request BGR233, we close connection.
        
		    Protected spf.rfbSetPixelFormatMsg
		    
		    n = ReadExact(@sock, @spf + 1, SizeOf(rfbSetPixelFormatMsg) - 1)
		    If n <= 0
		      If n = 0
			      PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf
		      ProcedureReturn
		    EndIf
				
		    spf\format\bitsPerPixel = spf\format\bitsPerPixel
		    spf\format\depth = spf\format\depth
		    If spf\format\trueColour
		      spf\format\trueColour = 1
		    Else 
		      spf\format\trueColour = 0
		    EndIf
		    If spf\format\bigEndian
		      spf\format\bigEndian = 1
		    Else
		      spf\format\bigEndian = 0
		    EndIf
		    spf\format\redMax = Swap16IfLE(spf\format\redMax)
		    spf\format\greenMax = Swap16IfLE(spf\format\greenMax)
		    spf\format\blueMax = Swap16IfLE(spf\format\blueMax)
		    spf\format\redShift = spf\format\redShift
		    spf\format\greenShift = spf\format\greenShift
		    spf\format\blueShift = spf\format\blueShift
				
		    If Not PF_EQ(spf\format, BGR233Format)
		      PrintN("Error: Client has wrong pixel format")
		      ProcedureReturn
		    EndIf
				
        
	    Case #rfbFixColourMapEntries
	      PrintN("Error: rfbProcessClientMessage: cannot handle colourmaps")
		    End 1
	      
        
	    Case #rfbSetEncodings
                
        ; This reads but ignores the encoding List.
		    ; We simply check here that the client 
		    ; can do RRE encoding.
        
		    Protected se.rfbSetEncodingsMsg
		    Protected enc.l
		    Protected i.i
		    Protected candoRRE.i = 0
		    
		    n = ReadExact(@sock, @se + 1, SizeOf(rfbSetEncodingsMsg) - 1)
		    If n <= 0
		      If n = 0
			      PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf
		      ProcedureReturn
		    EndIf
				
		    se\nEncodings = Swap16IfLE(se\nEncodings)
		    For i = 0 To se\nEncodings - 1
		      n = ReadExact(@sock, @enc, 4)
		      If n <= 0
			      If n = 0
			        PrintN("rfbProcessClientMessage: client gone")
			      Else
			        PrintN("Error: rfbProcessClientMessage: read")
			      EndIf
			      ProcedureReturn
			    EndIf
			    If Swap32IfLE(enc) = #rfbEncodingRRE : candoRRE = 1 : EndIf
		    Next i
		    
		    If Not candoRRE
		      PrintN("Error: Client can't do RRE")
		      ProcedureReturn
		    EndIf
			  
        
		  Case #rfbFramebufferUpdateRequest
		    
	      ; This is the important bit.
        ; The client has requested an update, so we need To send it
        ; the display.

		    Protected sur.rfbFramebufferUpdateRequestMsg
		    Static counterval.i = 0
		    Static oldcounterval.i = 0
		    
		    n = ReadExact(@sock, @sur + 1, SizeOf(rfbFramebufferUpdateRequestMsg) - 1)
		    If n <= 0
		      If n = 0
		        PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf
		      ProcedureReturn
		    EndIf
				
		    If sur\incremental
;          Debug "Inc"
		      If clockmode
			      Protected DateTime.i
			      While (1)
			        DateTime = Date()			        
			        counterval = 100 * Hour(DateTime) + Minute(DateTime)
			        If counterval <> oldcounterval
			          Break;
			        EndIf
			        Delay(60000 - Second(DateTime) * 1000)
			      Wend
			      oldcounterval = counterval;
		      Else
			      counterval = (counterval + 1) % 10000
		      EndIf
		      If Not draw_counter(sock, counterval, numdigits, segmentWidth, segmentLength, fg, bg)
		        ProcedureReturn
		      EndIf

		    Else ; blank the screen initially
;          Debug "Full"
		      Protected su.rfbFramebufferUpdateMsg
		      Protected rect.rfbFramebufferUpdateRectHeader
		      Protected hdr.rfbRREHeader
		      Protected colour.a
		      su\type   = #rfbFramebufferUpdate
		      su\nRects = Swap16IfLE(1)
		      WriteExact(@sock, @su, #sz_rfbFramebufferUpdateMsg)
		      rect\r\x = Swap16IfLE(0)
		      rect\r\y = Swap16IfLE(0)
		      rect\r\w = Swap16IfLE(screenWidth)
		      rect\r\h = Swap16IfLE(screenHeight)
		      rect\encoding = Swap32IfLE(#rfbEncodingRRE)
		      WriteExact(@sock, @rect, #sz_rfbFramebufferUpdateRectHeader)
		      hdr\nSubrects = Swap32IfLE(0)
		      WriteExact(@sock, @hdr, #sz_rfbRREHeader)
		      colour = bg
		      WriteExact(@sock, @colour, 1)
		      oldcounterval = 0

		    EndIf
		    
		    
	    Case #rfbKeyEvent
	      
        ; Read And ignore key events, except For Q, which quits

        Protected key.rfbKeyEventMsg
        
        n = ReadExact(@sock, @key + 1, SizeOf(rfbKeyEventMsg) - 1)
		    If n <= 0
		      If n = 0
			      PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf
		      ProcedureReturn
		    EndIf
		    
		    key\key = Swap32IfLE(key\key)
		    key\key = key\key & $ff
		    If key\key = 'q' Or key\key = 'Q'
		      ProcedureReturn
		    EndIf
		    
			  
	    Case #rfbPointerEvent
	      
        ; Read And ignore pointer events
        
        Protected ptr.rfbPointerEventMsg
        
        n = ReadExact(@sock, @ptr + 1, SizeOf(rfbPointerEventMsg) - 1)
		    If n <= 0
		      If n = 0
			      PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf
		      ProcedureReturn
		    EndIf
		    
		    
	    Case #rfbClientCutText
	      
        ; Read And ignore clipboard messages
        
		    Protected ct.rfbClientCutTextMsg
		    Protected *buf
		    
		    n = ReadExact(@sock, @ct + 1, SizeOf(rfbClientCutTextMsg) - 1)
		    If n <= 0
		      If n = 0
			      PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf
		      ProcedureReturn
		    EndIf
				
		    ct\length = Swap32IfLE(ct\length)
		    *buf = AllocateMemory(ct\length)
		    If *buf = #Null
		      PrintN("Error: Cannot allocate " + Str(ct\length) + " bytes")
		      ProcedureReturn
		    EndIf
		    
		    n = ReadExact(@sock, *buf, ct\length)
		    If n <= 0
		      If n = 0
			      PrintN("rfbProcessClientMessage: client gone")
		      Else
		        PrintN("Error: rfbProcessClientMessage: read")
		      EndIf 
		      ProcedureReturn
		    EndIf
				
		    FreeMemory(*buf)
			  
			  
	    Default:
	      PrintN("rfbProcessClientMessage: unknown message type " + Str(msgType))
	      PrintN("rfbProcessClientMessage: ... closing connection")
	      ProcedureReturn
	    
	  EndSelect
	  
	Wend
	
EndProcedure




;
; ListenAtTcpAddr starts listening at the given TCP port.
;

Macro DO(x)
  If ((x) < 0) { close(sock); return -1; }
EndMacro

Procedure.i ListenAtTcpAddr(port.i)
  ProcedureReturn CreateNetworkServer(#PB_Any, port, #PB_Network_TCP)
EndProcedure




Procedure.i draw_counter(sock.i, value.i, numdigits.i, segl.i, segw.i, fg.i, bg.i)
  
  Protected su.rfbFramebufferUpdateMsg
  Protected xoffset.i = border
  Protected yoffset.i = border
  Protected i.i
  
  ; This one update will consist of a separate rectangle For each digit
  ; Each rectangle uses RRE encoding, And the subrects draw the segments
  
  su\type = #rfbFramebufferUpdate
  su\nRects = Swap16IfLE(numdigits);
  WriteExact(@sock, @su, #sz_rfbFramebufferUpdateMsg)
  
  ; We draw the digits right To left
  ; The rightmost gopes here:
  xoffset + (numdigits - 1) * (segl + 2 * segw + digit_spacing)
  
  For i = 0 To numdigits - 1
	  If Not draw_digit(sock, value % 10, segl, segw, fg, bg, xoffset, yoffset)
	    ProcedureReturn 0
	  EndIf 
	  xoffset - segl * ((2 + segment_aspect) + digit_spacing)
    value = value / 10
  Next i
  
  ProcedureReturn 1
  
EndProcedure

Procedure.i draw_digit(sock.i, digit.i, segl.i, segw.i, fg.i, bg.i, xoffset.i, yoffset.i)
  
  Protected rect.rfbFramebufferUpdateRectHeader
  Protected hdr.rfbRREHeader
  Protected Dim buf.a(256)
  Protected len.i = 0
  Protected bits.i = digits(digit)
  Protected *rreheaderbuf
	
  ; A digit is made up of segments As follows:
  ;     -      
  ;    | |     where the length of each seg is segl
  ;     -      And the width is segw.
  ;    | |
  ;     -
  
  ; First calculate the overall dimensions of the segment
  rect\r\x = Swap16IfLE(xoffset)
  rect\r\y = Swap16IfLE(yoffset)
  rect\r\w = Swap16IfLE(2 * segl + segw)
  rect\r\h = Swap16IfLE(3 * segl + 2 * segw)
  rect\encoding = Swap32IfLE(#rfbEncodingRRE)
	
  ; Put this in the buffer ready To send
  CopyMemory(@rect, @buf(len), SizeOf(rfbFramebufferUpdateRectHeader))
  len + SizeOf(rfbFramebufferUpdateRectHeader)
	
  *rreheaderbuf = @buf(len)
  len + SizeOf(rfbRREHeader)
  
  ; background pixel value
  buf(len) = bg & $FF
  len + 1
	
  ; Now insert in the buffer the commands needed To
  ; draw each lit segment.
  hdr\nSubrects = 0
	
  If bits & #bottom
	  putSubrect(@buf(0), @len, fg, segl, 2 * segl + 2 * segw, segw, segl)
	  hdr\nSubrects + 1
	EndIf
	
  If bits & #bottomLeft
	  putSubrect(@buf(0), @len, fg, 0, 2 * segl + segw, segl, segw)
	  hdr\nSubrects + 1
	EndIf
	
  If bits & #bottomRight
	  putSubrect(@buf(0), @len, fg, segl + segw, 2 * segl + segw, segl, segw)
	  hdr\nSubrects + 1
	EndIf
	
  If bits & #middle
	  putSubrect(@buf(0), @len, fg, segl, segl + segw, segw, segl)
	  hdr\nSubrects + 1
	EndIf
	
  If bits & #topLeft
  	putSubrect(@buf(0), @len, fg, 0, segl, segl, segw)
	  hdr\nSubrects + 1
	EndIf
	
  If bits & #topRight
	  putSubrect(@buf(0), @len, fg, segl+segw, segl, segl, segw)
	  hdr\nSubrects + 1
	EndIf
	
  If bits & #top
	  putSubrect(@buf(0), @len, fg, segl, 0, segw, segl);
	  hdr\nSubrects + 1
  EndIf
	
  hdr\nSubrects = Swap32IfLE(hdr\nSubrects)
  CopyMemory(@hdr, *rreheaderbuf, SizeOf(rfbRREHeader))
	
  ; And then send the buffer To the viewer
  
  If WriteExact(@sock, @buf(0), len) < 0
	  PrintN("Error: draw_digit: write")
	  ProcedureReturn 0;
  EndIf
	
  ProcedureReturn 1
  
EndProcedure

Procedure putSubrect(*buf, *lenp, colour.i, x.i, y.i, w.i, h.i)
  
  Protected r.rfbRectangle
	
  PokeA(*buf + (PeekI(*lenp)), colour & $FF)
  PokeI(*lenp, PeekI(*lenp) + 1)
  
  r\x = Swap16IfLE(x)
  r\y = Swap16IfLE(y)
  r\w = Swap16IfLE(w)
  r\h = Swap16IfLE(h)
  CopyMemory(@r, *buf + PeekI(*lenp), SizeOf(rfbRectangle))
  PokeI(*lenp, PeekI(*lenp) + SizeOf(rfbRectangle))
EndProcedure



;
; ReadExact reads an exact number of bytes on a TCP socket.  Returns 1 If
; those bytes have been Read, 0 If the other End has closed, Or -1 If an error
; occurred (errno is set To ETIMEDOUT If it timed out).
;

Procedure.i ReadExact(*sock, *buf, len.i)
  
  Protected NServerEvent.i, sock.i, n.i
  
  While len > 0
    Repeat
	    Delay(3)
	    NServerEvent = NetworkServerEvent()
	  Until NServerEvent = #PB_NetworkEvent_Data Or NServerEvent = #PB_NetworkEvent_Disconnect
	  If NServerEvent = #PB_NetworkEvent_Data
	    sock = EventClient()
	    PokeI(*sock, sock)
      n = ReceiveNetworkData(sock, *buf, len)
;      Debug n
	    If n > 0
	      *buf + n
	      len - n
      Else
        ProcedureReturn n
      EndIf
    Else
      ProcedureReturn -2
    EndIf
	Wend
	
  ProcedureReturn 1
  
EndProcedure

;
; WriteExact writes an exact number of bytes on a TCP socket.  Returns 1 If
; those bytes have been written, Or -1 If an error occurred (errno is set To
; ETIMEDOUT If it timed out).
;

Procedure.i WriteExact(*sock, *buf, len.i)
  
  Protected n.i, sock,i
  
	sock = PeekI(*sock)
  While len > 0
	  n = SendNetworkData(sock, *buf, len)
		
	  If n > 0
	    *buf + n
	    len - n
	  ElseIf n = 0
      PrintN("Error: WriteExact: write returned 0?")
	    End 1
    Else
      ProcedureReturn n
    EndIf
	
  Wend
  
  ProcedureReturn 1
    
EndProcedure

Code: Select all

Run cmd
c:\Temp\rfbcounter 5900 300

Code: Select all

c:\Temp\rfbcounter 5900 300