Patch title: Release 90 bulk changes
Abstract:
File: /graphic/browser/frontend/x11.pli
Key:
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/protocol/http/client.pli"

module "/pliant/graphic/browser/xml/tree.pli"
module "/pliant/graphic/browser/xml/io.pli"
module "/pliant/graphic/browser/xml/context.pli"

module "/pliant/graphic/browser/tag/prototype.pli"
module "/pliant/graphic/browser/tag/all.pli"

module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/packed.pli"
module "/pliant/graphic/image/antialiasing.pli"
module "/pliant/graphic/image/convert.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/draw/image.pli"
module "/pliant/graphic/os/x11.pli"

constant debug true


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 dpi 72
constant page_mm_x 300
constant page_mm_y 297
constant ground_color (rgb_color 255 255 255)
constant antialiasing 4
constant margin 5
constant window_size_x (cast page_mm_x/25.4*dpi Int)+2*margin
constant window_size_y (cast page_mm_y/25.4*dpi Int)+2*margin
constant memory_maximum_buffer 8*2^20
constant window_max_x 8192
constant window_max_y 8192
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 XScreen display:default_screen) map XScreen
gvar Pointer:XVisual visual :> screen root_visual
if screen:root_depth<>24
  error "Pliant requires X11 to work in truecolor mode (either 24 or 32 bits per pixel)"

function x11_gamut_name -> name
  arg Str name
  name := "rgb"
  if visual:red_mask=255*2^16
    name := shunt name="rgb" "bgr" "rgb"
  if (shunt processor_is_low_indian LSBFirst MSBFirst)<>display:byte_order
    name := shunt name="rgb" "bgr" "rgb"
  check display:bitmap_unit=24 or display:bitmap_unit=32
  if display:bitmap_unit=32
    name += "32"


function x11_color rgb -> c
  arg Int rgb ; arg Str c
  function hexa2 i -> h2
    arg Int i ; arg Str h2
    h2 := right (string i "radix 16") 2 "0"
  c := "rgb:"+(hexa2 rgb%256)+"/"+(hexa2 rgb\256%256)+"/"+(hexa2 rgb\256^2)

if (XAllocNamedColor display screen:cmap x11_color:ground_color (gvar XColor x11_ground_exact) (gvar XColor x11_ground))=0
  error "Failed to allocate X11 ground color"


function redraw url t ux uy ix0 iy0 ix1 iy1 window x y
  arg Str url ; arg_rw XmlTree t ; arg Float ux uy ; arg Int ix0 iy0 ix1 iy1 ; arg XWindow window ; arg Int x y
  if ix1<=ix0 or iy1<=iy0
    return
  if (ix1-ix0)*(iy1-iy0)*antialiasing*antialiasing*3>memory_maximum_buffer
    var Int m := (iy0+iy1)\2
    redraw url t ux uy ix0 iy0 ix1 m window x y
    redraw url t ux uy ix0 m ix1 iy1 window x y+m-iy0
    return
  if antialiasing=1
    var Link:ImagePixmap pixmap :> new ImagePixmap
    pixmap setup (image_prototype ix0*ux iy0*uy ix1*ux iy1*uy ix1-ix0 iy1-iy0 color_gamut:"rgb") ""
    var Link:ImagePrototype initial :> pixmap
    var Link:ImagePrototype final :> pixmap
  else
    var Link:ImagePixmap packed :> new ImagePixmap
    # var Link:ImagePacked packed :> new ImagePacked
    packed setup (image_prototype ix0*ux iy0*uy ix1*ux iy1*uy (ix1-ix0)*antialiasing (iy1-iy0)*antialiasing color_gamut:"rgb") ""
    var Link:ImageAntiAliasing aa :> new ImageAntiAliasing
    aa bind packed antialiasing antialiasing
    var Link:ImagePrototype initial :> packed
    var Link:ImagePrototype final :> aa
  var Link:ImageConvert conv :> new ImageConvert
  conv bind final color_gamut:x11_gamut_name ""
  final :> conv
  for (var Int iy) 0 initial:size_y-1
    initial fill 0 iy initial:size_x addressof:ground_color
  var Link:DrawImage draw :> new DrawImage
  draw image :> initial
  (var XmlContext context) draw_setup url draw initial:x0 initial:y0 initial:x1 initial:y1
  context draw t
  var Address linebuf := memory_allocate final:line_size null
  var XGC gc := XCreateGC display window 0 (var XGCValues gcvalues) 
  var XImage img
  img width := final size_x
  img height := 1
  img xoffset := 0
  img format := ZPixmap
  img byte_order := display byte_order
  check display:bitmap_unit=final:pixel_size*8
  img bitmap_unit := display bitmap_unit
  img bitmap_bit_order := display bitmap_bit_order
  img bitmap_pad := display bitmap_pad
  img depth := screen root_depth
  img bytes_per_line := final line_size
  img bits_per_pixel := final:pixel_size*8
  img red_mask := visual red_mask
  img green_mask := visual green_mask
  img blue_mask := visual blue_mask
  img data := linebuf
  if not (XInitImage img)
    error "Failed to setup X11 image"
  for (var Int iy) 0 final:size_y-1
    final read 0 iy final:size_x linebuf
    if (XPutImage display window gc img 0 0 x y+iy final:size_x 1)<>0
      error "Failed to draw X11 image"
  # XSetForeground display gc (rgb_color 255 128 128)
  # XFillRectangle display window gc final:size_x-5 0 5 5
  XFreeGC display gc
  memory_free linebuf


function x11_keyboard_mapping id -> key
  arg Int id ; arg Str key
  if id<256
    key := string id
  eif id=XK_Return
    key := "enter"
  eif id=XK_BackSpace
    key := "backspace"
  eif id=XK_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"
  eif id>=XK_F1 and id<=XK_F12
    key := "F"+(string id-XK_F0)
  else
    key := ""


