/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