/pliant/graphic/filter/jpeg.pli
1	abstract
2	[The well known JPEG file format interface.] ; eol
3	[We link to JPEG standard library rather than porting it to Pliant because ]
4	[JPEG encoding is far from beeing trivial.]
5
6	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
7	#
8	# This program is free software; you can redistribute it and/or
9	# modify it under the terms of the GNU General Public License version 2
10	# as published by the Free Software Foundation.
11	#
12	# This program is distributed in the hope that it will be useful,
13	# but WITHOUT ANY WARRANTY; without even the implied warranty of
14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15	# GNU General Public License for more details.
16	#
17	# You should have received a copy of the GNU General Public License
18	# version 2 along with this program; if not, write to the Free Software
19	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20
21
22	module "/pliant/language/compiler.pli"
23	module "/pliant/language/context.pli"
24	module "/pliant/language/stream.pli"
25	module "prototype.pli"
26	module "/pliant/graphic/color/gamut.pli"
27
28	constant read_resolution true
29	constant write_resolution true
30
31
32
33
34
35	if os_api<>"win32"
36	constant jpeglib "libjpeg.so"
37	else
38	constant jpeglib pliant_root_path+"binary\libjpeg.dll"
39
40	type jpeg_error_mgr
41	field Address error_exit
42	field Address emit_message
43	field (Array Byte 132-8) unused1
44
45	type my_destination_mgr
46	field Address next_output_byte
47	field Int free_in_buffer
48	field Address init_destination
49	field Address empty_output_buffer
50	field Address term_destination
51	field Pointer:Stream stream
52
53	type jpeg_compress_struct
54	field Pointer:jpeg_error_mgr err
55	field (Array Byte 20) unused1
56	field Pointer:my_destination_mgr dest
57	field Int image_width
58	field Int image_height
59	field Int input_components
60	field Int in_color_space
61	field (Array Byte 372-44) unused2
62
63
64	type my_source_mgr
65	field Address next_input_byte
66	field Int bytes_in_buffer
67	field Address init_source
68	field Address fill_input_buffer
69	field Address skip_input_data
70	field Address resync_to_restart
71	field Address term_source
72	field Pointer:Stream stream
73
74	type jpeg_decompress_struct
75	field Pointer:jpeg_error_mgr err
76	field (Array Byte 20) unused1
77	field Pointer:my_source_mgr src
78	field Int image_width
79	field Int image_height
80	field Int num_components
81	field Int jpeg_color_space
82	field (Array Byte 464-44) unused2
83
84
85	constant JCS_GRAYSCALE 1
86	constant JCS_RGB 2
87	constant JPEG_LIB_VERSION 62
88	constant OUTPUT_BUF_SIZE 4096
89	constant JPEG_COM 0FEh
90
91	function jpeg_std_error jerr -> same
92	arg_rw jpeg_error_mgr jerr ; arg_RW jpeg_error_mgr same
93	external jpeglib "jpeg_std_error"
94
95	function jpeg_CreateCompress cinfo version size
96	arg_rw jpeg_compress_struct cinfo ; arg Int version size
97	external jpeglib "jpeg_CreateCompress"
98
99	function jpeg_create_compress cinfo
100	arg_rw jpeg_compress_struct cinfo
101	jpeg_CreateCompress cinfo JPEG_LIB_VERSION jpeg_compress_struct:size
102
103	function jpeg_set_defaults cinfo
104	arg_rw jpeg_compress_struct cinfo
105	external jpeglib "jpeg_set_defaults"
106
107	function jpeg_set_quality cinfo quality force_baseline
108	arg_rw jpeg_compress_struct cinfo ; arg Int quality ; arg CBool force_baseline
109	external jpeglib "jpeg_set_quality"
110
111	function jpeg_start_compress cinfo wat
112	arg_rw jpeg_compress_struct cinfo ; arg CBool wat
113	external jpeglib "jpeg_start_compress"
114
115	function jpeg_write_scanlines cinfo ptrs maxi -> count
116	arg_rw jpeg_compress_struct cinfo ; arg Pointer:Address ptrs ; arg Int maxi count
117	external jpeglib "jpeg_write_scanlines"
118
119	function jpeg_finish_compress cinfo
120	arg_rw jpeg_compress_struct cinfo
121	external jpeglib "jpeg_finish_compress"
122
123	function jpeg_abort_compress cinfo
124	arg_rw jpeg_compress_struct cinfo
125	external jpeglib "jpeg_abort_compress"
126
127	function jpeg_destroy_compress cinfo
128	arg_rw jpeg_compress_struct cinfo
129	external jpeglib "jpeg_destroy_compress"
130
131	function jpeg_write_marker cinfo marker adr len
132	arg_rw jpeg_compress_struct cinfo ; arg Int marker ; arg Address adr ; arg Int len
133	external jpeglib "jpeg_write_marker"
134
135
136
137	function jpeg_CreateDecompress cinfo version size
138	arg_rw jpeg_decompress_struct cinfo ; arg Int version size
139	external jpeglib "jpeg_CreateDecompress"
140
141	function jpeg_create_decompress cinfo
142	arg_rw jpeg_decompress_struct cinfo
143	jpeg_CreateDecompress cinfo JPEG_LIB_VERSION jpeg_decompress_struct:size
144
145	function jpeg_read_header cinfo require_image -> status
146	arg_rw jpeg_decompress_struct cinfo ; arg CBool require_image ; arg Int status
147	external jpeglib "jpeg_read_header"
148
149	function jpeg_start_decompress cinfo
150	arg_rw jpeg_decompress_struct cinfo
151	external jpeglib "jpeg_start_decompress"
152
153	function jpeg_read_scanlines cinfo ptrs maxi -> count
154	arg_rw jpeg_decompress_struct cinfo ; arg Pointer:Address ptrs ; arg Int maxi count
155	external jpeglib "jpeg_read_scanlines"
156
157	function jpeg_finish_decompress cinfo
158	arg_rw jpeg_decompress_struct cinfo
159	external jpeglib "jpeg_finish_decompress"
160
161	function jpeg_abort_decompress cinfo
162	arg_rw jpeg_decompress_struct cinfo
163	external jpeglib "jpeg_abort_decompress"
164
165	function jpeg_destroy_decompress cinfo
166	arg_rw jpeg_decompress_struct cinfo
167	external jpeglib "jpeg_destroy_decompress"
168
169	function jpeg_set_marker_processor cinfo marker_code routine
170	arg_rw jpeg_decompress_struct cinfo ; arg Int marker_code ; arg Address routine
171	external jpeglib "jpeg_set_marker_processor"
172
173
174
175
176
177	function init_source cinfo
178	arg_rw jpeg_decompress_struct cinfo
179	external_calling_convention
180	var Pointer:my_source_mgr src :> cinfo src
181	var Pointer:Stream stream :> src stream
182	src bytes_in_buffer := 0
183
184	function fill_input_buffer cinfo -> ok
185	arg_rw jpeg_decompress_struct cinfo ; arg CBool ok
186	external_calling_convention
187	var Pointer:my_source_mgr src :> cinfo src
188	var Pointer:Stream stream :> src stream
189	stream read_available src:next_input_byte src:bytes_in_buffer
190	ok := stream=success and src:bytes_in_buffer<>0
191
192	function skip_input_data cinfo num_bytes
193	arg_rw jpeg_decompress_struct cinfo ; arg Int num_bytes
194	external_calling_convention
195	var Pointer:my_source_mgr src :> cinfo src
196	var Pointer:Stream stream :> src stream
197	var Int remain := num_bytes
198	var Int step := min src:bytes_in_buffer num_bytes
199	src next_input_byte := src:next_input_byte translate Byte step
200	src bytes_in_buffer -= step
201	remain -= step
202	while remain<>0 and not stream:atend
203	stream read_available (var Address adr) (var Int step) remain
204	remain -= step
205
206	function resync_to_restart cinfo desired -> ok
207	arg_rw jpeg_decompress_struct cinfo ; arg Int desired ; arg CBool ok
208	external_calling_convention
209	console "oops: undefined function resync_to_restart called by jpeg library interface"
210	ok := false
211
212	function term_source cinfo
213	arg_rw jpeg_decompress_struct cinfo
214	external_calling_convention
215
216
217	type ImageReadFilterJpeg
218	field jpeg_decompress_struct cinfo
219	field my_source_mgr src
220	field jpeg_error_mgr jerr
221	field Int remain
222
223	ImageReadFilter maybe ImageReadFilterJpeg
224
225
226	function jpeg_getc cinfo -> byte
227	arg_rw jpeg_decompress_struct cinfo ; arg uInt byte
228	var Pointer:my_source_mgr src :> cinfo src
229	if src:bytes_in_buffer=0
230	fill_input_buffer cinfo
231	byte := src:next_input_byte map uInt8
232	src next_input_byte := src:next_input_byte translate Byte 1
233	src bytes_in_buffer -= 1
234
235	function process_comment cinfo -> ok
236	arg_rw jpeg_decompress_struct cinfo ; arg CBool ok
237	external_calling_convention
238	var Int len := jpeg_getc:cinfo*256+jpeg_getc:cinfo-2
239	var Str comment := repeat len " "
240	for (var Int i) 0 len-1
241	comment i := character jpeg_getc:cinfo
242	console "jpeg comment: " comment eol
243	ok := true
244
245	function error_exit cinfo
246	arg Address cinfo
247	external_calling_convention
248
249	function emit_message cinfo msg_level
250	arg Address cinfo ; arg Int msg_level
251	external_calling_convention
252
253	method f open stream options h -> status
254	arg_rw ImageReadFilterJpeg f ; arg_rw Stream stream ; arg Str options ; arg_w ImagePrototype h ; arg ExtendedStatus status
255	f:src stream :> stream
256	f:cinfo err :> jpeg_std_error f:jerr
257	f:jerr error_exit := (the_function error_exit Address):executable
258	f:jerr emit_message := (the_function emit_message Address Int):executable
259	jpeg_create_decompress f:cinfo
260	f:cinfo src :> f src
261	f:src init_source := (the_function init_source jpeg_decompress_struct) executable
262	f:src fill_input_buffer := (the_function fill_input_buffer jpeg_decompress_struct -> CBool) executable
263	f:src skip_input_data := (the_function skip_input_data jpeg_decompress_struct Int) executable
264	f:src resync_to_restart := (the_function resync_to_restart jpeg_decompress_struct Int -> CBool) executable
265	f:src term_source := (the_function term_source jpeg_decompress_struct) executable
266	if (jpeg_read_header f:cinfo true)<>1
267	jpeg_destroy_decompress f:cinfo
268	return failure
269	if false # f:cinfo:jpeg_color_space<>JCS_RGB and f:cinfo:jpeg_color_space<>JCS_GRAYSCALE
270	jpeg_destroy_decompress f:cinfo
271	return (failure "unsupported JPEG color space "+(string f:cinfo:jpeg_color_space))
272	var Int size_x := f:cinfo image_width
273	var Int size_y := f:cinfo image_height
274	if not ((options (options option_position "resolution" 0) options:len) parse word:"resolution" (var Float dpi_x) (var Float dpi_y) any)
275	dpi_x := options option "resolution" Float 72 ; dpi_y := dpi_x
276	if read_resolution
277	var Int density_unit := ((addressof f:cinfo) translate Byte 286) map uInt8
278	if density_unit=1
279	dpi_x := ((addressof f:cinfo) translate Byte 288) map uInt16
280	dpi_y := ((addressof f:cinfo) translate Byte 290) map uInt16
281	h := image_prototype 0 0 size_x/dpi_x*25.4 size_y/dpi_y*25.4 size_x size_y color_gamut:(shunt f:cinfo:jpeg_color_space=JCS_GRAYSCALE "grey" "rgb")
282	jpeg_set_marker_processor f:cinfo JPEG_COM (the_function process_comment jpeg_decompress_struct -> CBool):executable
283	jpeg_start_decompress f:cinfo
284	f remain := size_y
285	status := success
286
287	method f readline adr -> status
288	arg_rw ImageReadFilterJpeg f ; arg Address adr ; arg Status status
289	var Pointer:Address ptrs :> adr
290	status := shunt (jpeg_read_scanlines f:cinfo ptrs 1)=1 success failure
291	if status=success
292	f remain -= 1
293
294	method f close -> status
295	arg_rw ImageReadFilterJpeg f ; arg ExtendedStatus status
296	if f:remain=0
297	jpeg_finish_decompress f:cinfo
298	jpeg_destroy_decompress f:cinfo
299	status := shunt f:src:stream=success success failure
300
301
302
303
304
305	function init_destination cinfo
306	arg_rw jpeg_compress_struct cinfo
307	external_calling_convention
308	var Pointer:my_destination_mgr dest :> cinfo dest
309	var Pointer:Stream stream :> dest stream
310	dest next_output_byte := stream stream_write_cur
311	dest free_in_buffer := (cast stream:stream_write_stop Int).-.(cast stream:stream_write_cur Int)
312
313	function empty_output_buffer cinfo -> ok
314	arg_rw jpeg_compress_struct cinfo ; arg CBool ok
315	external_calling_convention
316	var Pointer:my_destination_mgr dest :> cinfo dest
317	var Pointer:Stream stream :> dest stream
318	stream stream_write_cur := stream stream_write_stop
319	stream flush anytime
320	dest next_output_byte := stream stream_write_cur
321	dest free_in_buffer := (cast stream:stream_write_stop Int).-.(cast stream:stream_write_cur Int)
322	ok := stream=success
323
324	function term_destination cinfo
325	arg_rw jpeg_compress_struct cinfo
326	external_calling_convention
327	var Pointer:my_destination_mgr dest :> cinfo dest
328	var Pointer:Stream stream :> dest stream
329	stream stream_write_cur := stream:stream_write_stop translate Byte -(dest free_in_buffer)
330	stream flush anytime
331
332
333	type ImageWriteFilterJpeg
334	field jpeg_compress_struct cinfo
335	field my_destination_mgr dest
336	field jpeg_error_mgr jerr
337	field Int remain
338
339	ImageWriteFilter maybe ImageWriteFilterJpeg
340
341	method f open stream options h -> status
342	arg_rw ImageWriteFilterJpeg f ; arg_rw Stream stream ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status
343	if h:gamut:name<>"rgb"
344	return failure:"Only RGB images are currently supported by JPEG output filter"
345	f:dest stream :> stream
346	f:cinfo err :> jpeg_std_error f:jerr
347	jpeg_create_compress f:cinfo
348	f:cinfo dest :> f dest
349	f:dest init_destination := (the_function init_destination jpeg_compress_struct) executable
350	f:dest empty_output_buffer := (the_function empty_output_buffer jpeg_compress_struct -> CBool) executable
351	f:dest term_destination := (the_function term_destination jpeg_compress_struct) executable
352	f:cinfo image_width := h size_x
353	f:cinfo image_height := h size_y
354	f:cinfo input_components := 3
355	f:cinfo in_color_space := JCS_RGB
356	if write_resolution
357	((addressof f:cinfo) translate Byte 210) map uInt8 := 1 # density_unit
358	((addressof f:cinfo) translate Byte 212) map uInt16 := cast h:size_x/(abs h:x1-h:x0)*25.4 Int # X_density
359	((addressof f:cinfo) translate Byte 214) map uInt16 := cast h:size_y/(abs h:y1-h:y0)*25.4 Int # Y_density
360	jpeg_set_defaults f:cinfo
361	var Float quality := options option "quality" Float
362	if quality=defined
363	jpeg_set_quality f:cinfo (cast quality*100 Int) false
364	jpeg_start_compress f:cinfo true
365	var Str comment := options option "comment" Str
366	if comment<>""
367	jpeg_write_marker f:cinfo JPEG_COM comment:characters comment:len
368	f remain := h size_y
369	status := success
370
371	method f writeline adr -> status
372	arg_rw ImageWriteFilterJpeg f ; arg Address adr ; arg Status status
373	var Pointer:Address ptrs :> adr
374	status := shunt (jpeg_write_scanlines f:cinfo ptrs 1)=1 success failure
375	if status=success
376	f remain -= 1
377
378	method f close -> status
379	arg_rw ImageWriteFilterJpeg f ; arg ExtendedStatus status
380	if f:remain=0
381	jpeg_finish_compress f:cinfo
382	jpeg_destroy_compress f:cinfo
383	status := shunt f:dest:stream=success success failure
384
385
386	image_record_filters ".jpg" ImageReadFilterJpeg false ImageWriteFilterJpeg false
387	image_record_filters ".jpeg" ImageReadFilterJpeg false ImageWriteFilterJpeg false
388