Patch title: Release 90 bulk changes
Abstract:
File: /protocol/vnc/client.pli
Key:
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/linux/input/keyboard.pli"
module "/pliant/linux/input/mouse.pli"
module "/pliant/language/os.pli"

module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/frame_buffer.pli"
module "/pliant/graphic/color/gamut.pli"

constant os_VT_GETSTATE 5603h
constant os_VT_ACTIVATE 5606h

constant os_FBIOBLANK 4611h

type os_vt_stat
  field uInt16 v_active
  field uInt16 v_signal
  field uInt16 v_state

function vncEncryptBytes bytes passwd
  arg Address bytes ; arg CStr passwd
  external "/pliant/pliant/protocol/vnc/vncchallenge.so" "vncEncryptBytes"


type VncPixelFormat
  field uInt8 bits_per_pixel
  field uInt8 depth
  field uInt8 big_endian_flag
  field uInt8 true_color_flag
  field uInt16_hi red_max green_max blue_max
  field uInt8 red_shift green_shift blue_shift
  field Byte padding1 padding2 padding3

function kbd_map ch -> c

function kbd_map0 ch -> c
  arg Str ch ; arg Int c
  if (ch parse c)
    void
  eif ch="enter"
    c := 0FF0Dh
  eif ch="backspace"
    c := 0FF08h
  eif ch="tab"
    c := 0FF09h
  eif ch="escape"
    c := 0FF1Bh
  eif ch="insert"
    c := 0FF63h
  eif ch="delete"
    c := 0FFFFh
  eif ch="home"
    c := 0FF50h
  eif ch="end"
    c := 0FF57h
  eif ch="pageup"
    c := 0FF55h
  eif ch="pagedown"
    c := 0FF56h
  eif ch="left"
    c := 0FF51h
  eif ch="up"
    c := 0FF52h
  eif ch="right"
    c := 0FF53h
  eif ch="down"
    c := 0FF54h
  eif (ch parse "F" (var Int i)) and i>=1 and i<=12
    c := 0FFBDh+i
  eif ch="press left shift"
  eif ch="left shift"
    c := 0FFE1h
  eif ch="release left shift"
    c := -0FFE1h
  eif ch="press right shift"
  eif ch="right shift"
    c := 0FFE2h
  eif ch="release right shift"
    c := -0FFE2h
  eif ch="press left ctrl"
  eif ch="left ctrl"
    c := 0FFE3h
  eif ch="release left ctrl"
    c := -0FFE3h
  eif ch="press right ctrl"
  eif ch="right ctrl"
    c := 0FFE4h
  eif ch="release right ctrl"
    c := -0FFE4h
  eif ch="press left alt"
  eif ch="left alt"
    c := 0FFE9h
  eif ch="release left alt"
    c := -0FFE9h
  eif false # ch="press right alt"
  eif false # ch="right alt"
    c := 0FFEAh
  eif false # ch="release right alt"
    c := -0FFEAh
  eif (ch parse word:"shift" any:(var Str remain)) or (ch parse word:"ctrl" any:(var Str remain)) or (ch parse word:"alt" any:(var Str remain))
    c := kbd_map remain
    c := kbd_map0 remain
  else
    c := undefined

function kbd_map ch -> c
  arg Str ch ; arg Int c
  if (ch parse word:"press" any:(var Str k))
    c := undefined
  eif (ch parse word:"release" any:(var Str k))
    c := kbd_map0 k
    if c<>undefined
      c := -c
  else
    c := kbd_map0 ch


