Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/vfilter/postscript.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/admin/file.pli"
module "/pliant/admin/execute.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/vfilter/prototype.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/curve/mode.pli"
module "/pliant/math/transform.pli"
module "/pliant/math/matrix.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/graphic/misc/bytes.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/language/stream/pipe.pli"



module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/admin/file.pli"
module "/pliant/admin/execute.pli"
module "/pliant/graphic/image/prototype.pli"
module "/pliant/graphic/vfilter/prototype.pli"
module "/pliant/graphic/draw/prototype.pli"
module "/pliant/graphic/vector/font.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/math/curve.pli"
module "/pliant/math/curve/mode.pli"
module "/pliant/math/transform.pli"
module "/pliant/math/matrix.pli"
module "/pliant/language/type/text/str32.pli"
module "/pliant/graphic/misc/bytes.pli"
module "/pliant/util/encoding/html.pli"
module "/pliant/language/stream/pipe.pli"



type DrawWriteFilterPsPending
  field Array:Curve curves
  field Int mode
  field Transform2 t
  field Int counter
  field ColorBuffer pending

type DrawWriteFilterPs
  field Pointer:Stream stream
  field ImagePrototype proto
  field Float ox oy
  field Link:ColorGamut gamut
  field Int dim transp
  field Array:Str temps
  field (Array Pointer:Stream) streams
  field Array:Stream real_streams

type DrawWriteFilterPs
  field Pointer:Stream stream
  field ImagePrototype proto
  field Float ox oy
  field Link:ColorGamut gamut
  field Int dim transp
  field Array:Str temps
  field (Array Pointer:Stream) streams
  field Array:Stream real_streams
  field Int counter <- 0
  field ExtendedStatus status
  field ExtendedStatus status
  field Array:Curve clip_curves
  field Int clip_mode
  field Transform2 clip_t
  field ColorBuffer clip_pending
  field CBool optimize
  field List:DrawWriteFilterPsPending pending_stack


