Patch title: Release 90 bulk changes
Abstract:
File: /graphic/vector/font.pli
Key:
    Removed line
    Added line
   
abstract
  [Loading and rendering a PostScript Type 1 font]


abstract
  [Loading and rendering a PostScript Type 1 font]



if false


if false


type FontChar
  field Str char_name
  field Array:Curve curves
  field Vector2 vector
  field Float bbox_x0 bbox_y0 bbox_x1 bbox_y1 <- 0
public


function build fc
  arg_w FontChar fc
  fc vector := vector 1 0
  type FontChar
    field Str char_name
    field Array:Curve curves
    field Vector2 vector <- (vector 1 0)
    field Float bbox_x0 bbox_y0 bbox_x1 bbox_y1 <- 0




type Font
  inherit CachePrototype
  field (Dictionary Int FontChar) chars
  field Float x0 y0 x1 y1 <- 0
  field Str file
  # Pliant way to identify
  field Str family
  field Str fullname
  field Str psname
  field Str md5
  if type1details
    field Str weight
    field Float italic <- 0
    field CBool fixed <- false
public


  type Font
    inherit CachePrototype
    field (Dictionary Int FontChar) chars
    field Float x0 y0 x1 y1 <- 0
    field Str file
    # Pliant way to identify
    field Str family
    field Str fullname
    field Str psname
    field Str md5
    field Array:Int encoding
    if type1details
      field Str weight
      field Float italic <- 0
      field CBool fixed <- false

CachePrototype maybe Font



CachePrototype maybe Font



method f load_postscript filename -> status
  arg_rw Font f ; arg Str filename ; arg Status status