type BrowserHistory
  field Str url
  field Int tx ty

function browse url user password
  arg Str url user password
  console "Back button is F12" eol
  var List:BrowserHistory history
  var Link:XmlTree tree :> new XmlTree
  var Str options := ""
  if user<>""
    options := "user "+string:user+" password "+string:password
  var Str current_url := "" ; var Str new_url := url
  var Int tx := -margin ; var Int ty := -margin
  var Int memo_x memo_y ; var CBool scroll
  var XSetWindowAttributes a
  a background_pixel := x11_ground pixel
  a override_redirect := false # true
  a event_mask := PointerMotionMask+ButtonPressMask+ButtonReleaseMask+KeyPressMask+KeyReleaseMask+ExposureMask
  var uInt mask := CWBackPixel+CWBorderPixel+CWOverrideRedirect+CWEventMask
  var XWindow window := XCreateWindow display screen:root 0 0 window_size_x window_size_y 0 screen:root_depth InputOutput screen:root_visual mask a
  XStoreName display window "Pliant browser"
  XMapWindow display window
  while true
    if new_url<>current_url
      if debug
        memory_checkup
      var DateTime dt := datetime
      tree load string:new_url+" no_http_encode" "lowercase"
      console "loaded " new_url " in " string:(cast (datetime:seconds-dt:seconds)*1000 Int) " ms" eol
      tree save "file:/tmp/test.html" ""
      if debug
        memory_checkup
      (var XmlContext context) position_setup new_url 0 0 page_mm_x page_mm_y
      context position tree
      if debug
        memory_checkup
      XClearArea display window 0 0 window_max_x window_max_y true
      if current_url<>""
        var BrowserHistory h ; h url := current_url ; h tx := tx ; h ty := ty
        history += h
        tx := -margin ; ty := -margin 
      current_url := new_url
    XNextEvent display (var XEvent event)
    if event:type=Expose or event:type=GraphicsExpose
      var Pointer:XExposeEvent expose :> addressof:event map XExposeEvent
      if trace
        console "redraw " expose:x " " expose:y " " expose:x+expose:width " " expose:y+expose:height " (" expose:count ")" eol
      # var DateTime dt := datetime
      redraw current_url tree 25.4/dpi 25.4/dpi expose:x+tx expose:y+ty expose:x+expose:width+tx expose:y+expose:height+ty window expose:x expose:y
      # console (cast (datetime:seconds-dt:seconds)*1000 Int) " ms" eol
      if event:type=GraphicsExpose and expose:count=0
        scroll := true
    eif event:type=NoExpose
      if trace
        console "noexpose" eol
      scroll := true
    eif event:type=KeyPress or event:type=KeyRelease
      var Pointer:XKeyEvent k :> addressof:event map XKeyEvent
      if trace
        console "key " k:keycode " state " k:state
      var Str key := "                     "
      memory_clear addressof:(var XComposeStatus cstatus) XComposeStatus:size
      XLookupString k key:characters key:len (var XKeySym keysym) cstatus
      key := x11_keyboard_mapping keysym:id 
      if event:type=KeyPress and key="F12"
        if (exists history:last)
          current_url := ""
          new_url := history:last url
          tx := history:last tx ; ty := history:last ty
          history remove history:last
      eif key<>""
        (var XmlContext context) event_setup current_url (shunt k:type=KeyPress "press " "release ")+key (k:x+tx)*25.4/dpi (k:y+ty)*25.4/dpi
        context event tree
        if k:type=KeyPress
          (var XmlContext context) event_setup current_url key (k:x+tx)*25.4/dpi (k:y+ty)*25.4/dpi
          context event tree
        new_url := context url
        if new_url=current_url and event:type=KeyPress
          (var XmlContext context) event_setup current_url key (k:x+tx)*25.4/dpi (k:y+ty)*25.4/dpi
          context event tree
          new_url := context url
      else
        console (shunt k:type=KeyPress "press " "release ")+"keycode" k:keycode " keysym " keysym:id eol
    eif event:type=ButtonPress or event:type=ButtonRelease
      var Pointer:XButtonEvent button :> addressof:event map XButtonEvent
      if trace
        console "button " button:button " state " button:state " position " button:x " " button:y eol
      if event:type=ButtonPress and button:button=2
        memo_x := button x ; memo_y := button y ; scroll := true
      var Str key := ""
      if button:button>=1 and button:button<=3
        key := (shunt event:type=ButtonPress "press" "release")+" button"+(string button:button)
      (var XmlContext context) event_setup current_url key (button:x+tx)*25.4/dpi (button:y+ty)*25.4/dpi
      context event tree
      if context:url<>current_url
        new_url := context url
    eif event:type=MotionNotify
      var Pointer:XMotionEvent motion :> addressof:event map XMotionEvent
      if trace
        console "motion " motion:x " " motion:y " (" motion:state ")" eol
      if motion:state=512 and scroll # middle button is down
        var Int delta_x := min motion:x-memo_x tx+margin ; var Int delta_y := min motion:y-memo_y ty+margin
        if delta_x<>0 or delta_y<>0
          var XGC gc := XCreateGC display window 0 (var XGCValues gcvalues)
          XCopyArea display window window gc -delta_x -delta_y window_max_x+abs:delta_x window_max_y+abs:delta_y 0 0
          XFreeGC display gc
          scroll := false
        tx -= delta_x ; ty -= delta_y
        memo_x := motion x ; memo_y := motion y
    else
      console "unknown event " event:type eol

function browse url
  arg Str url
  browse url "" ""

export browse