Patch title: Release 96 bulk changes
Abstract:
File: /pliant/graphic/filter/tiff.pli
Key:
    Removed line
    Added line
module "/pliant/graphic/filter/prototype.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/language/unsafe.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/file.pli"

constant tifflib "libtiff.so.4"
constant libtiff "libtiff.so.4"

public

  function TIFFOpen name mode -> handle
    arg CStr name mode ; arg Address handle
    external tifflib "TIFFOpen"
    external libtiff "TIFFOpen"
  
  function TIFFVGetField handle tag param
    arg Address handle ; arg Int tag ; arg Address param
    external libtiff "TIFFGetField"
  
  function TIFFGetField handle tag value
    arg Address handle ; arg Int tag ; arg_w Int value
    external tifflib "TIFFGetField"
    value := 0
    TIFFVGetField handle tag addressof:value
  
  function TIFFVSetField handle tag param
    arg Address handle ; arg Int tag ; arg Address param
    external libtiff "TIFFVSetField"
  
  function TIFFSetField handle tag value
    arg Address handle ; arg Int tag ; arg Int value
    TIFFVSetField handle tag addressof:value
  
  function TIFFScanlineSize handle -> size
    arg Address handle ; arg Int size
    external tifflib "TIFFScanlineSize"
    external libtiff "TIFFScanlineSize"
  
  function TIFFReadScanline handle buf row plan -> err
    arg Address handle ; arg Address buf ; arg Int row plan ; arg Int err
    external tifflib "TIFFReadScanline"
    external libtiff "TIFFReadScanline"
    # err=1 means ok, err=(-1) means error

  function TIFFWriteScanline handle buf row plan -> err
    arg Address handle ; arg Address buf ; arg Int row plan ; arg Int err
    external libtiff "TIFFWriteScanline"
    # err=1 means ok, err=(-1) means error

  function TIFFClose handle
    arg Address handle
    external tifflib "TIFFClose"
    external libtiff "TIFFClose"


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


method s write16 v
  arg_rw Stream s ; arg Int v
  var uInt16_li v16 := v ; s raw_write addressof:v16 uInt16_li:size

method s write32 v
  arg_rw Stream s ; arg Int v
  var uInt32_li v32 := v ; s raw_write addressof:v32 uInt32_li:size

method s tiff_field tag type_ count value
  arg_rw Stream s ; arg Int tag type_ count ; arg Int value
  s write16 tag
  s write16 type_
  s write32 count
  s write32 value

function write_tiff_header options s
  arg Str options ; arg_rw Stream s
  constant nb 8
  s write16 4949h # low_indian
  s write16 2Ah
  s write32 8
  s write16 nb # nb fields
  var Int offset := 8+2+nb*12+4
  # console "initial offset is " offset eol
  var CBool rgb := (options option "line_size" Int)=3*(options option "size_x" Int)
  s tiff_field 256 4 1 (options option "size_x" Int 1)
  s tiff_field 257 4 1 (options option "size_y" Int 1)
  if rgb
    s tiff_field 258 3 3 offset ; offset += 3*uInt16:size
  else
    s tiff_field 258 3 1 (options option "bpc" Int)
  s tiff_field 259 3 1 (options option "compression" Int 1) # compression
  s tiff_field 262 3 1 (shunt rgb 2 1) # color model
  s tiff_field 273 4 1 offset # bitmap offset 
  s tiff_field 277 3 1 (shunt rgb 3 1) # nb components
  s tiff_field 279 4 1 (options option "size" Int) # bitmap length
  s write32 0
  # console "final offset is " (s query "seek") eol
  if rgb
    s write16 8 ; s write16 8 ; s write16 8
  
export write_tiff_header


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


type ImageReadFilterTiff
type ImageReadFilterLibtiff
  field Str temp
  field Address handle
  field Int current_y

ImageReadFilter maybe ImageReadFilterTiff
ImageReadFilter maybe ImageReadFilterLibtiff


