Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/console/x11.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/unsafe.pli"
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/language/context.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/util/encoding/utf8.pli"
module "/pliant/language/type/text/str8.pli"
module "prototype.pli"
module "x11_api.pli"

module "prototype.pli"
module "x11_api.pli"


function rgb_color r g b -> rgb
  arg Int r g b rgb
  check r>=0 and r<256 and g>=0 and g<256 and b>=0 and b<256
  rgb := r+g*2^8+b*2^16

function rgb_color r g b -> rgb
  arg Int r g b rgb
  check r>=0 and r<256 and g>=0 and g<256 and b>=0 and b<256
  rgb := r+g*2^8+b*2^16

constant ground_color (rgb_color 255 255 255)
constant ground_color (rgb_color 248 248 248)
constant trace false


gvar Pointer:XDisplay display :> XOpenDisplay ":0.0"
if not exists:display
  error "Failed to open X11 display"
gvar Pointer:XScreen screen :> (display:screens translate XS
gvar Pointer:XVisual visual :> screen root_visual
if screen:root_depth<>24
  error "Pliant requires X11 to work in truecolor mode (eith
constant trace false


gvar Pointer:XDisplay display :> XOpenDisplay ":0.0"
if not exists:display
  error "Failed to open X11 display"
gvar Pointer:XScreen screen :> (display:screens translate XS
gvar Pointer:XVisual visual :> screen root_visual
if screen:root_depth<>24
  error "Pliant requires X11 to work in truecolor mode (eith
gvar Int atom_utf8



if (XAllocNamedColor display screen:cmap x11_color:ground_co
  error "Failed to allocate X11 ground color"



if (XAllocNamedColor display screen:cmap x11_color:ground_co
  error "Failed to allocate X11 ground color"
atom_utf8 := XInternAtom display "UTF8_STRING" false


type ConsoleX11
  field XWindow window


type ConsoleX11
  field XWindow window
  field XGC gc
  field Int size_x size_y
  field Int size_x size_y
  field Sem sem
  field XEvent ev
  field Int lock_x lock_y <- undefined
  field CBool locked <- false
  field Link:Function clipboard_fun ; field Address clipboard_param




method c open p options
  oarg_rw ConsoleX11 c ; arg ImagePrototype p ; arg Str opti
method c open p options -> status
  oarg_rw ConsoleX11 c ; arg ImagePrototype p ; arg Str options ; arg ExtendedStatus status
  var XSetWindowAttributes a
  a background_pixel := x11_ground pixel
  var XSetWindowAttributes a
  a background_pixel := x11_ground pixel
  a override_redirect := false # true
  a override_redirect := false
  a event_mask := PointerMotionMask+ButtonPressMask+ButtonRe
  var uInt mask := CWBackPixel+CWBorderPixel+CWOverrideRedir
  c size_x := p size_x ; c size_y := p size_y
  a event_mask := PointerMotionMask+ButtonPressMask+ButtonRe
  var uInt mask := CWBackPixel+CWBorderPixel+CWOverrideRedir
  c size_x := p size_x ; c size_y := p size_y
  if not (options option "size_x") and display:nscreens>display:default_screen
    var Pointer:XScreen screen :> display:screens map XScreen display:default_screen
    if (options option "fullscreen")
      c size_x := screen width
      c size_y := screen height
      a override_redirect := true
      a cursor := XCreateFontCursor display (shunt (options option "cross") 130 68)
      mask += CWCursor
    else
      c size_y := screen:height-100
      c size_x := min screen:width-100 c:size_y*4\5
  c window := XCreateWindow display screen:root 0 0 c:size_x
  c window := XCreateWindow display screen:root 0 0 c:size_x
  XStoreName display c:window "Pliant browser"
  XStoreName display c:window (options option "label" Str)
  XMapWindow display c:window
  XMapWindow display c:window
  c gc := XCreateGC display c:window 0 (var XGCValues gcvalues)
  if (options option "fullscreen")
    XSetInputFocus display c:window 0 0
  status := success






method c sem_request
  arg_rw ConsoleX11 c
  if c:sem:nowait_request
    return
  while true
    var XClientMessageEvent ev
    memory_clear addressof:ev XClientMessageEvent:size
    ev type := ClientMessage
    ev window := c window
    ev format := 8
    XSendEvent display c:window false 0 (addressof:ev map XEvent)
    XFlush display
    sleep 0
    if c:sem:nowait_request
      return
    var DateTime start := datetime
    while datetime:seconds-start:seconds<0.5
      if c:sem:nowait_request
        return
      sleep 0.01


method c paint img tx ty
  oarg_rw ConsoleX11 c ; oarg_rw ImagePrototype img ; arg In
method c paint img tx ty
  oarg_rw ConsoleX11 c ; oarg_rw ImagePrototype img ; arg In
  if img:size_x>2048 or img:size_y>2048
    error "X11 paint overflow"
  var Address linebuf := memory_allocate img:line_size null
  var Address linebuf := memory_allocate img:line_size null
  var XGC gc := XCreateGC display c:window 0 (var XGCValues 
  var XImage ximg
  ximg width := img size_x
  ximg height := 1
  ximg xoffset := 0
  ximg format := ZPixmap
  ximg byte_order := display byte_order
  check display:bitmap_unit=img:pixel_size*8
  ximg bitmap_unit := display bitmap_unit
  ximg bitmap_bit_order := display bitmap_bit_order
  ximg bitmap_pad := display bitmap_pad
  ximg depth := screen root_depth
  ximg bytes_per_line := img line_size
  ximg bits_per_pixel := img:pixel_size*8
  ximg red_mask := visual red_mask
  ximg green_mask := visual green_mask
  ximg blue_mask := visual blue_mask
  var XImage ximg
  ximg width := img size_x
  ximg height := 1
  ximg xoffset := 0
  ximg format := ZPixmap
  ximg byte_order := display byte_order
  check display:bitmap_unit=img:pixel_size*8
  ximg bitmap_unit := display bitmap_unit
  ximg bitmap_bit_order := display bitmap_bit_order
  ximg bitmap_pad := display bitmap_pad
  ximg depth := screen root_depth
  ximg bytes_per_line := img line_size
  ximg bits_per_pixel := img:pixel_size*8
  ximg red_mask := visual red_mask
  ximg green_mask := visual green_mask
  ximg blue_mask := visual blue_mask
  ximg data := linebuf
  c sem_request
  if not (XInitImage ximg)
    error "Failed to setup X11 image"
  for (var Int iy) 0 img:size_y-1
  if not (XInitImage ximg)
    error "Failed to setup X11 image"
  for (var Int iy) 0 img:size_y-1
    img read 0 iy img:size_x linebuf
    if (XPutImage display c:window gc ximg 0 0 tx ty+iy img:
      error "Failed to draw X11 image"
  XFreeGC display gc
    var Address adr := img read_map 0 iy img:size_x img:size_x (var Int count)
    if adr<>null
      ximg data := adr
      if (XPutImage display c:window c:gc ximg 0 0 tx ty+iy img:size_x 1)<>0
        error "Failed to draw X11 image"
      img read_unmap 0 iy count adr
    else
      img read 0 iy img:size_x linebuf
      ximg data := linebuf
      if (XPutImage display c:window c:gc ximg 0 0 tx ty+iy img:size_x 1)<>0
        error "Failed to draw X11 image"
  c:sem release
  memory_free linebuf


method c copy x0 y0 x1 y1 xx yy
  oarg_rw ConsoleX11 c ; arg Int x0 y0 x1 y1 xx yy
  memory_free linebuf


method c copy x0 y0 x1 y1 xx yy
  oarg_rw ConsoleX11 c ; arg Int x0 y0 x1 y1 xx yy
  var XGC gc := XCreateGC display c:window 0 (var XGCValues 
  XCopyArea display c:window c:window gc x0 y0 x1-x0 y1-y0 x
  XFreeGC display gc
  if x1-x0<0 or y1-y0<0 or x1-x0>2048 or y1-y0>2048
    error "X11 copy overflow "+string:x0+" "+string:y0+" "+string:x1+" "+string:y1
  c sem_request
  XCopyArea display c:window c:window c:gc x0 y0 x1-x0 y1-y0 xx yy
  c:sem release


function x11_keyboard_mapping id -> key
  arg Int id ; arg Str key


function x11_keyboard_mapping id -> key
  arg Int id ; arg Str key
  if id<256
    key := string id
  eif id=XK_Return
  if id=XK_Return
    key := "enter"
  eif id=XK_BackSpace
    key := "backspace"
    key := "enter"
  eif id=XK_BackSpace
    key := "backspace"
  eif id=XK_Tab
  eif id=XK_Tab or id=XK_ISO_Left_Tab
    key := "tab"
  eif id=XK_Escape
    key := "escape"
  eif id=XK_Left
    key := "left"
  eif id=XK_Up
    key := "up"
  eif id=XK_Right
    key := "right"
  eif id=XK_Down
    key := "down"
  eif id=XK_Page_Up
    key := "pageup"
  eif id=XK_Page_Down
    key := "pagedown"
  eif id=XK_Home
    key := "home"
  eif id=XK_End
    key := "end"
  eif id=XK_Insert
    key := "insert"
  eif id=XK_Delete
    key := "delete"
    key := "tab"
  eif id=XK_Escape
    key := "escape"
  eif id=XK_Left
    key := "left"
  eif id=XK_Up
    key := "up"
  eif id=XK_Right
    key := "right"
  eif id=XK_Down
    key := "down"
  eif id=XK_Page_Up
    key := "pageup"
  eif id=XK_Page_Down
    key := "pagedown"
  eif id=XK_Home
    key := "home"
  eif id=XK_End
    key := "end"
  eif id=XK_Insert
    key := "insert"
  eif id=XK_Delete
    key := "delete"
  eif id=XK_Shift_L or id=XK_Shift_R
    key := "shift"
  eif id=XK_Control_L or id=XK_Control_R
    key := "ctrl"
  eif id=XK_Alt_L or id=XK_Alt_R
    key := "alt"
  eif id>=XK_F1 and id<=XK_F12
    key := "F"+(string id-XK_F0)
  else
  eif id>=XK_F1 and id<=XK_F12
    key := "F"+(string id-XK_F0)
  else
    # console "X11 key id is " id eol
    key := ""

    key := ""

method c event key buttons x_or_x0 y_or_y0 x1 y1 -> event
  oarg_rw ConsoleX11 c ; arg_w Str key ; arg_w Int buttons x
  key := "" ; buttons := undefined ; x_or_x0 := undefined ; 
  XNextEvent display (var XEvent ev)
  if ev:type=Expose or ev:type=GraphicsExpose
    var Pointer:XExposeEvent expose :> addressof:ev map XExp
    if trace
      console "redraw " expose:x " " expose:y " " expose:x+e
    x_or_x0 := expose x ; y_or_y0 := expose y ; x1 := expose
    event := "redraw"
    while (XCheckMaskEvent display ExposureMask ev)
      x_or_x0 := min x_or_x0 expose:x
      y_or_y0 := min y_or_y0 expose:y
      x1 := max expose:x+expose:width x1
      y1 := max expose:y+expose:height y1
  eif ev:type=NoExpose
    if trace
      console "noexpose" eol
  eif ev:type=KeyPress or ev:type=KeyRelease
    var Pointer:XKeyEvent k :> addressof:ev map XKeyEvent
    if trace
      console "key " k:keycode " state " k:state
    x_or_x0 := k x ; y_or_y0 := k y
    buttons := k:state\256%7
    key := "                     "
    memory_clear addressof:(var XComposeStatus cstatus) XCom
    XLookupString k key:characters key:len (var XKeySym keys
    key := x11_keyboard_mapping keysym:id
    event := shunt ev:type=KeyPress "press" "release"
  eif ev:type=ButtonPress or ev:type=ButtonRelease
    var Pointer:XButtonEvent button :> addressof:ev map XBut
    if trace
      console "button " button:button " state " button:state
    x_or_x0 := button x ; y_or_y0 := button y
    buttons := button:state\256%7
    if button:button>=1 and button:button<=3
      key := "button"+(string button:button)
      event := shunt ev:type=ButtonPress "press" "release"
  eif ev:type=MotionNotify
    while (XCheckMaskEvent display ButtonMotionMask ev)
      void
    var Pointer:XMotionEvent motion :> addressof:ev map XMot
    event := "move"
    x_or_x0 := motion x ; y_or_y0 := motion y
    buttons := motion:state\256%7
  eif ev:type=ConfigureNotify
    var Pointer:XConfigureEvent configure :> addressof:ev ma
    x_or_x0 := configure width ; y_or_y0 := configure height
    event := "resize"
  eif trace
    console "unknown event " ev:type eol


function clipboard_content param fun -> text
  arg Address param ; arg Function fun ; arg Str text
  indirect


method c event key buttons x_or_x0 y_or_y0 x1 y1 options -> event
  oarg_rw ConsoleX11 c ; arg_w Str key ; arg_w Int buttons x_or_x0 y_or_y0 x1 y1 ; arg_w Str options ; arg Str event
  key := "" ; buttons := undefined ; x_or_x0 := undefined ; y_or_y0 := undefined ; x1 := undefined ; y1 := undefined ; options := "" ; event := ""
  c:sem request
  part wait_for_event
    XNextEvent display (var XEvent ev)
    if ev:type=Expose or ev:type=GraphicsExpose
      var Pointer:XExposeEvent expose :> addressof:ev map XExposeEvent
      if trace
        console "redraw " expose:x " " expose:y " " expose:x+expose:width " " expose:y+expose:height " (" expose:count ")" eol
      x_or_x0 := expose x ; y_or_y0 := expose y ; x1 := expose:x+expose:width ; y1 := expose:y+expose:height
      event := "redraw"
      while (XCheckTypedEvent display GraphicsExpose ev)
        x_or_x0 := min x_or_x0 expose:x
        y_or_y0 := min y_or_y0 expose:y
        x1 := max expose:x+expose:width x1
        y1 := max expose:y+expose:height y1
    eif ev:type=NoExpose
      if trace
        console "noexpose" eol
    eif ev:type=KeyPress or ev:type=KeyRelease
      var Pointer:XKeyEvent k :> addressof:ev map XKeyEvent
      x_or_x0 := k x ; y_or_y0 := k y
      buttons := k:state\256%7
      key := "                     "
      memory_clear addressof:(var XComposeStatus cstatus) XComposeStatus:size
      XLookupString k key:characters key:len (var XKeySym keysym) cstatus
      options := "keycode "+(string k:keycode)
      if keysym:id>0 and keysym:id<0F000h
        key := utf8_encode (character32 keysym:id)
        event := shunt ev:type=KeyPress "character" "uncharacter"
      else
        key := x11_keyboard_mapping keysym:id
        event := shunt ev:type=KeyPress "press" "release"
      if key=""
        restart wait_for_event
      if event="press" or event="release" or ((k:state .and. 12)<>0 and key:len=1 and ((key>="a" and key<="z") or (key>="A" and key<="Z") or (key>="0" and key<="1")))
        event := shunt event="character" "press" event="uncharacter" "release" event
        if (k:state .and. 8)<>0 and key<>"alt"
          key := "alt "+key
        if (k:state .and. 4)<>0 and key<>"ctrl"
          key := "ctrl "+key
        if (k:state .and. 1)<>0 and key<>"shift"
          key := "shift "+key
      if trace
        console "key " k:keycode " state " k:state " keysym " keysym:id " -> " event " " key eol
    eif ev:type=ButtonPress or ev:type=ButtonRelease
      var Pointer:XButtonEvent button :> addressof:ev map XButtonEvent
      if trace
        console "button " button:button " state " button:state " position " button:x " " button:y eol
      x_or_x0 := button x ; y_or_y0 := button y
      buttons := button:state\256%7
      if button:button>=1 and button:button<=3
        key := "button"+(string button:button)
        event := shunt ev:type=ButtonPress "press" "release"
      c lock_x := x_or_x0 ; c lock_y := y_or_y0
    eif ev:type=MotionNotify
      while (XCheckTypedEvent display MotionNotify ev)
        void
      var Pointer:XMotionEvent motion :> addressof:ev map XMotionEvent
      if c:locked
        event := "scroll"
        var uInt none := 0
        x_or_x0 := motion:x-c:lock_x ; y_or_y0 := motion:y-c:lock_y
        if x_or_x0=0 and y_or_y0=0
          restart wait_for_event
        x1 := c lock_x ; y1 := c lock_y
        XWarpPointer display (addressof:none map XWindow) (addressof:none map XWindow) 0 0 0 0 -x_or_x0 -y_or_y0
        XMaskEvent display ButtonMotionMask ev
      else
        event := "move"
        x_or_x0 := motion x ; y_or_y0 := motion y
      buttons := motion:state\256%7
    eif ev:type=ConfigureNotify
      var Pointer:XConfigureEvent configure :> addressof:ev map XConfigureEvent
      x_or_x0 := configure width ; y_or_y0 := configure height
      while (XCheckTypedEvent display ConfigureNotify ev)
        var Pointer:XConfigureEvent configure :> addressof:ev map XConfigureEvent
        x_or_x0 := configure width ; y_or_y0 := configure height
      event := "resize"
    eif ev:type=ClientMessage
      c:sem release
      sleep 0.01
      c:sem request
    eif ev:type=SelectionRequest
      var Pointer:XSelectionRequestEvent sre :> addressof:ev map XSelectionRequestEvent
      var CBool ok := sre:selection=XA_PRIMARY and (sre:target=atom_utf8 or sre:target=XA_STRING) and (addressof c:clipboard_fun)<>null
      if ok
        var Int prop := sre property
        var Str text := clipboard_content c:clipboard_param c:clipboard_fun
        if sre:target=atom_utf8
          XChangeProperty display sre:requestor prop XA_STRING 8 PropModeReplace text:characters text:len
        else
          var Str8 text8 := text
          XChangeProperty display sre:requestor prop XA_STRING 8 PropModeReplace text8:characters text8:len
      var XSelectionEvent se
      se type := SelectionNotify
      se serial := 0
      se send_event := true
      se display :> display
      se requestor := sre requestor
      se selection := sre selection
      se target := sre target
      se property := shunt ok prop 0
      se time := sre time
      XSendEvent display sre:requestor false 0 (addressof:se map XEvent)
    eif ev:type=SelectionClear
      c clipboard_fun :> null map Function
    eif trace
      console "unknown event " ev:type eol
    if event=""
      restart wait_for_event
  c:sem release


method c lock_pointer locked
  oarg_rw ConsoleX11 c ; arg CBool locked
  c locked := locked


method c close
  oarg_rw ConsoleX11 c
method c close
  oarg_rw ConsoleX11 c
  XFreeGC display c:gc
  XDestroyWindow display c:window


  XDestroyWindow display c:window


method c clipboard_export fun param
  oarg_rw ConsoleX11 c ; arg Function fun ; arg Address param
  c:sem request
  c clipboard_fun :> fun
  c clipboard_param := param
  XSetSelectionOwner display XA_PRIMARY c:window 0
  c:sem release


method c clipboard_import text -> status
  oarg_rw ConsoleX11 c ; arg_w Str text ; arg Status status
  c:sem request
  text := ""
  status := failure
  if not (exists c:clipboard_fun)
    for (var Int lap) 1 2
      constant prop XA_STRING
      var Int req_type := shunt lap=1 atom_utf8 XA_STRING
      XConvertSelection display XA_PRIMARY req_type prop c:window 0
      part wait
        for (var Int lap) 1 50
          if (XCheckTypedEvent display SelectionNotify (var XEvent ev))
            if (addressof:ev map XSelectionEvent):property=0
              leave wait
            XGetWindowProperty display c:window prop 0 2^24 true req_type (var Int actual_type) (var Int actual_format) (var Int size) (var Int bytes_after) (var Address adr)
            var Address adr2 := memory_allocate size null
            memory_copy adr adr2 size
            if lap=1
              text set adr2 size true
            else
              (var Str text8) set adr2 size true
              text := text8
            XFree adr
            status := success
            leave wait
          sleep 0.01
  c:sem release


graphic_console_record "x11" ConsoleX11
graphic_console_record "x11" ConsoleX11