Patch title: Release 93 bulk changes
Abstract:
File: /graphic/browser/tag/prototype.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/compiler.pli"
submodule "/pliant/graphic/browser/xml/tree.pli"
submodule "/pliant/graphic/browser/xml/context.pli"
submodule "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/browser/document.pli"
module "/pliant/graphic/browser/context.pli"


gvar Dictionary tag_position_dictionary
gvar Dictionary tag_draw_dictionary
gvar Dictionary tag_event_dictionary


named_expression tag_position_prototype
  method context 'pliant tag position function' tree
    arg_rw XmlContext context ; arg_rw XmlTree tree
    implicit context tree
  method context 'pliant tag position function' node
    arg_rw BrowserContext context ; arg_rw BrowserNode node
    implicit context node
      body

meta tag_position e
meta browser_tag_position e
  if e:size=2 and e:0:is_pure_ident and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate tag_position_prototype substitute body e:1 near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first ". pliant tag position function") map Function
    e:module rewind mark
    if exists:f
      tag_position_dictionary insert e:0:ident true addressof:f
      e set_void_result


named_expression tag_draw_prototype
  method context 'pliant tag draw function' tree
    arg_rw XmlContext context ; arg_rw XmlTree tree
    implicit context tree
  method context 'pliant tag draw function' node
    arg_rw BrowserContext context ; arg_rw BrowserNode node
    implicit context node
      body

meta tag_draw e
meta browser_tag_draw e
  if e:size=2 and e:0:is_pure_ident and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate tag_draw_prototype substitute body e:1 near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first ". pliant tag draw function") map Function
    e:module rewind mark
    if exists:f
      tag_draw_dictionary insert e:0:ident true addressof:f
      e set_void_result


named_expression tag_event_prototype
  method context 'pliant tag event function' tree -> consumed
    arg_rw XmlContext context ; arg_rw XmlTree tree ; arg CBool consumed
    consumed := false
    implicit context tree
  method context 'pliant tag event function' node
    arg_rw BrowserContext context ; arg_rw BrowserNode node
    implicit context node
      body

meta tag_event e
meta browser_tag_event e
  if e:size=2 and e:0:is_pure_ident and e:1:ident="{}"
    var Address mark := e:module mark
    var Link:Expression ee :> expression duplicate tag_event_prototype substitute body e:1 near e
    error_push_record (var ErrorRecord er) error_filter_all
    ee compile
    if er:id<>error_id_noerror
      console er:message eol
      er id := error_id_noerror
      e suckup_error ee
    error_pull_record er
    var Link:Function f :> (pliant_general_dictionary first ". pliant tag event function") map Function
    e:module rewind mark
    if exists:f
      tag_event_dictionary insert e:0:ident true addressof:f
      e set_void_result

export tag_position_dictionary tag_draw_dictionary
export tag_position tag_draw tag_event
export browser_tag_position browser_tag_draw browser_tag_event


#-----------------------------------------------------------------------------


method context tag_position_prototype tree f
  arg_rw XmlContext context ; arg_rw XmlTree tree ; arg Function f
method context tag_position_prototype node f
  arg_rw BrowserContext context ; arg_rw BrowserNode node ; arg Function f
  indirect

method context position tree
  arg_rw XmlContext context ; arg_rw XmlTree tree
  var Str tag := tree tag
method context position node
  arg_rw BrowserContext context ; arg_rw BrowserNode node
  var Str tag := node tag
  context mark
  context set tag
  tree first_attr (var Str attr) (var Str value)
  node first_attribute (var Str attr) (var Str value)
  while attr<>""
    context set tag attr value
    tree next_attr (var Str attr) (var Str value)
  tree x0 := undefined ; tree y0 := undefined ; tree x1 := undefined ; tree y1 := undefined
    node next_attribute (var Str attr) (var Str value)
  memory_free node:extra ; node extra := null
  var Pointer:Arrow c :> tag_position_dictionary first tag
  if c<>null
    context tag_position_prototype tree (c map Function)
    context tag_position_prototype node (c map Function)
  else
    each sub tree
    each sub node
      context position sub
  context rewind


method context tag_draw_prototype tree f
  arg_rw XmlContext context ; arg_rw XmlTree tree ; arg Function f
method context tag_draw_prototype node f
  arg_rw BrowserContext context ; arg_rw BrowserNode node ; arg Function f
  indirect

method context draw tree
  arg_rw XmlContext context ; arg_rw XmlTree tree
  if tree:x0=defined and context:clip_x0=defined
    if tree:x0>=context:clip_x1 or tree:x1<=context:clip_x0 or tree:y0>context:clip_y1 or tree:y1<context:clip_y0
method context draw node
  arg_rw BrowserContext context ; arg_rw BrowserNode node
  if node:has_area and context:clip_x0=defined
    if node:area:x0>=context:clip_x1 or node:area:x1<=context:clip_x0 or node:area:y0>context:clip_y1 or node:area:y1<context:clip_y0
      return
  var Str tag := tree tag
  var Str tag := node tag
  context mark
  context set tag
  tree first_attr (var Str attr) (var Str value)
  node first_attribute (var Str attr) (var Str value)
  while attr<>""
    context set tag attr value
    tree next_attr (var Str attr) (var Str value)
  var Pointer:Arrow c :> tag_draw_dictionary first tree:tag
    node next_attribute (var Str attr) (var Str value)
  var Pointer:Arrow c :> tag_draw_dictionary first node:tag
  if c<>null
    context tag_draw_prototype tree (c map Function)
    context tag_draw_prototype node (c map Function)
  else
    each sub tree
    each sub node
      context draw sub
  context rewind


method context tag_event_prototype tree f -> consumed
  arg_rw XmlContext context ; arg_rw XmlTree tree ; arg Function f ; arg CBool consumed
method context tag_event_prototype node f
  arg_rw BrowserContext context ; arg_rw BrowserNode node ; arg Function f
  indirect

method context event tree -> result
  arg_rw XmlContext context ; arg_rw XmlTree tree ; arg Int result
  result := 0
  if tree:x0=defined
    if tree:x0>context:x or tree:x1<context:x or tree:y0>context:y or tree:y1<context:y
method context event node
  arg_rw BrowserContext context ; arg_rw BrowserNode node
  if node:has_area
    if node:area:x0>context:x or node:area:x1<context:x or node:area:y0>context:y or node:area:y1<context:y
      return
    else
      result := 1
  var Str tag := tree tag
  context mark
  var Str tag := node tag
  context set tag
  tree first_attr (var Str attr) (var Str value)
  node first_attribute (var Str attr) (var Str value)
  while attr<>""
    context set tag attr value
    tree next_attr (var Str attr) (var Str value)
  each sub tree
    result := max result (context event sub)
  if result=1
    var Pointer:Arrow c :> tag_event_dictionary first tree:tag
    node next_attribute (var Str attr) (var Str value)
  var Pointer:BrowserNode sub :> node first
  if exists:sub
    while { var Pointer:BrowserNode n :> sub next ; exists n }
      sub :> n
    while not context:discard_event_flag and exists:sub
      context event sub
      sub :> sub previous
  if not context:discard_event_flag
    var Pointer:Arrow c :> tag_event_dictionary first node:tag
    if c<>null
      if (context tag_event_prototype tree (c map Function))
        result=2
      context tag_event_prototype node (c map Function)
  context rewind


export '. position' '. draw' '. event'