/pliant/graphic/filter/tiff.pli
 
 1  module "/pliant/graphic/filter/prototype.pli" 
 2  module "/pliant/graphic/color/gamut.pli" 
 3  module "/pliant/language/unsafe.pli" 
 4  module "/pliant/language/stream.pli" 
 5  module "/pliant/admin/file.pli" 
 6   
 7  constant libtiff "libtiff.so.4" 
 8   
 9  public 
 10   
 11    function TIFFOpen name mode -> handle 
 12      arg CStr name mode ; arg Address handle 
 13      external libtiff "TIFFOpen" 
 14     
 15    function TIFFVGetField handle tag param 
 16      arg Address handle ; arg Int tag ; arg Address param 
 17      external libtiff "TIFFGetField" 
 18     
 19    function TIFFGetField handle tag value 
 20      arg Address handle ; arg Int tag ; arg_w Int value 
 21      value := 0 
 22      TIFFVGetField handle tag addressof:value 
 23     
 24    function TIFFVSetField handle tag param 
 25      arg Address handle ; arg Int tag ; arg Address param 
 26      external libtiff "TIFFVSetField" 
 27     
 28    function TIFFSetField handle tag value 
 29      arg Address handle ; arg Int tag ; arg Int value 
 30      TIFFVSetField handle tag addressof:value 
 31     
 32    function TIFFScanlineSize handle -> size 
 33      arg Address handle ; arg Int size 
 34      external libtiff "TIFFScanlineSize" 
 35     
 36    function TIFFReadScanline handle buf row plan -> err 
 37      arg Address handle ; arg Address buf ; arg Int row plan ; arg Int err 
 38      external libtiff "TIFFReadScanline" 
 39      # err=1 means ok, err=(-1) means error 
 40   
 41    function TIFFWriteScanline handle buf row plan -> err 
 42      arg Address handle ; arg Address buf ; arg Int row plan ; arg Int err 
 43      external libtiff "TIFFWriteScanline" 
 44      # err=1 means ok, err=(-1) means error 
 45   
 46    function TIFFClose handle 
 47      arg Address handle 
 48      external libtiff "TIFFClose" 
 49   
 50   
 51 
 
 52   
 53   
 54  method s write16 v 
 55    arg_rw Stream s ; arg Int v 
 56    var uInt16_li v16 := v ; s raw_write addressof:v16 uInt16_li:size 
 57   
 58  method s write32 v 
 59    arg_rw Stream s ; arg Int v 
 60    var uInt32_li v32 := v ; s raw_write addressof:v32 uInt32_li:size 
 61   
 62  method s tiff_field tag type_ count value 
 63    arg_rw Stream s ; arg Int tag type_ count ; arg Int value 
 64    s write16 tag 
 65    s write16 type_ 
 66    s write32 count 
 67    s write32 value 
 68   
 69  function write_tiff_header options s 
 70    arg Str options ; arg_rw Stream s 
 71    constant nb 8 
 72    s write16 4949h # low_indian 
 73    s write16 2Ah 
 74    s write32 8 
 75    s write16 nb # nb fields 
 76    var Int offset := 8+2+nb*12+4 
 77    # console "initial offset is " offset eol 
 78    var CBool rgb := (options option "line_size" Int)=3*(options option "size_x" Int) 
 79    s tiff_field 256 4 1 (options option "size_x" Int 1) 
 80    s tiff_field 257 4 1 (options option "size_y" Int 1) 
 81    if rgb 
 82      s tiff_field 258 3 3 offset ; offset += 3*uInt16:size 
 83    else 
 84      s tiff_field 258 3 1 (options option "bpc" Int) 
 85    s tiff_field 259 3 1 (options option "compression" Int 1) # compression 
 86    s tiff_field 262 3 1 (shunt rgb 2 1) # color model 
 87    s tiff_field 273 4 1 offset # bitmap offset  
 88    s tiff_field 277 3 1 (shunt rgb 3 1) # nb components 
 89    s tiff_field 279 4 1 (options option "size" Int) # bitmap length 
 90    s write32 0 
 91    # console "final offset is " (s query "seek") eol 
 92    if rgb 
 93      s write16 8 ; s write16 8 ; s write16 8 
 94     
 95   
 96 
 
 97   
 98   
 99  type ImageReadFilterLibtiff 
 100    field Str temp 
 101    field Address handle 
 102    field Int current_y 
 103   
 104  ImageReadFilter maybe ImageReadFilterLibtiff 
 105   
 106  method f open stream options h -> status 
 107    oarg_rw ImageReadFilterLibtiff f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status 
 108    f temp := file_temporary 
 109    (var Stream tmp) open f:temp out+safe 
 110    if (options option "write_tiff_header") 
 111      write_tiff_header options tmp 
 112    while (raw_copy stream tmp 1 2^24)<>0 
 113      void 
 114    tmp close 
 115    f handle := TIFFOpen (file_os_name f:temp) "rb" 
 116    if f:handle=null 
 117      file_delete f:temp 
 118      return failure:"not a TIFF image" 
 119    TIFFGetField f:handle 256 (var Int i) ; h size_x := i 
 120    TIFFGetField f:handle 257 (var Int i) ; h size_y := i 
 121    TIFFGetField f:handle 258 (var Int bpc) 
 122    TIFFGetField f:handle 262 (var Int mode) 
 123    TIFFGetField f:handle 277 (var Int dim) 
 124    var Int i := 2 ; TIFFGetField f:handle 296 (var Int i) 
 125    var Float unit := shunt i=3 10 25.4 
 126    TIFFVGetField f:handle 282 addressof:(var Float32 rx) 
 127    h x0 := 0 ; h x1 := h:size_x/rx*unit 
 128    TIFFVGetField f:handle 283 addressof:(var Float32 ry) 
 129    h y0 := 0 ; h y1 := h:size_y/ry*unit 
 130    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" "") 
 131    if h:gamut=failure 
 132      TIFFClose f:handle 
 133      file_delete f:temp 
 134      return (failure "unsupported gamut "+h:gamut:name) 
 135    if h:gamut:pixel_size<>dim or bpc<>8 
 136      TIFFClose f:handle 
 137      file_delete f:temp 
 138      return (failure "unsupported color depth "+string:dim+"x"+string:bpc) 
 139    h complete 
 140    if h:line_size<>(TIFFScanlineSize f:handle) 
 141      TIFFClose f:handle 
 142      file_delete f:temp 
 143      return (failure "inconsistent line size (computed "+(string h:line_size)+" real "+string:(TIFFScanlineSize f:handle)+")") 
 144    f current_y := 0 
 145    status := success 
 146   
 147  method f readline adr -> status 
 148    oarg_rw ImageReadFilterLibtiff f ; arg Address adr ; arg Status status 
 149    TIFFReadScanline f:handle adr f:current_y 0 
 150    f current_y += 1 
 151    status := success 
 152   
 153  method f close -> status 
 154    oarg_rw ImageReadFilterLibtiff f ; arg ExtendedStatus status 
 155    TIFFClose f:handle 
 156    file_delete f:temp 
 157    status := success 
 158   
 159   
 160  type ImageWriteFilterLibtiff 
 161    field Pointer:Stream stream 
 162    field Str temp 
 163    field Address handle 
 164    field Int current_y 
 165   
 166  ImageWriteFilter maybe ImageWriteFilterLibtiff 
 167   
 168  method f open stream options h -> status 
 169    oarg_rw ImageWriteFilterLibtiff f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status 
 170    f:stream :> stream 
 171    f temp := file_temporary 
 172    f handle := TIFFOpen (file_os_name f:temp) "wb" 
 173    if f:handle=null 
 174      file_delete f:temp 
 175      return failure:"failed to create TIFF image" 
 176    TIFFSetField f:handle 256 h:size_x 
 177    TIFFSetField f:handle 257 h:size_y 
 178    TIFFSetField f:handle 258 8 
 179    TIFFSetField f:handle 259 (shunt (options option "zlib") 8 (options option "lzw") 5 (options option "packbits") 32773 1) 
 180    TIFFSetField f:handle 262 (shunt h:gamut:name="grey" 1 h:gamut:name="rgb" 2 5) 
 181    TIFFSetField f:handle 277 h:pixel_size 
 182    var Float r := h:size_x/(h:x1-h:x0)*25.4 ; TIFFVSetField f:handle 282 addressof:r 
 183    var Float r := h:size_y/(h:y1-h:y0)*25.4 ; TIFFVSetField f:handle 283 addressof:r 
 184    TIFFSetField f:handle 284 1 
 185    TIFFSetField f:handle 296 2 
 186    f current_y := 0 
 187    status := success 
 188   
 189  method f writeline adr -> status 
 190    oarg_rw ImageWriteFilterLibtiff f ; arg Address adr ; arg Status status 
 191    TIFFWriteScanline f:handle adr f:current_y 0 
 192    f current_y += 1 
 193    status := success 
 194   
 195  method f close -> status 
 196    oarg_rw ImageWriteFilterLibtiff f ; arg ExtendedStatus status 
 197    TIFFClose f:handle 
 198    (var Stream tmp) open f:temp in+safe 
 199    while (raw_copy tmp f:stream 1 2^24)<>0 
 200      void 
 201    tmp close 
 202    file_delete f:temp 
 203    status := success 
 204   
 205  image_record_filters ".libtiff" ImageReadFilterLibtiff false ImageWriteFilterLibtiff false 
 206   
 207   
 208   
 209