/pliant/graphic/filter/io.pli
1	abstract
2	[Reading and writing a Pliant image from or to a file.]
3
4	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
5	#
6	# This program is free software; you can redistribute it and/or
7	# modify it under the terms of the GNU General Public License version 2
8	# as published by the Free Software Foundation.
9	#
10	# This program is distributed in the hope that it will be useful,
11	# but WITHOUT ANY WARRANTY; without even the implied warranty of
12	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13	# GNU General Public License for more details.
14	#
15	# You should have received a copy of the GNU General Public License
16	# version 2 along with this program; if not, write to the Free Software
17	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
18
19
20	module "/pliant/language/compiler.pli"
21	module "/pliant/language/stream.pli"
22	module "/pliant/admin/file.pli"
23	module "prototype.pli"
24	module "all.pli"
25	module "/pliant/graphic/image/prototype.pli"
26	module "/pliant/language/context.pli"
27	module "/pliant/graphic/misc/mtbuffer.pli"
28	module "/pliant/storage/database.pli"
29
30	constant trace false
31
32	function image_query filename options h -> status
33	arg Str filename options ; arg_w ImagePrototype h ; arg ExtendedStatus status
34	var Link:ImageReadFilter f :> image_read_filter (options option "filter" Str filename)
35	if not exists:f
36	return (failure "There is no filter for "+filename+" image")
37	status := f query filename options h
38
39
40	method p load stream options -> status
41	oarg_rw ImagePrototype p ; arg_rw Stream stream ; arg Str options ; arg ExtendedStatus status
42	var Link:ImageReadFilter f :> image_read_filter (options option "filter" Str stream:name)
43	if not exists:f
44	return (failure "There is no filter for "+stream:name+" image")
45	part open "load image "+(entry_type addressof:f):name+" open"
46	status := f open stream options (var ImagePrototype h)
47	if status=failure
48	return
49	if (p setup h options)=failure
50	return failure:"Cannot setup image"
51	p options := h options
52	var Address buffer := null
53	part read_lines "load image "+(entry_type addressof:f):name+" "+stream:name
54	for (var Int y) 0 p:size_y-1
55	part line "line "+string:y+"/"+(string p:size_y)
56	if stream=failure
57	status := failure "Image input stream is broken"
58	leave read_lines
59	if trace and 100*y\p:size_y<>100*(y-1)\p:size_y
60	console stream:name " " (string 100*y\p:size_y) "%  [cr]"
61	var Address adr := p write_map 0 y p:size_x p:size_x (var Int count)
62	if adr<>null
63	if (f readline adr)=failure
64	status := failure "Failed to read mapped line "+(string y+1)+"/"+(string p:size_y)
65	p write_unmap 0 y count adr
66	leave read_lines
67	p write_unmap 0 y count adr
68	else
69	if buffer=null
70	buffer := memory_allocate p:line_size addressof:p
71	if (f readline buffer)=failure
72	status := failure "Failed to read line "+(string y+1)+"/"+(string p:size_y)
73	leave read_lines
74	p write 0 y p:size_x buffer
75	if buffer<>null
76	memory_free buffer
77	part close "load image "+(entry_type addressof:f):name+" close"
78	if f:close=failure
79	if status=success
80	status := failure "Failed to close the image input file"
81	if trace
82	console (repeat stream:name:len+7 " ") "[cr]"
83
84	method p load filename options -> status
85	oarg_rw ImagePrototype p ; arg Str filename options ; arg ExtendedStatus status
86	var Link:Stream s :> new Stream
87	if (s open filename options in+safe+anyeol+bigcache+image_read_flags:(options option "filter" Str filename))=failure
88	return (failure "Failed to open "+filename)
89	status := p load s options
90	if s=failure
91	status := failure filename+" is corrupted"
92
93
94	method p save stream options -> status
95	oarg_rw ImagePrototype p ; arg_rw Stream stream ; arg Str options ; arg ExtendedStatus status
96	var Link:ImageWriteFilter f :> image_write_filter (options option "filter" Str stream:name)
97	if not exists:f
98	return (failure "There is no filter for "+stream:name+" image")
99	var ImagePrototype h := image_prototype p:x0 p:y0 p:x1 p:y1 p:size_x p:size_y p:gamut
100	h options := p options
101	part open "save image "+(entry_type addressof:f):name+" open"
102	status := f open stream options h
103	if status=failure
104	return
105	var Int burst := options option "burst" Int (shunt (options option "burst") processor_count undefined)
106	var Str cflag := options option "continue_flag" Str
107	if burst<>undefined and burst>1
108	(var MtBuffer buffers) size := p line_size
109	part burst_write_lines "burst "+string:burst+" save image "+(entry_type addressof:f):name+" "+stream:name
110	parallel threads burst
111	for (var Int y) 0 p:size_y-1
112	if cflag:len>0 and (cflag pmap Bool)<>true
113	status := failure "Interrupted"
114	if status=success
115	if trace and 100*y\p:size_y<>100*(y-1)\p:size_y
116	console stream:name " " (string 100*y\p:size_y) "%  [cr]"
117	var Address buffer
118	task
119	share p f buffers
120	buffer := buffers allocate
121	part read_line "burst read line "+string:y+"/"+(string p:size_y)
122	p read 0 y p:size_x buffer
123	post
124	part write_line "burst write line "+string:y+"/"+(string p:size_y)
125	if (f writeline buffer)=failure
126	status := failure "Failed to write line "+(string y+1)+"/"+(string p:size_y)
127	buffers free buffer
128	if stream=failure
129	status := failure "Image output stream is broken"
130	else
131	var Address buffer := null
132	part write_lines "save image "+(entry_type addressof:f):name+" "+stream:name
133	for (var Int y) 0 p:size_y-1
134	if cflag:len>0 and (cflag pmap Bool)<>true
135	status := failure "Interrupted"
136	if status=failure
137	leave write_lines
138	part line "line "+string:y+"/"+(string p:size_y)
139	if trace and 100*y\p:size_y<>100*(y-1)\p:size_y
140	console stream:name " " (string 100*y\p:size_y) "%  [cr]"
141	var Address adr := p read_map 0 y p:size_x p:size_x (var Int count)
142	if adr<>null
143	if (f writeline adr)=failure
144	status := failure "Failed to write mapped line "+(string y+1)+"/"+(string p:size_y)
145	p read_unmap 0 y count adr
146	else
147	if buffer=null
148	buffer := memory_allocate p:line_size addressof:p
149	p read 0 y p:size_x buffer
150	if (f writeline buffer)=failure
151	status := failure "Failed to write line "+(string y+1)+"/"+(string p:size_y)
152	if stream=failure
153	status := failure "Image output stream is broken"
154	if buffer<>null
155	memory_free buffer
156	part close "save image "+(entry_type addressof:f):name+" close"
157	var ExtendedStatus cs := f close
158	if cs=failure and status=success
159	status := cs
160	if trace
161	console (repeat stream:name:len+7 " ") "[cr]"
162
163	method p save filename options -> status
164	oarg_rw ImagePrototype p ; arg Str filename options ; arg ExtendedStatus status
165	var CBool tmp := not (options option "notmp")
166	var Link:Stream s :> new Stream
167	if (s open filename+(shunt tmp ".tmp" "") options out+safe+bigcache+image_write_flags:(options option "filter" Str filename))=failure
168	return (failure "Failed to open "+filename)
169	status := p save s options+" filter "+string:filename
170	if status=success and s:close=failure
171	status := failure "Failed to write "+filename
172	if tmp
173	if status=success
174	file_delete filename
175	file_move filename+".tmp" filename
176	else
177	file_delete filename+".tmp"
178
179
180	export image_query '. load' '. save'
181