function vnc_client server password -> status
  arg Str server password ; arg ExtendedStatus status
  if not (server eparse any:(var Str host) ":" (var Int display))
    host := server ; display := 0
  var Link:Stream s :> new Stream
  s open "tcp://"+host+"/client/"+(string 5900+display) in+out+safe+noautopost
  var Str handshake := s readline
  if (handshake 0 3)<>"RFB"
    return failure:"Failed to connect to the VNC server"
  s writeline "RFB 003.003" ; s flush anytime
  s raw_read addressof:(var uInt32_hi auth) uInt32:size
  if auth=2
    s raw_read addressof:(var (Array Byte 16) challenge) 16
    vncEncryptBytes addressof:challenge password
    s raw_write addressof:(var (Array Byte 16) challenge) 16 ; s flush anytime
    s raw_read addressof:(var uInt32_hi ack) uInt32:size
    if ack<>0
      return failure:"Password is wrong"
  var uInt8 share := 1 ; s raw_write addressof:share uInt8:size ; s flush anytime
  s raw_read addressof:(var uInt16_hi size_x) uInt16:size
  s raw_read addressof:(var uInt16_hi size_y) uInt16:size
  s raw_read addressof:(var VncPixelFormat pixel_format) VncPixelFormat:size
  s raw_read addressof:(var uInt32_hi length) uInt32:size
  var Str name := repeat length " "
  s raw_read name:characters name:len
  console "VNC screen " name " is " (cast size_x Int) " x " (cast size_y Int) " x " (cast pixel_format:bits_per_pixel Int) eol
  # console "depth = " (cast pixel_format:depth Int) eol
  # console "red max = " (cast pixel_format:red_max Int) eol
  # console "green max = " (cast pixel_format:green_max Int) eol
  # console "red shift = " (cast pixel_format:red_shift Int) eol
  # console "green shift = " (cast pixel_format:green_shift Int) eol

  var uInt8 message := 0 ; s raw_write addressof:message 1
  for (var Int i) 1 3
    var uInt8 padding := 0 ; s raw_write addressof:padding 1
  pixel_format true_color_flag := 1
  pixel_format bits_per_pixel := 32
  pixel_format red_max := 255
  pixel_format green_max := 255
  pixel_format blue_max := 255
  pixel_format red_shift := 16
  pixel_format green_shift := 8
  pixel_format blue_shift := 0
  s raw_write addressof:pixel_format VncPixelFormat:size

  var uInt8 message := 2 ; s raw_write addressof:message 1
  var uInt8 padding := 0 ; s raw_write addressof:padding 1
  var uInt16_hi number_of_encodings := 1 ; s raw_write addressof:number_of_encodings uInt16_hi:size
  var uInt32_hi encoding := 0 ; s raw_write addressof:encoding uInt32_hi:size
  s flush anytime

  var Link:Sem sem :> new Sem
  var Link:CBool active :> new CBool false

  os_ioctl 0 os_VT_ACTIVATE (cast 2 Address)
  (var Stream tty2) open "device:/tty2" out+safe
  tty2 writechars character:27+"[lb]?25l"
  tty2 close

  thread # auto refresh
    while s=success
      sleep 0.25
      var CBool was_active := active      
      os_ioctl 0 os_VT_GETSTATE addressof:(var os_vt_stat stat)
      active := stat:v_active=2
      if active
        sem request
        var uInt8 message := 3 ; s raw_write addressof:message 1
        var uInt8 incremental := shunt was_active 1 0 ; s raw_write addressof:incremental 1
        var uInt16_hi x_position := 0 ; s raw_write addressof:x_position uInt16_hi:size
        var uInt16_hi y_position := 0 ; s raw_write addressof:y_position uInt16_hi:size
        var uInt16_hi width := size_x ; s raw_write addressof:size_x uInt16_hi:size
        var uInt16_hi height := size_y ; s raw_write addressof:size_y uInt16_hi:size
        s flush anytime
        sem release

  thread # keyboard
    var CBool verbose := false
    var CBool pause := false
    while s=success
      var Str ch := keyboard_read
      if (ch parse word:"alt" word:"ctrl" any:(var Str remain))
        ch := "ctrl alt "+remain
      if ch="ctrl alt escape"
        s configure "shutdown"
      eif (ch eparse "ctrl alt F" (var Int i)) and i>=1 and i<=2
        os_ioctl 0 os_VT_ACTIVATE (cast i Address)
        active := false
      eif ch="ctrl alt F11"
        verbose := true
      eif ch="ctrl alt F12"
        verbose := false
      eif ch="pause"
        pause := not pause
        var Int handle := os_open "/dev/fb0" os_O_RDWR 0
        if handle>=0
          os_ioctl handle os_FBIOBLANK (cast (shunt pause 4 0) Address)
          os_close handle
      if verbose
        console ch eol
      var Int c := kbd_map ch
      if c<>undefined
        if verbose
          console " -> " c eol
        sem request
        var uInt8 message := 4 ; s raw_write addressof:message 1
        var uInt8 down_flags := shunt c>=0 1 0 ; s raw_write addressof:down_flags 1
        for (var Int i) 1 2
          var uInt8 padding := 0 ; s raw_write addressof:padding 1
        var uInt32_hi key := abs c  ; s raw_write addressof:key uInt32_hi:size
        if active
          var uInt8 message := 3 ; s raw_write addressof:message 1
          var uInt8 incremental := 1 ; s raw_write addressof:incremental 1
          var uInt16_hi x_position := 0 ; s raw_write addressof:x_position uInt16_hi:size
          var uInt16_hi y_position := 0 ; s raw_write addressof:y_position uInt16_hi:size
          var uInt16_hi width := size_x ; s raw_write addressof:size_x uInt16_hi:size
          var uInt16_hi height := size_y ; s raw_write addressof:size_y uInt16_hi:size
        s flush anytime
        sem release

  thread # mouse
    while s=success
      mouse_read (var Int x) (var Int y) (var Int buttons)
      var Str ch := mouse_read (var Int x) (var Int y) (var Int buttons)
      sem request
      if ch<>"" and { var Int c := kbd_map ch ; c<>undefined }
        var uInt8 message := 4 ; s raw_write addressof:message 1
        var uInt8 down_flags := shunt c>=0 1 0 ; s raw_write addressof:down_flags 1
        for (var Int i) 1 2
          var uInt8 padding := 0 ; s raw_write addressof:padding 1
        var uInt32_hi key := abs c  ; s raw_write addressof:key uInt32_hi:size
      var uInt8 message := 5 ; s raw_write addressof:message 1
      var Int buttons8 := (buttons .and. 1)+(buttons .and. 2)*2+(buttons .and. 4)\2 ; s raw_write addressof:buttons8 1
      var uInt16_hi mouse_x16 := x ; s raw_write addressof:mouse_x16 uInt16_hi:size
      var uInt16_hi mouse_y16 := y ; s raw_write addressof:mouse_y16 uInt16_hi:size
      if active
        var uInt8 message := 3 ; s raw_write addressof:message 1
        var uInt8 incremental := 1 ; s raw_write addressof:incremental 1
        var uInt16_hi x_position := 0 ; s raw_write addressof:x_position uInt16_hi:size
        var uInt16_hi y_position := 0 ; s raw_write addressof:y_position uInt16_hi:size
        var uInt16_hi width := size_x ; s raw_write addressof:size_x uInt16_hi:size
        var uInt16_hi height := size_y ; s raw_write addressof:size_y uInt16_hi:size
      s flush anytime
      sem release

  var Link:ImagePrototype fb :> new ImageFrameBuffer
  fb setup (image_prototype 0 0 1 1 size_x size_y color_gamut:"rgb") "noset"
  while not s:atend
    s raw_read addressof:(var uInt8 message) 1
    if message=0
      s raw_read addressof:(var uInt8 padding) 1
      s raw_read addressof:(var uInt16_hi number_of_rectangles) uInt16_hi:size
      for (var Int i) 0 number_of_rectangles-1
        s raw_read addressof:(var uInt16_hi x_position) uInt16_hi:size
        s raw_read addressof:(var uInt16_hi y_position) uInt16_hi:size
        s raw_read addressof:(var uInt16_hi width) uInt16_hi:size
        s raw_read addressof:(var uInt16_hi height) uInt16_hi:size
        s raw_read addressof:(var uInt32_hi encoding) uInt32_hi:size
        if encoding=0
          for (var Int y) y_position y_position+height-1
            if active
              var Address pixels := fb write_map x_position y width width (var Int count)
              s raw_read pixels width*uInt32:size
              fb write_unmap x_position y count pixels
            else
              for (var Int x) x_position x_position+width-1
                s raw_read addressof:(var uInt32 pixel) uInt32:size
    eif message=2
      void # bell
    eif message=3
      for (var Int i) 1 3
        s raw_read addressof:(var Byte drop) 1
      s raw_read addressof:(var uInt32_hi length) uInt32_hi:size
      for (var Int i) 1 length
        s raw_read addressof:(var Byte drop) 1
    else
      console "VNC unknown message " (cast message Int) eol


export vnc_client