Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/browser/server/instructions.pli
Key:
    Removed line
    Added line
module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/util/pml/io.pli"
module "/pliant/util/pml/body.pli"
module "context.pli"
module "/pliant/protocol/http/site.pli"
module "/pliant/storage/database.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/math/vector.pli"
module "/pliant/math/curve.pli"

constant debug true


method c allowed name -> a # FIXME: code is duplicated from api.pli
  arg_rw BrowserServerContext c ; arg Str name ; arg CBool a
  a := c:user_is_admin or (c:user_rights first name)<>null and name<>""


browser_server_instruction pliant
  if not (connection itag "pliant")
    connection error "invalid 'pliant' instruction"


function page_prototype context fun
  arg_rw BrowserServerContext context ; arg Function fun
  indirect

browser_server_instruction connect
  if (connection itag "connect" (var Str site_name) (var Str url))
    var Data:Site site :> site_database:data:site site_name
    if site:computer<>computer_fullname and site:computer<>""
      site :> var Data:Site no_site
    var Int longuest := 0
    var Data:SiteArea area
    each a site:area
      var Str p := a path
      if (url 0 p:len)=p
        var Int l := p len
        if l>longuest
          area :> a
          longuest := l
        eif l=longuest
          area :> var Data:SiteArea nonexisting_area
    if (allowed area:read)
      user_rights kmap "read" Bool := true
    else
      if debug
        console "not allowed" eol
      connection error "not allowed"
      return
    if (allowed area:write)
      user_rights kmap "write" Bool := true
    if area:root<>""
      url := area:root+(url area:path:len url:len)
    browser_pages_sem rd_request
    var Int i := url len
    # FIXME: two slow
    while { var Link:Function fun :> (browser_pages first (url 0 i)) map Function ; not exists:fun and i>0 }
      i -= 1
    browser_pages_sem rd_release
    if exists:fun
      context url := url
      context subpath := url i url:len
      context env := var Dictionary empty_dictionary
      connection oraw open (cast "group" Ident) body
      page_prototype context fun
      connection oraw close
    else
      connection error "unkown url '"+url+"' requested"
  else
    connection error "invalid 'connect' instruction"


constant from_index (the_function '. from string' Universal Str Str CBool Int Int -> Status):generic_index

function from_string data string options may_skip skiped offset function -> status
  arg Universal data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Function function ; arg Status status
  indirect

function execute1 a f
  arg Address a ; arg Function f
  indirect

browser_server_instruction set
  env_sem request
  if (connection itag "set" (var Str id) (var Str value))
    if (id parse (var Str sid) (var Str vid))
      var Link:BrowserServerSection section :> (env first "section "+sid) map BrowserServerSection
      if exists:section and (entry_type addressof:section)=BrowserServerSection
        var Link:BrowserServerVariable va :> (section:env first vid) map BrowserServerVariable
        if exists:va and (entry_type addressof:va)=BrowserServerVariable
          if va:variable<>null
            var Pointer:Function fun :> (entry_type va:variable) get_generic_method from_index
            if exists:fun and fun<>(the_function '. from string' Universal Str Str CBool Int Int -> Status)
              from_string (va:variable map Universal) value "db" true (var Int skiped) (var Int offset) fun 
          if va:data_path<>""
            var Data_ data := data_root search_path va:data_path false
            data:base:sem request
            var Status status := data:interface set data addressof:value Str
            data:base:sem release
          if (exists va:run:function)
            var DelayedAction action := va run
            env_sem release
            connection oraw open (cast "group" Ident) body
            execute1 action:parameter action:function
            connection oraw close
            env_sem request
  env_sem release


browser_server_instruction run
  env_sem request
  if (connection itag "run" (var Str id))
    if (id parse (var Str sid) (var Str bid))
      var Link:BrowserServerSection section :> (env first "section "+sid) map BrowserServerSection
      if exists:section and (entry_type addressof:section)=BrowserServerSection
        var Link:DelayedAction da :> (section:env first bid) map DelayedAction
        if exists:da and (entry_type addressof:da)=DelayedAction
          env_sem release
          connection oraw open (cast "group" Ident) body
          execute1 da:parameter da:function
          connection oraw close
          env_sem request
  env_sem release