method f open stream options h -> status
  arg_rw ImageReadFilterTiff f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status
  oarg_rw ImageReadFilterLibtiff f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status
  f temp := file_temporary
  (var Stream tmp) open f:temp out+safe
  if (options option "write_tiff_header")
    write_tiff_header options tmp
  while (raw_copy stream tmp 1 2^24)<>0
    void
  tmp close
  f handle := TIFFOpen (file_os_name f:temp) "rb"
  if f:handle=null
    file_delete f:temp
    return failure:"not a TIFF image"
  TIFFGetField f:handle 256 (var Int i) ; h size_x := i
  TIFFGetField f:handle 257 (var Int i) ; h size_y := i
  TIFFGetField f:handle 258 (var Int bpp)
  TIFFGetField f:handle 258 (var Int bpc)
  TIFFGetField f:handle 262 (var Int mode)
  TIFFGetField f:handle 277 (var Int dim)
  var Int i := 2 ; TIFFGetField f:handle 296 (var Int i)
  var Float unit := shunt i=3 10 25.4
  TIFFVGetField f:handle 282 addressof:(var Float32 rx)
  h x0 := 0 ; h x1 := h:size_x/rx*unit
  TIFFVGetField f:handle 283 addressof:(var Float32 ry)
  h y0 := 0 ; h y1 := h:size_y/ry*unit
  h gamut :> color_gamut (shunt (options option "gamut" Str)<>"" (options option "gamut" Str) mode=0 "pantone:process_black" mode=1 "grey" mode=2 "rgb" mode=5 "pantone:process_cyan+process_magenta+process_yellow+process_black" "")
  if h:gamut=failure
    TIFFClose f:handle
    file_delete f:temp
    return (failure "unsupported gamut "+h:gamut:name)
  if h:gamut:pixel_size<>dim or bpc<>8
    TIFFClose f:handle
    file_delete f:temp
    return (failure "unsupported color depth "+string:dim+"x"+string:bpc)
  h complete
  if h:line_size<>(TIFFScanlineSize f:handle)
    TIFFClose f:handle
    file_delete f:temp
    return (failure "inconsistent line size (computed "+(string h:line_size)+" real "+string:(TIFFScanlineSize f:handle)+")")
  f current_y := 0
  status := success

method f readline adr -> status
  arg_rw ImageReadFilterTiff f ; arg Address adr ; arg Status status
  oarg_rw ImageReadFilterLibtiff f ; arg Address adr ; arg Status status
  TIFFReadScanline f:handle adr f:current_y 0
  f current_y += 1
  status := success

method f close -> status
  arg_rw ImageReadFilterTiff f ; arg ExtendedStatus status
  oarg_rw ImageReadFilterLibtiff f ; arg ExtendedStatus status
  TIFFClose f:handle
  file_delete f:temp
  status := success


image_record_filters ".tiff" ImageReadFilterTiff true Void false
type ImageWriteFilterLibtiff
  field Pointer:Stream stream
  field Str temp
  field Address handle
  field Int current_y

ImageWriteFilter maybe ImageWriteFilterLibtiff

method f open stream options h -> status
  oarg_rw ImageWriteFilterLibtiff f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status
  f:stream :> stream
  f temp := file_temporary
  f handle := TIFFOpen (file_os_name f:temp) "wb"
  if f:handle=null
    file_delete f:temp
    return failure:"failed to create TIFF image"
  TIFFSetField f:handle 256 h:size_x
  TIFFSetField f:handle 257 h:size_y
  TIFFSetField f:handle 258 8
  TIFFSetField f:handle 259 (shunt (options option "zlib") 8 (options option "lzw") 5 (options option "packbits") 32773 1)
  TIFFSetField f:handle 262 (shunt h:gamut:name="grey" 1 h:gamut:name="rgb" 2 5)
  TIFFSetField f:handle 277 h:pixel_size
  var Float r := h:size_x/(h:x1-h:x0)*25.4 ; TIFFVSetField f:handle 282 addressof:r
  var Float r := h:size_y/(h:y1-h:y0)*25.4 ; TIFFVSetField f:handle 283 addressof:r
  TIFFSetField f:handle 284 1
  TIFFSetField f:handle 296 2
  f current_y := 0
  status := success

method f writeline adr -> status
  oarg_rw ImageWriteFilterLibtiff f ; arg Address adr ; arg Status status
  TIFFWriteScanline f:handle adr f:current_y 0
  f current_y += 1
  status := success

method f close -> status
  oarg_rw ImageWriteFilterLibtiff f ; arg ExtendedStatus status
  TIFFClose f:handle
  (var Stream tmp) open f:temp in+safe
  while (raw_copy tmp f:stream 1 2^24)<>0
    void
  tmp close
  file_delete f:temp
  status := success

image_record_filters ".libtiff" ImageReadFilterLibtiff false ImageWriteFilterLibtiff false