Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/filter/pcl.pli
Key:
    Removed line
    Added line
   
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# Generic PCL driver
# tested on HP Designjet large format printers


# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# Generic PCL driver
# tested on HP Designjet large format printers


method s xl_uInt8 v
  arg_rw Stream s ; arg Array:uInt v
  var uInt8 b := 0C8h ; s raw_write addressof:b 1
  s xl_uInt16 (cast v:size uInt)
  for (var Int i) 0 v:size-1
    var uInt8 b := v i ; s raw_write addressof:b 1



method s xl_attr attr
  arg_rw Stream s ; arg Int attr
  var uInt8 b := 0F8h ; s raw_write addressof:b 1
  var uInt8 b := attr ; s raw_write addressof:b 1


constant xl_aPaletteDepth 2
method s xl_attr attr
  arg_rw Stream s ; arg Int attr
  var uInt8 b := 0F8h ; s raw_write addressof:b 1
  var uInt8 b := attr ; s raw_write addressof:b 1


constant xl_aPaletteDepth 2
constant xl_aPaletteData 6
constant xl_e1Bit 0
constant xl_e4Bit 1
constant xl_e8Bit 2

constant xl_aPoint 76
constant xl_e1Bit 0
constant xl_e4Bit 1
constant xl_e8Bit 2

constant xl_aPoint 76
constant xl_aROP3 44




constant xl_aTxMode 45
constant xl_eOpaque 0
constant xl_eTransparent 1

constant xl_aNullBrush 4
constant xl_aNullPen 5

constant xl_aColorDepth 98
constant xl_aSourceWidth 108
constant xl_aSourceHeight 107
constant xl_aDestinationSize 103
constant xl_aStartLine 109
constant xl_aBlocHeight 99

constant xl_aCompressMode 101
constant xl_eNoCompression 0
constant xl_aColorDepth 98
constant xl_aSourceWidth 108
constant xl_aSourceHeight 107
constant xl_aDestinationSize 103
constant xl_aStartLine 109
constant xl_aBlocHeight 99

constant xl_aCompressMode 101
constant xl_eNoCompression 0
constant xl_eRLECompression 1
constant xl_eDeltaRowCompression 3


constant xl_oBeginSession 41h
constant xl_oOpenDataSource 48h
constant xl_oBeginPage 43h
constant xl_oSetColorSpace 6Ah
constant xl_oSetCursor 6Bh
constant xl_eDeltaRowCompression 3


constant xl_oBeginSession 41h
constant xl_oOpenDataSource 48h
constant xl_oBeginPage 43h
constant xl_oSetColorSpace 6Ah
constant xl_oSetCursor 6Bh
constant xl_oSetROP 7Bh
constant xl_oSetBrushSource 63h
constant xl_oSetPenSource 79h
constant xl_oSetPatternTxMode 78h
constant xl_oSetSourceTxMode 7Ch
constant xl_oBeginImage B0h
constant xl_oReadImage B1h
constant xl_oBeginImage B0h
constant xl_oReadImage B1h

constant xl_oEndImage B2h
constant xl_oEndPage 44h
constant xl_oCloseDataSource 49h
constant xl_oEndSession 42h



type ImageWriteFilterPcl
  field Pointer:Stream stream
  field Int size_x line_size
  field Link:ColorGamut gamut
  field Int current_y
constant xl_oEndImage B2h
constant xl_oEndPage 44h
constant xl_oCloseDataSource 49h
constant xl_oEndSession 42h



type ImageWriteFilterPcl
  field Pointer:Stream stream
  field Int size_x line_size
  field Link:ColorGamut gamut
  field Int current_y
  field CBool hpgl
  field CBool pclxl
  field CBool pjl hpgl pclxl
  field Address negative <- null
  field Address plan <- null
  field Address bits <- null
  field Array:DitherMatrix dither
  field Address negative <- null
  field Address plan <- null
  field Address bits <- null
  field Array:DitherMatrix dither
  field Address padding <- null
  field CBool packbits <- false
  field CBool seedrow <- false
  field CBool always_compress <- false
  field Address previous_line <- null
  field Address compressed <- null