browser_server_instruction over
  env_sem request
  if (connection itag "over" (var Str id) (var CBool on))
    if (id parse (var Str sid) (var Str bid))
      var Link:BrowserServerSection section :> (env first "section "+sid) map BrowserServerSection
      if exists:section and (entry_type addressof:section)=BrowserServerSection
        var Link:Str help :> (section:env first bid+" help") map Str
        var Link:DelayedAction da :> (section:env first bid) map DelayedAction
        var Link:BrowserServerVariable va :> (section:env first bid) map BrowserServerVariable
        if exists:help and (entry_type addressof:help)=Str
          env_sem release
          connection oraw open (cast "group" Ident) body
          connection oraw open (cast "section_overwrite" Ident) "help" body
          connection oraw open (cast "para" Ident) (cast "stick" Ident) body
          if on
            connection oraw open (cast "text" Ident) help close
          connection oraw close
          connection oraw close
          connection oraw close
          env_sem request
        eif exists:da and (entry_type addressof:da)=DelayedAction
          context over_on := on
          context over_off := not on
          env_sem release
          connection oraw open (cast "group" Ident) body
          execute1 da:parameter da:function
          connection oraw close
          env_sem request
          context over_on := false
          context over_off := false
        eif exists:va and (entry_type addressof:va)=BrowserServerVariable and (exists va:run:function)
          context over_on := on
          context over_off := not on
          var DelayedAction action := va run
          env_sem release
          connection oraw open (cast "group" Ident) body
          execute1 action:parameter action:function
          connection oraw close
          env_sem request
          context over_on := false
          context over_off := false
  env_sem release


browser_server_instruction event
  env_sem request
  if (connection itag "event" (var Str id))
    if (id parse (var Str sid) (var Str bid))
      var Link:BrowserServerSection section :> (env first "section "+sid) map BrowserServerSection
      if exists:section and (entry_type addressof:section)=BrowserServerSection
        var Link:DelayedAction da :> (section:env first bid) map DelayedAction
        if exists:da and (entry_type addressof:da)=DelayedAction
          env_sem release
          connection iattr "event" event
          connection iattr "key" key
          connection iattr "pointer_x" pointer_x
          connection iattr "pointer_y" pointer_y
          connection iattr "pointer_section" pointer_section
          connection iattr "pointer_index" pointer_index
          connection iattr "focus_section" focus_section
          connection iattr "focus_index" focus_index
          connection oraw open (cast "group" Ident) body
          execute1 da:parameter da:function
          connection oraw close
          event := "" ; key := ""
          pointer_x := undefined ; pointer_y := undefined
          pointer_section := "" ; pointer_index := undefined
          focus_section := "" ; focus_index := undefined
          env_sem request
  env_sem release


browser_server_instruction thread_run
  if (connection itag "thread_run" (var Str id))
    browser_thread_sem request
    var Pointer:BrowserPendingThread pending :> browser_thread_dict first id
    if exists:pending
      var DelayedAction action := pending action
      var Pointer:Type t :> entry_type action:parameter
      for (var Int i) 0 t:nb_fields-1
        if (t field i):name="context"
          (action:parameter translate Byte (t field i):offset) map Address := addressof context
      env_sem :> pending env_sem
      env :> pending env
    browser_thread_dict remove pending
    browser_thread_sem release
    if exists:pending
      execute1 action:parameter action:function


browser_server_instruction font
  if (connection itag "font" (var Str name))
    if (name 0 1)="/"
      var Link:Font f :> font (name 1 name:len)
      if exists:f
        connection oraw open (cast "font" Ident)
        if (connection iattr "bbox")
          connection oraw (cast "bbox" Ident) f:bbox_x0 f:bbox_y0 f:bbox_x1 f:bbox_y1
        if (connection iattr "vector")
          connection oraw (cast "vector" Ident) f:vector:x f:vector:y
        connection oraw body
        if not (connection ibody_begin)
          return
        while (connection iraw (var Int n))
          var Pointer:FontChar ch :> f:chars first n
          if exists:ch
            connection oraw open (cast "char" Ident) n
            connection oraw (cast "bbox" Ident) ch:bbox_x0 ch:bbox_y0 ch:bbox_x1 ch:bbox_y1
            connection oraw (cast "vector" Ident) ch:vector:x ch:vector:y
            connection oraw body
            for (var Int i) 0 ch:curves:size-1
              var Pointer:Curve c :> ch:curves i
              connection oraw open (cast "c" Ident) c:mode body
              for (var Int j) 0 c:size-1
                var Pointer:CurvePoint p :> c point j
                connection oraw open (cast "p" Ident) p:x p:y
                if p:in_x<>0 or p:in_y<>0
                  connection oraw (cast "i" Ident) (cast p:in_mode Int) p:in_x p:in_y
                if p:out_x<>0 or p:out_y<>0
                  connection oraw (cast "o" Ident) (cast p:out_mode Int) p:out_x p:out_y
                connection oraw close
              connection oraw close
            connection oraw close
        if not (connection ibody_end)
          return
        connection oraw close
        return
  connection oraw (var Void v)