method f load_postscript filename options -> status
  arg_rw Font f ; arg Str filename options ; arg Status status
  if false
    (var Stream s) open "pfb:"+filename in+safe
    (var Stream clear) open "file:/tmp/font.txt" out+safe
    while not s:atend
      clear writeline s:readline
    clear close
  (var Stream s) open "pfb:"+filename in+safe
  if s=failure or not (s:readline parse "%!" any)
    return failure
  f file := filename
  var FontContext ctx ; ctx filename := filename
  while not s:atend
    var Str l := s readline
    if (l parse word:"/FontName" "/" any:(var Str n) word:"d
      f psname := n
    eif (l parse word:"/FullName" "(" any:(var Str n) ")" wo
      f fullname := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" 
      f family := n
    eif type1details and (l parse word:"/Weight" "(" any:(va
      f weight := n
    eif type1details and (l parse word:"/ItalicAngle" (var F
      f italic := ff
    eif type1details and (l parse word:"/isFixedPitch" any:(
      f fixed := n="true"
    eif (l parse word:"/FontBBox" "{" (var Int ix0) (var Int
      f x0 := ix0/1000
      f y0 := -iy1/1000
      f x1 := ix1/1000
      f y1 := -iy0/1000
    eif (l parse word:"dup" (var Int i) "{" any:(var Str d) 
      if i>=0 and i<2^16
        if i>=ctx:subrs:size
          ctx:subrs size := i+1
        ctx:subrs i := d
    eif (l parse "/" any:(var Str n) "{" any:(var Str d) "}"
      ctx:defs insert n d
  if false
    (var Stream s) open "pfb:"+filename in+safe
    (var Stream clear) open "file:/tmp/font.txt" out+safe
    while not s:atend
      clear writeline s:readline
    clear close
  (var Stream s) open "pfb:"+filename in+safe
  if s=failure or not (s:readline parse "%!" any)
    return failure
  f file := filename
  var FontContext ctx ; ctx filename := filename
  while not s:atend
    var Str l := s readline
    if (l parse word:"/FontName" "/" any:(var Str n) word:"d
      f psname := n
    eif (l parse word:"/FullName" "(" any:(var Str n) ")" wo
      f fullname := n
    eif (l parse word:"/FamilyName" "(" any:(var Str n) ")" 
      f family := n
    eif type1details and (l parse word:"/Weight" "(" any:(va
      f weight := n
    eif type1details and (l parse word:"/ItalicAngle" (var F
      f italic := ff
    eif type1details and (l parse word:"/isFixedPitch" any:(
      f fixed := n="true"
    eif (l parse word:"/FontBBox" "{" (var Int ix0) (var Int
      f x0 := ix0/1000
      f y0 := -iy1/1000
      f x1 := ix1/1000
      f y1 := -iy0/1000
    eif (l parse word:"dup" (var Int i) "{" any:(var Str d) 
      if i>=0 and i<2^16
        if i>=ctx:subrs:size
          ctx:subrs size := i+1
        ctx:subrs i := d
    eif (l parse "/" any:(var Str n) "{" any:(var Str d) "}"
      ctx:defs insert n d
    eif (l parse word:"dup" (var Int i) "/" any:(var Str n) _ word:"put")
      var Pointer:Int num :> postscript_glyphs first n
      if i>=0 and i<256 and exists:num
        if f:encoding:size=0
          f:encoding size := 256
          for (var Int j) 0 255
            f:encoding j := undefined
        f:encoding i := num
    else
      void
      # console "font line " l eol
  each def ctx:defs
    var Str n := ctx:defs key def
    var Pointer:Int num :> postscript_glyphs first n
    if exists:num
      var FontChar new_ch := var FontChar empty_char
      ctx open_char_def new_ch n
      ctx interprete def
      ctx close_char_def
      if not auto_accent or not exists:(accents first num) o
        f:chars insert num new_ch
  each def ctx:defs
    var Str n := ctx:defs key def
    var Pointer:Int num :> postscript_glyphs first n
    if exists:num
      var FontChar new_ch := var FontChar empty_char
      ctx open_char_def new_ch n
      ctx interprete def
      ctx close_char_def
      if not auto_accent or not exists:(accents first num) o
        f:chars insert num new_ch
    else
      void
      # console "unsupported glyph " def eol
  if f:x0=0 and f:y0=0 and f:x1=0 and f:y1=0
    each ch f:chars
      for (var Int j) 0 ch:curves:size-1
        ch:curves:j bbox (var Float x0) (var Float y0) (var 
        if y0=defined and y1=defined
          f x0 := min f:x0 x0
          f y0 := min f:y0 y0
          f x1 := max f:x1 x1
          f y1 := max f:y1 y1
  f md5 := file_md5_hexa_signature filename
  if verbose
    console "  loaded font " f:fullname eol
  status := success

  if f:x0=0 and f:y0=0 and f:x1=0 and f:y1=0
    each ch f:chars
      for (var Int j) 0 ch:curves:size-1
        ch:curves:j bbox (var Float x0) (var Float y0) (var 
        if y0=defined and y1=defined
          f x0 := min f:x0 x0
          f y0 := min f:y0 y0
          f x1 := max f:x1 x1
          f y1 := max f:y1 y1
  f md5 := file_md5_hexa_signature filename
  if verbose
    console "  loaded font " f:fullname eol
  status := success

function font_postscript filename -> f
  arg Str filename ; arg Link:Font f
function font_postscript filename options -> f
  arg Str filename options ; arg Link:Font f
  f :> new Font
  f :> new Font
  if (f load_postscript filename)=failure
  if (f load_postscript filename options)=failure
    f :> null map Font


method f bbox text kerning x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Address kerning ; arg_w Fl
  if text:len<>0
    f :> null map Font


method f bbox text kerning x0 y0 x1 y1
  arg Font f ; arg Str text ; arg Address kerning ; arg_w Fl
  if text:len<>0
    var Vector2 v := f vector text:characters text:len-1 1 k
    x0 := min f:x0 v:x+f:x0 ; y0 := min f:y0 v:y+f:y0 ; x1 :
    var Vector2 v := f vector text:characters text:len 1 kerning
    x0 := 0 ; y0 := f y0 ; x1 := v x ; y1 := f y1 # FIXME
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0

method f bbox text kerning x0 y0 x1 y1
  arg Font f ; arg Str32 text ; arg Address kerning ; arg_w 
  if text:len<>0
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0

method f bbox text kerning x0 y0 x1 y1
  arg Font f ; arg Str32 text ; arg Address kerning ; arg_w 
  if text:len<>0
    var Vector2 v := f vector text:characters text:len-1 4 k
    x0 := min f:x0 v:x+f:x0 ; y0 := min f:y0 v:y+f:y0 ; x1 :
    var Vector2 v := f vector text:characters text:len 4 kerning
    x0 := 0 ; y0 := f y0 ; x1 := v x ; y1 := f y1 # FIXME
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0


function font_scan path
  arg Str path
  var Array:FileInfo files := file_list path extended+recurs
  for (var Int i) 0 files:size-1
    if files:i:extension=".pfb" and not files:i:is_link
  else
    x0 := 0 ; y0 := 0 ; x1 := 0 ; y1 := 0


function font_scan path
  arg Str path
  var Array:FileInfo files := file_list path extended+recurs
  for (var Int i) 0 files:size-1
    if files:i:extension=".pfb" and not files:i:is_link
      var Link:Font f :> font_postscript files:i:name
      var Link:Font f :> font_postscript files:i:name ""
      if exists:f
        font_database:data:font create f:md5
        var Data:FontFile ffile :> font_database:data:font f
        ffile family := f family
        ffile fullname := f fullname
        ffile psname := f psname
        ffile file := f file
        console f:fullname eol
        font_database:data:family create f:family
        (font_database:data:family f:family) create f:md5
        font_database:data:fullname create f:fullname
        font_database:data:fullname f:fullname := f md5
        font_database:data:psname create f:psname
        font_database:data:psname f:psname := f md5


function font name -> font
  arg Str name ; arg Link:Font font
  var Data:FontFile f :> font_database:data:font name # md5
  if not exists:f
    f :> font_database:data:font font_database:data:psname:n
  if not exists:f
    f :> font_database:data:font font_database:data:fullname
  if not exists:f
    f :> font_database:data:font font_database:data:alias:na
  if exists:f
    if (cache_open "/pliant/font/"+keyof:f Font ((addressof 
      if exists:f
        font_database:data:font create f:md5
        var Data:FontFile ffile :> font_database:data:font f
        ffile family := f family
        ffile fullname := f fullname
        ffile psname := f psname
        ffile file := f file
        console f:fullname eol
        font_database:data:family create f:family
        (font_database:data:family f:family) create f:md5
        font_database:data:fullname create f:fullname
        font_database:data:fullname f:fullname := f md5
        font_database:data:psname create f:psname
        font_database:data:psname f:psname := f md5


function font name -> font
  arg Str name ; arg Link:Font font
  var Data:FontFile f :> font_database:data:font name # md5
  if not exists:f
    f :> font_database:data:font font_database:data:psname:n
  if not exists:f
    f :> font_database:data:font font_database:data:fullname
  if not exists:f
    f :> font_database:data:font font_database:data:alias:na
  if exists:f
    if (cache_open "/pliant/font/"+keyof:f Font ((addressof 
      if (font load_postscript f:file)=success
      if (font load_postscript f:file "")=success
        cache_ready ((addressof Link:Font font) map Link:Cac
      else
        cache_cancel ((addressof Link:Font font) map Link:Ca
        font :> null map Font
  else
    font :> null map Font



        cache_ready ((addressof Link:Font font) map Link:Cac
      else
        cache_cancel ((addressof Link:Font font) map Link:Ca
        font :> null map Font
  else
    font :> null map Font