method f open s options h -> status
  arg_rw ImageWriteFilterPcl f ; arg_rw Stream s ; arg Str o
  f stream :> s
  f size_x := h size_x
  f line_size := h line_size
  f gamut :> h gamut
  field CBool packbits <- false
  field CBool seedrow <- false
  field CBool always_compress <- false
  field Address previous_line <- null
  field Address compressed <- null


method f open s options h -> status
  arg_rw ImageWriteFilterPcl f ; arg_rw Stream s ; arg Str o
  f stream :> s
  f size_x := h size_x
  f line_size := h line_size
  f gamut :> h gamut
  f pjl := not (options option "no_pjl")
  f hpgl := options option "hpgl"
  f pclxl := options option "pclxl"
  if not (options option "pcl_no_compression")
    if (options option "pcl_seedrow_compression")
      f seedrow := true
    eif (options option "pcl_packbits_compression")
      f packbits := true
  f hpgl := options option "hpgl"
  f pclxl := options option "pclxl"
  if not (options option "pcl_no_compression")
    if (options option "pcl_seedrow_compression")
      f seedrow := true
    eif (options option "pcl_packbits_compression")
      f packbits := true
    eif f:pclxl # seedraw is only part of PCL XL 2.1
      f packbits := true
    else
      f seedrow := true
  f always_compress := options option "pcl_always_compress"
  if f:packbits or f:seedrow
    f compressed := memory_allocate 2*f:line_size+4 addresso
  if f:seedrow
    f previous_line := memory_zallocate f:line_size addresso
    else
      f seedrow := true
  f always_compress := options option "pcl_always_compress"
  if f:packbits or f:seedrow
    f compressed := memory_allocate 2*f:line_size+4 addresso
  if f:seedrow
    f previous_line := memory_zallocate f:line_size addresso
  var Float dpi := h:size_x/(abs h:x1-h:x0)*25.4
  if f:pjl
    var Str pjl_eol := options option "pjl_eol" Str "[cr][lf]"
    var Str cmd := escape+"%-12345X"
    if not (options option "no_pjl_resolution")
      cmd += "@PJL SET RESOLUTION = "+string:dpi+pjl_eol
    cmd += options option "pjl_options" Str
    cmd += "@PJL ENTER LANGUAGE = "+(shunt f:hpgl "HPGL2" f:pclxl "PCLXL" "PCL")+pjl_eol
    s writechars cmd
  if f:pclxl
    check h:gamut:pixel_size=1 or h:gamut:pixel_size=3
    s writechars ") HP-PCL XL;1;1;Pliant "+string:pliant_rel
    s xl_uInt16 (cast h:size_x/(abs h:x1-h:x0)*25.4 uInt) (c
    s xl_uInt8 xl_eInch ; s xl_attr xl_aMeasure
    s xl_uInt8 xl_eBackChAndErrPage ; s xl_attr xl_aErrorRep
    s xl_op xl_oBeginSession
    s xl_uInt8 xl_eBinaryLowByteFirst ; s xl_attr xl_aDataOr
    s xl_uInt8 xl_eDefaultSource ; s xl_attr xl_aSourceType
    s xl_op xl_oOpenDataSource
    s xl_uInt8 xl_ePortraitOrientation ; s xl_attr xl_aOrien
    s xl_uInt8 (cast (options option "pcl_media_size" Int (s
    s xl_op xl_oBeginPage
    s xl_uInt8 (shunt h:gamut:dimension=1 xl_eGrey xl_eRGB) 
  if f:pclxl
    check h:gamut:pixel_size=1 or h:gamut:pixel_size=3
    s writechars ") HP-PCL XL;1;1;Pliant "+string:pliant_rel
    s xl_uInt16 (cast h:size_x/(abs h:x1-h:x0)*25.4 uInt) (c
    s xl_uInt8 xl_eInch ; s xl_attr xl_aMeasure
    s xl_uInt8 xl_eBackChAndErrPage ; s xl_attr xl_aErrorRep
    s xl_op xl_oBeginSession
    s xl_uInt8 xl_eBinaryLowByteFirst ; s xl_attr xl_aDataOr
    s xl_uInt8 xl_eDefaultSource ; s xl_attr xl_aSourceType
    s xl_op xl_oOpenDataSource
    s xl_uInt8 xl_ePortraitOrientation ; s xl_attr xl_aOrien
    s xl_uInt8 (cast (options option "pcl_media_size" Int (s
    s xl_op xl_oBeginPage
    s xl_uInt8 (shunt h:gamut:dimension=1 xl_eGrey xl_eRGB) 
    s xl_uInt8 xl_e8Bit ; s xl_attr xl_aPaletteDepth
    s xl_op xl_oSetColorSpace
    s xl_uInt16 0 0 ; s xl_attr xl_aPoint
    s xl_op xl_oSetCursor
    s xl_op xl_oSetColorSpace
    s xl_uInt16 0 0 ; s xl_attr xl_aPoint
    s xl_op xl_oSetCursor
    s xl_uInt8 204 ; s xl_attr xl_aROP3
    s xl_op xl_oSetROP
    s xl_uInt8 0 ; s xl_attr xl_aNullBrush
    s xl_op xl_oSetBrushSource
    s xl_uInt8 0 ; s xl_attr xl_aNullPen
    s xl_op xl_oSetPenSource
    s xl_uInt8 xl_eDirectPixel ; s xl_attr xl_aColorMapping
    s xl_uInt8 xl_e8Bit ; s xl_attr xl_aColorDepth
    s xl_uInt16 (cast h:size_x uInt) ; s xl_attr xl_aSourceW
    s xl_uInt16 (cast h:size_y uInt) ; s xl_attr xl_aSourceH
    s xl_uInt16 (cast h:size_x uInt) (cast h:size_y uInt) ; 
    s xl_op xl_oBeginImage
    s xl_uInt8 xl_eDirectPixel ; s xl_attr xl_aColorMapping
    s xl_uInt8 xl_e8Bit ; s xl_attr xl_aColorDepth
    s xl_uInt16 (cast h:size_x uInt) ; s xl_attr xl_aSourceW
    s xl_uInt16 (cast h:size_y uInt) ; s xl_attr xl_aSourceH
    s xl_uInt16 (cast h:size_x uInt) (cast h:size_y uInt) ; 
    s xl_op xl_oBeginImage
    if f:line_size%4<>0
      f padding := memory_zallocate (f:line_size+3 .and. -4) addressof:f
  else # pcl5
  else # pcl5
    var Float dpi := h:size_x/(abs h:x1-h:x0)*25.4
    s writechars escape+"E" # reset
    if f:hpgl
    s writechars escape+"E" # reset
    if f:hpgl
      s writechars escape+"%-12345X@PJL RESET[cr][lf]@PJL SE
      s writechars escape+"%1B" # enter HP GL/2 mode
      s writechars "BP3,1,5,1;" # do not store file on the d
      if (options option "hpgl_page")
        var Int nx := cast 1016.0*h:size_x/dpi+0.5 Int
        var Int ny := cast 1016.0*h:size_y/dpi+0.5 Int
        s writechars "PS"+string:ny+","+string:nx+";" # set 
      else
        s writechars "PS;" # no page clip
      s writechars escape+"%0A" # enter HP RTL mode
    if not (options option "pcl_no_paper_size")
      # A4 = 26 , A3 = 27 , A3+ = 16, custom = 101
      s writechars escape+"&l"+(options option "pcl_paper_si
    if (options option "pcl_no_perforation_skip")
      s writechars escape+"&l0L" # Turn off perforation skip
    s writechars escape+"&a1N" # No negative motion - allow 
    if (options option "pcl_dither")
      if h:gamut:dimension=1
        s writechars escape+"*r1U"
        if h:gamut:model=color_gamut_additive
          f negative := memory_allocate f:line_size addresso
      eif h:gamut:model=color_gamut_additive
        check h:gamut:pixel_size=3
        s writechars escape+"*r"+(string h:gamut:dimension)+
      else
        check h:gamut:pixel_size=3 or h:gamut:pixel_size=4
        s writechars escape+"*r"+(string -(h:gamut:dimension
      f plan := memory_allocate f:size_x addressof:f
      f bits := memory_allocate (f:size_x+7)\8 addressof:f
      f:dither size := h:gamut dimension
      for (var Int i) 0  h:gamut:dimension-1
        var Pointer:DitherMatrix dither :> f:dither i
        dither := dither_matrix i ""
        for (var Int y) 0 dither:size_y-1
          for (var Int x) 0 dither:size_x-1
            var Float d := (dither x y)/(dither:size_x*dithe
      s writechars escape+"%1B" # enter HP GL/2 mode
      s writechars "BP3,1,5,1;" # do not store file on the d
      if (options option "hpgl_page")
        var Int nx := cast 1016.0*h:size_x/dpi+0.5 Int
        var Int ny := cast 1016.0*h:size_y/dpi+0.5 Int
        s writechars "PS"+string:ny+","+string:nx+";" # set 
      else
        s writechars "PS;" # no page clip
      s writechars escape+"%0A" # enter HP RTL mode
    if not (options option "pcl_no_paper_size")
      # A4 = 26 , A3 = 27 , A3+ = 16, custom = 101
      s writechars escape+"&l"+(options option "pcl_paper_si
    if (options option "pcl_no_perforation_skip")
      s writechars escape+"&l0L" # Turn off perforation skip
    s writechars escape+"&a1N" # No negative motion - allow 
    if (options option "pcl_dither")
      if h:gamut:dimension=1
        s writechars escape+"*r1U"
        if h:gamut:model=color_gamut_additive
          f negative := memory_allocate f:line_size addresso
      eif h:gamut:model=color_gamut_additive
        check h:gamut:pixel_size=3
        s writechars escape+"*r"+(string h:gamut:dimension)+
      else
        check h:gamut:pixel_size=3 or h:gamut:pixel_size=4
        s writechars escape+"*r"+(string -(h:gamut:dimension
      f plan := memory_allocate f:size_x addressof:f
      f bits := memory_allocate (f:size_x+7)\8 addressof:f
      f:dither size := h:gamut dimension
      for (var Int i) 0  h:gamut:dimension-1
        var Pointer:DitherMatrix dither :> f:dither i
        dither := dither_matrix i ""
        for (var Int y) 0 dither:size_y-1
          for (var Int x) 0 dither:size_x-1
            var Float d := (dither x y)/(dither:size_x*dithe
            d := dot_unadjust d "header [dq]pcl_"+(h:gamut q
            d := dot_unadjust d "header [dq]pcl_"+(h:gamut query "component_name "+string:i)+"_[dq] header2 [dq]pcl_[dq] "+options
            dither x y := max (cast d*255 Int) 1
      if f:gamut:dimension>1 and f:seedrow
        f packbits := true
        f seedrow := false
    else
      if h:gamut:dimension=1
        s writechars escape+"*v6W"+character:0+character:1+c
        for (var Int i) 0 255
          for (var Int c) 0 2 
            s writechars escape+"*v"+string:(shunt h:gamut:m
          s writechars escape+"*v"+string:i+"I"
        s writechars escape+"&b1M"
      else # RGB
        check h:gamut:model=color_gamut_additive and h:gamut
        var Int color_model := shunt (options option "sRGB")
        s writechars escape+"*v6W"+character:color_model+cha
    s writechars escape+"*t"+string:(cast dpi Int)+"R" # set
    s writechars escape+"*r"+(string h:size_x)+"S" # number 
    s writechars escape+"*r"+(string h:size_y)+"T" # number 
    s writechars escape+"*r1A" # start raster graphics at cu
    if f:always_compress
      s writechars escape+"*b"+(shunt f:seedrow "3" f:packbi
  f current_y := 0
  status := success


method f writeline adr -> status
  arg_rw ImageWriteFilterPcl f ; arg Address adr ; arg Statu
  var Pointer:Stream s :> f stream
  var Address line := adr ; var Int size := f line_size
  if f:negative<>null
    bytes_copy_255minus line 1 f:negative 1 f:line_size
    line := f negative
  for (var Int i) 0 (shunt f:plan<>null f:gamut:dimension-1 
    var Address memo_line := line ; var Int memo_size := siz
    if f:plan<>null
      bytes_copy (line translate Byte (i+(shunt f:gamut:dime
      line := f plan ; size := f size_x
    if f:bits<>null
      memory_clear f:bits (size+7)\8
      var Address src := line
      var Address stop := line translate uInt8 size
      var Address dest := f bits ; var Int shift := 7
      var Address dither := addressof (f:dither:i 0 f:curren
      while src<>stop
        if (src map uInt8)>=(dither map Int dx)
          dest map uInt8 += 2^shift
        src := src translate uInt8
        dx += 1
        if dx=dm
          dx := 0
        if shift>0
          shift -= 1
        else
          dest := dest translate uInt8 1 ; shift := 7
      line := f bits ; size := (size+7)\8
            dither x y := max (cast d*255 Int) 1
      if f:gamut:dimension>1 and f:seedrow
        f packbits := true
        f seedrow := false
    else
      if h:gamut:dimension=1
        s writechars escape+"*v6W"+character:0+character:1+c
        for (var Int i) 0 255
          for (var Int c) 0 2 
            s writechars escape+"*v"+string:(shunt h:gamut:m
          s writechars escape+"*v"+string:i+"I"
        s writechars escape+"&b1M"
      else # RGB
        check h:gamut:model=color_gamut_additive and h:gamut
        var Int color_model := shunt (options option "sRGB")
        s writechars escape+"*v6W"+character:color_model+cha
    s writechars escape+"*t"+string:(cast dpi Int)+"R" # set
    s writechars escape+"*r"+(string h:size_x)+"S" # number 
    s writechars escape+"*r"+(string h:size_y)+"T" # number 
    s writechars escape+"*r1A" # start raster graphics at cu
    if f:always_compress
      s writechars escape+"*b"+(shunt f:seedrow "3" f:packbi
  f current_y := 0
  status := success


method f writeline adr -> status
  arg_rw ImageWriteFilterPcl f ; arg Address adr ; arg Statu
  var Pointer:Stream s :> f stream
  var Address line := adr ; var Int size := f line_size
  if f:negative<>null
    bytes_copy_255minus line 1 f:negative 1 f:line_size
    line := f negative
  for (var Int i) 0 (shunt f:plan<>null f:gamut:dimension-1 
    var Address memo_line := line ; var Int memo_size := siz
    if f:plan<>null
      bytes_copy (line translate Byte (i+(shunt f:gamut:dime
      line := f plan ; size := f size_x
    if f:bits<>null
      memory_clear f:bits (size+7)\8
      var Address src := line
      var Address stop := line translate uInt8 size
      var Address dest := f bits ; var Int shift := 7
      var Address dither := addressof (f:dither:i 0 f:curren
      while src<>stop
        if (src map uInt8)>=(dither map Int dx)
          dest map uInt8 += 2^shift
        src := src translate uInt8
        dx += 1
        if dx=dm
          dx := 0
        if shift>0
          shift -= 1
        else
          dest := dest translate uInt8 1 ; shift := 7
      line := f bits ; size := (size+7)\8
    if f:padding<>null
      memory_copy line f:padding size
      line := f padding
      size := size+3 .and. -4
    var Int cmode := 0
    if f:seedrow
      var Int csize := seedrow_encode line f:compressed size
      memory_copy line f:previous_line size
      if csize<size or f:always_compress
        line := f compressed ; size := csize
        cmode := 3
    eif f:packbits
      var Int csize := packbits_encode line f:compressed siz
      if csize<size or f:always_compress
        line := f compressed ; size := csize
        cmode := 2
    if f:pclxl
      s xl_uInt16 (cast f:current_y uInt) ; s xl_attr xl_aSt
      s xl_uInt16 1 ; s xl_attr xl_aBlocHeight
    var Int cmode := 0
    if f:seedrow
      var Int csize := seedrow_encode line f:compressed size
      memory_copy line f:previous_line size
      if csize<size or f:always_compress
        line := f compressed ; size := csize
        cmode := 3
    eif f:packbits
      var Int csize := packbits_encode line f:compressed siz
      if csize<size or f:always_compress
        line := f compressed ; size := csize
        cmode := 2
    if f:pclxl
      s xl_uInt16 (cast f:current_y uInt) ; s xl_attr xl_aSt
      s xl_uInt16 1 ; s xl_attr xl_aBlocHeight
      s xl_uInt8 (shunt cmode=3 xl_eDeltaRowCompression xl_e
      s xl_uInt8 1 ; s xl_attr xl_aPadBytesMultiple
      s xl_uInt8 (shunt cmode=3 xl_eDeltaRowCompression cmode=2 xl_eRLECompression xl_eNoCompression) ; s xl_attr xl_aCompressMode
      # s xl_uInt8 1 ; s xl_attr xl_aPadBytesMultiple
      s xl_op xl_oReadImage
      s xl_length size
      s raw_write line size
    else
      s writechars escape+"*b"+string:cmode+"m"+string:size+
      s raw_write line size
    line := memo_line ; size := memo_size
  f current_y += 1
  status := success


method f close -> status
  arg_rw ImageWriteFilterPcl f ; arg ExtendedStatus status
  memory_free f:negative
  memory_free f:plan
  memory_free f:bits
      s xl_op xl_oReadImage
      s xl_length size
      s raw_write line size
    else
      s writechars escape+"*b"+string:cmode+"m"+string:size+
      s raw_write line size
    line := memo_line ; size := memo_size
  f current_y += 1
  status := success


method f close -> status
  arg_rw ImageWriteFilterPcl f ; arg ExtendedStatus status
  memory_free f:negative
  memory_free f:plan
  memory_free f:bits
  memory_free f:padding
  memory_free f:compressed
  memory_free f:previous_line
  var Pointer:Stream s :> f stream
  if f:pclxl
    s xl_op xl_oEndImage
    s xl_op xl_oEndPage
    s xl_op xl_oCloseDataSource
    s xl_op xl_oEndSession
  else # pcl5
    s writechars escape+"*rC" # end raster graphics
    if f:hpgl
      s writechars escape+"%1B" # back to HP GL/2
      s writechars "PG;" # end of job: eject page or advance
    s writechars escape+"E" # reset
  memory_free f:compressed
  memory_free f:previous_line
  var Pointer:Stream s :> f stream
  if f:pclxl
    s xl_op xl_oEndImage
    s xl_op xl_oEndPage
    s xl_op xl_oCloseDataSource
    s xl_op xl_oEndSession
  else # pcl5
    s writechars escape+"*rC" # end raster graphics
    if f:hpgl
      s writechars escape+"%1B" # back to HP GL/2
      s writechars "PG;" # end of job: eject page or advance
    s writechars escape+"E" # reset
  if f:pjl
    s writechars escape+"%-12345X"
  status := success


image_record_filters ".pcl" Void false ImageWriteFilterPcl f
  status := success


image_record_filters ".pcl" Void false ImageWriteFilterPcl f