method f open stream options proto -> status
  arg_rw DrawWriteFilterPs f ; arg_rw Stream stream ; arg St
  f stream :> stream
  f ox := proto x0
  f oy := proto y1
  f proto := proto
  f gamut :> proto gamut
  f dim := f:gamut dimension
  f transp := f:gamut transparency
  var Pointer:Stream s :> stream
  s writeline "%!PS"
  s writeline "%%Creator: Pliant "+string:pliant_release_num
  s writeline "%%HiResBoundingBox: 0 0 "+(ps_string (proto:x
  s writeline "%%PliantOrigin: "+(ps_string -(proto:x0)/25.4
  s writeline "%%PliantDrawModel: vector"
  s writeline "%%PliantColorModel: separated"
  s writeline "%%PliantColorGamut: "+proto:gamut:name
  s writeline "%%Pages: "+(string f:dim)
  s writeline "%%DocumentData: Binary"
  s writeline "%%BeginSetup"
  s writeline (ps_string (proto:x1-proto:x0)/25.4*72)+" "+(p
  s writeline "%%EndSetup"
  f:temps size := f dim
  f:real_streams size := f dim
  f:streams size := f dim
  for (var Int i) 0 f:dim-1
    if i=0
      f:streams i :> stream
    else
      f:temps i := file_temporary
      f:real_streams:i open f:temps:i out+safe
      f:streams i :> f:real_streams:i
    var Pointer:Stream s :> f:streams i
    s writeline "%%Page: "+(string i+1)+" "+(string i+1)
    s writeline "%%PlateColor: "+(proto:gamut query "compone
    s writeline "%%BeginDocument: "+(proto:gamut query "comp


method f open stream options proto -> status
  arg_rw DrawWriteFilterPs f ; arg_rw Stream stream ; arg St
  f stream :> stream
  f ox := proto x0
  f oy := proto y1
  f proto := proto
  f gamut :> proto gamut
  f dim := f:gamut dimension
  f transp := f:gamut transparency
  var Pointer:Stream s :> stream
  s writeline "%!PS"
  s writeline "%%Creator: Pliant "+string:pliant_release_num
  s writeline "%%HiResBoundingBox: 0 0 "+(ps_string (proto:x
  s writeline "%%PliantOrigin: "+(ps_string -(proto:x0)/25.4
  s writeline "%%PliantDrawModel: vector"
  s writeline "%%PliantColorModel: separated"
  s writeline "%%PliantColorGamut: "+proto:gamut:name
  s writeline "%%Pages: "+(string f:dim)
  s writeline "%%DocumentData: Binary"
  s writeline "%%BeginSetup"
  s writeline (ps_string (proto:x1-proto:x0)/25.4*72)+" "+(p
  s writeline "%%EndSetup"
  f:temps size := f dim
  f:real_streams size := f dim
  f:streams size := f dim
  for (var Int i) 0 f:dim-1
    if i=0
      f:streams i :> stream
    else
      f:temps i := file_temporary
      f:real_streams:i open f:temps:i out+safe
      f:streams i :> f:real_streams:i
    var Pointer:Stream s :> f:streams i
    s writeline "%%Page: "+(string i+1)+" "+(string i+1)
    s writeline "%%PlateColor: "+(proto:gamut query "compone
    s writeline "%%BeginDocument: "+(proto:gamut query "comp
  f optimize := not (options option "no_optimize")
  f status := success
  f status := success
  memory_clear (addressof f:clip_pending) f:dim
  status := success

method f close -> status
  arg_rw DrawWriteFilterPs f ; arg ExtendedStatus status
  status := success

method f close -> status
  arg_rw DrawWriteFilterPs f ; arg ExtendedStatus status
  var Pointer:Stream s :> f stream
  for (var Int i) 0 f:dim-1
    var Pointer:Stream s :> f:streams i
    s writeline "%%EndDocument"
    s writeline "showpage"
    if i>0
      s open f:temps:i in+safe+bigcache
      while not s:atend and f:stream=success
        raw_copy s f:stream 1 4*2^20
      s close
      file_delete f:temps:i
  f:stream writeline "%%EOF"
  status := f status



method f do_clip i
  arg_rw DrawWriteFilterPs f ; arg Int i
  for (var Int i) 0 f:dim-1
    var Pointer:Stream s :> f:streams i
    s writeline "%%EndDocument"
    s writeline "showpage"
    if i>0
      s open f:temps:i in+safe+bigcache
      while not s:atend and f:stream=success
        raw_copy s f:stream 1 4*2^20
      s close
      file_delete f:temps:i
  f:stream writeline "%%EOF"
  status := f status



method f do_clip i
  arg_rw DrawWriteFilterPs f ; arg Int i
  if f:clip_pending:bytes:i<>0
    memory_clear addressof:(var ColorBuffer color) f:dim+f:t
    color:bytes f:dim+i := 255
    f ps_curves f:clip_curves f:clip_t addressof:color
    f writeline (shunt f:clip_mode=fill_evenodd "eoclip" "cl
    f writeline "newpath" addressof:color
    f:clip_pending:bytes i := 0
  if f:optimize
    each p f:pending_stack
      if p:pending:bytes:i=1
        memory_clear addressof:(var ColorBuffer color) f:dim+f:transp
        color:bytes f:dim+i := 255
        f writeline "gsave" addressof:color
        f writeline "%id "+(string p:counter)+" clip" addressof:color
        f ps_curves p:curves p:t addressof:color
        f writeline (shunt p:mode=fill_evenodd "eoclip" "clip") addressof:color
        f writeline "newpath" addressof:color
        p:pending:bytes i := 2



method f image img t
  oarg_rw DrawWriteFilterPs f ; oarg_rw ImagePrototype img ;
method f image img t
  oarg_rw DrawWriteFilterPs f ; oarg_rw ImagePrototype img ;
  if img:gamut:transparency>0
    f status := failure "images with transparency channels are not supported"
  f counter += 1
  for (var Int i) 0 f:gamut:dimension-1
    for (var Int j) 0 img:gamut:dimension-1
      if (img:gamut query "component_name "+string:j)=(f:gam
        f do_clip i
        var Pointer:Stream s :> f:streams i
  for (var Int i) 0 f:gamut:dimension-1
    for (var Int j) 0 img:gamut:dimension-1
      if (img:gamut query "component_name "+string:j)=(f:gam
        f do_clip i
        var Pointer:Stream s :> f:streams i
        s writeline "%id "+(string f:counter)+" image"
        s writeline "/scanline "+(string img:size_x)+" strin
        var Transform2 tt
        s writeline "/scanline "+(string img:size_x)+" strin
        var Transform2 tt
        tt := compose t (transform -(f:ox) -(f:oy) 1 1 0 0) 
        tt := compose (compose (transform img:x0 img:y0 img:x1-img:x0 img:y1-img:y0 0 0) t) (compose (transform -(f:ox) -(f:oy) 1 1 0 0) (transform 0 0 72/25.4 -72/25.4 0 0))
        tt := compose reverse:tt (transform 0 0 img:size_x i
        var Matrix m := tt matrix
        tt := compose reverse:tt (transform 0 0 img:size_x i
        var Matrix m := tt matrix
        # s writeline "%origin "+(string f:ox)+" "+(string f:oy)
        # s writeline "%image "+(string img:x0)+" "+(string img:y0)+" "+(string img:x1)+" "+(string img:y1)+" "+(string img:size_x)+" "+(string img:size_y)
        # s writeline "%matrix "+(string t:xx)+" "+(string t:xy)+" "+(string t:xt)+" "+(string t:yx)+" "+(string t:yy)+" "+(string t:yt)
        s writeline (string img:size_x)+" "+(string img:size
        s writeline "%%BeginBinary: "+(string img:size_x*img
        s writeline "image"
        var Address src := memory_allocate img:line_size nul
        var Address dest := memory_allocate img:size_x null
        for (var Int y) 0 img:size_y-1
          img read 0 y img:size_x src
          bytes_copy_255minus (src translate Byte j) img:pix
          s raw_write dest img:size_x
        memory_free src
        memory_free dest
        s writeline "%%EndBinary"


method f fill curves mode t color
  oarg_rw DrawWriteFilterPs f ; arg Array:Curve curves ; arg
        s writeline (string img:size_x)+" "+(string img:size
        s writeline "%%BeginBinary: "+(string img:size_x*img
        s writeline "image"
        var Address src := memory_allocate img:line_size nul
        var Address dest := memory_allocate img:size_x null
        for (var Int y) 0 img:size_y-1
          img read 0 y img:size_x src
          bytes_copy_255minus (src translate Byte j) img:pix
          s raw_write dest img:size_x
        memory_free src
        memory_free dest
        s writeline "%%EndBinary"


method f fill curves mode t color
  oarg_rw DrawWriteFilterPs f ; arg Array:Curve curves ; arg
  f counter += 1
  for (var Int i) 0 f:dim-1
    if i>=f:transp or (color map uInt8 f:dim+i)<>0
      f do_clip i
      var Pointer:Stream s :> f:streams i
  for (var Int i) 0 f:dim-1
    if i>=f:transp or (color map uInt8 f:dim+i)<>0
      f do_clip i
      var Pointer:Stream s :> f:streams i
      s writeline "%id "+(string f:counter)+" fill"
      s writeline (string 1-(color map uInt8 i)/255)+" setgr
  f ps_curves curves t color
  f writeline (shunt mode=fill_evenodd "eofill" "fill") colo



method clip fill curves mode t color
  oarg_rw DrawClipFilterPs clip ; arg Array:Curve curves ; a
  var Pointer:DrawWriteFilterPs f :> clip f
  if (color map uInt8)<>255
    f status := failure "halftone clipping is not supported"
  if clip:done
    f status := failure "multi instructions clipping is not 
      s writeline (string 1-(color map uInt8 i)/255)+" setgr
  f ps_curves curves t color
  f writeline (shunt mode=fill_evenodd "eofill" "fill") colo



method clip fill curves mode t color
  oarg_rw DrawClipFilterPs clip ; arg Array:Curve curves ; a
  var Pointer:DrawWriteFilterPs f :> clip f
  if (color map uInt8)<>255
    f status := failure "halftone clipping is not supported"
  if clip:done
    f status := failure "multi instructions clipping is not 
  for (var Int i) 0 f:dim-1
    if f:clip_pending:bytes:i<>0
      # console "double clipping " i eol
      f do_clip i
  if f:dim>f:transp
  f counter += 1
  if f:optimize
    var Pointer:DrawWriteFilterPsPending p :> f:pending_stack last
    p curves := curves
    p mode := mode
    p t := t
    p counter := f counter
    for (var Int i) 0 f:dim-1
      p:pending:bytes i := 1
  else
    f writeline "%id "+(string f:counter)+" clip" null
    f ps_curves curves t null
    f writeline (shunt mode=fill_evenodd "eoclip" "clip") nu
    f writeline "newpath" null
    f ps_curves curves t null
    f writeline (shunt mode=fill_evenodd "eoclip" "clip") nu
    f writeline "newpath" null
  else
    f clip_curves := curves
    f clip_mode := mode
    f clip_t := t
    for (var Int i) 0 f:dim-1
      f:clip_pending:bytes i := 1
  clip done := true

method f clip_open x0 y0 x1 y1 -> dc
  oarg_rw DrawWriteFilterPs f ; arg Float x0 y0 x1 y1 ; arg 
  clip done := true

method f clip_open x0 y0 x1 y1 -> dc
  oarg_rw DrawWriteFilterPs f ; arg Float x0 y0 x1 y1 ; arg 
  f writeline "gsave" null
  if f:optimize
    var DrawWriteFilterPsPending p
    memory_clear (addressof p:pending) f:dim
    f pending_stack += p
  else
    f writeline "gsave" null
  var Link:DrawClipFilterPs clip :> new DrawClipFilterPs
  clip f :> f
  dc :> clip

method f clip_close
  oarg_rw DrawWriteFilterPs f
  var Link:DrawClipFilterPs clip :> new DrawClipFilterPs
  clip f :> f
  dc :> clip

method f clip_close
  oarg_rw DrawWriteFilterPs f
  for (var Int i) 0 f:dim-1
    if f:clip_pending:bytes:i=0
      f:streams:i writeline "grestore"
    else
      f:clip_pending:bytes i := 0
  if f:optimize
    var Pointer:DrawWriteFilterPsPending p :> f:pending_stack last
    for (var Int i) 0 f:dim-1
      if p:pending:bytes:i=2
        f:streams:i writeline "grestore"
    f:pending_stack remove p
  else
    f writeline "grestore" null


method f load stream options draw -> status
  oarg_rw DrawReadFilterPs f ; arg_rw Stream stream ; arg St
  var Str pdf_temp := file_temporary
  stream_pipe (var Str gs_in_pipe) (var Str gs_out_pipe)
  stream_pipe (var Str gmt_in_pipe) (var Str gmt_out_pipe)
  var Sem gs_sem
  gs_sem request
  thread
    part convert "convert PostScript to PDF"
      execute "gs -q -sDEVICE=pdfwrite -dCompressPages=false
    share:gs_sem release
  var Str gamutname
  var Sem gmt_sem
  gmt_sem request
  thread
    part discover "discover PostScript gamut"


method f load stream options draw -> status
  oarg_rw DrawReadFilterPs f ; arg_rw Stream stream ; arg St
  var Str pdf_temp := file_temporary
  stream_pipe (var Str gs_in_pipe) (var Str gs_out_pipe)
  stream_pipe (var Str gmt_in_pipe) (var Str gmt_out_pipe)
  var Sem gs_sem
  gs_sem request
  thread
    part convert "convert PostScript to PDF"
      execute "gs -q -sDEVICE=pdfwrite -dCompressPages=false
    share:gs_sem release
  var Str gamutname
  var Sem gmt_sem
  gmt_sem request
  thread
    part discover "discover PostScript gamut"
      share gamutname := "pantone:"
      share gamutname := (options option "color_device" Str "pantone")+":"
      var CBool newpage := false
      (var Stream ps) open gmt_in_pipe in+safe+anyeol
      while not ps:atend
        var Str l := ps readline ; ps recover
        if (l 0 1)="%"
          if (l parse "%%" "BeginBinary" ":" (var Int count)
            while count>0 and not ps:atend
              ps read_available (var Address adr) (var Int s
              count -= size
          eif (l parse "%%" "Page" ":" any)
            newpage := true
          eif (l parse "%%" "PlateColor" ":" any:(var Str co
            gamutname += (shunt (gamutname gamutname:len-1)<
            newpage := false
      var CBool newpage := false
      (var Stream ps) open gmt_in_pipe in+safe+anyeol
      while not ps:atend
        var Str l := ps readline ; ps recover
        if (l 0 1)="%"
          if (l parse "%%" "BeginBinary" ":" (var Int count)
            while count>0 and not ps:atend
              ps read_available (var Address adr) (var Int s
              count -= size
          eif (l parse "%%" "Page" ":" any)
            newpage := true
          eif (l parse "%%" "PlateColor" ":" any:(var Str co
            gamutname += (shunt (gamutname gamutname:len-1)<
            newpage := false
      if gamutname<>"pantone:"
      if gamutname<>(options option "color_device" Str "pantone")+":"
        gamutname += "+transparencies"
      else
        gamutname := ""
    share:gmt_sem release
  (var Stream gs_out) open gs_out_pipe out+safe
  (var Stream gmt_out) open gmt_out_pipe out+safe
  while not stream:atend and gs_out=success and gmt_out=succ
    stream read_available (var Address adr) (var Int size)
    gs_out raw_write adr size
    gmt_out raw_write adr size
  gs_out close ; gmt_out close
  gs_sem request ; gs_sem release
  gmt_sem request ; gmt_sem release
  var Link:Stream pdf_stream :> new Stream
  pdf_stream open pdf_temp in+safe
  var Link:DrawReadFilter pdf_filter :> draw_read_filter ".p
  status := pdf_filter load pdf_stream options+" share_fonts
  pdf_stream close
  file_delete pdf_temp


        gamutname += "+transparencies"
      else
        gamutname := ""
    share:gmt_sem release
  (var Stream gs_out) open gs_out_pipe out+safe
  (var Stream gmt_out) open gmt_out_pipe out+safe
  while not stream:atend and gs_out=success and gmt_out=succ
    stream read_available (var Address adr) (var Int size)
    gs_out raw_write adr size
    gmt_out raw_write adr size
  gs_out close ; gmt_out close
  gs_sem request ; gs_sem release
  gmt_sem request ; gmt_sem release
  var Link:Stream pdf_stream :> new Stream
  pdf_stream open pdf_temp in+safe
  var Link:DrawReadFilter pdf_filter :> draw_read_filter ".p
  status := pdf_filter load pdf_stream options+" share_fonts
  pdf_stream close
  file_delete pdf_temp