1 | module m_wxml_core |
---|
2 | |
---|
3 | use m_wxml_buffer |
---|
4 | use m_wxml_elstack |
---|
5 | use m_wxml_dictionary |
---|
6 | |
---|
7 | logical, private, save :: pcdata_advance_line_default = .false. |
---|
8 | logical, private, save :: pcdata_advance_space_default = .false. |
---|
9 | |
---|
10 | integer, private, parameter :: sp = selected_real_kind(6,30) |
---|
11 | integer, private, parameter :: dp = selected_real_kind(14,100) |
---|
12 | |
---|
13 | private |
---|
14 | |
---|
15 | type, public :: xmlf_t |
---|
16 | integer :: lun |
---|
17 | type(buffer_t) :: buffer |
---|
18 | type(elstack_t) :: stack |
---|
19 | type(wxml_dictionary_t) :: dict |
---|
20 | logical :: start_tag_closed |
---|
21 | logical :: root_element_output |
---|
22 | logical :: indenting_requested |
---|
23 | end type xmlf_t |
---|
24 | |
---|
25 | public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close |
---|
26 | public :: xml_AddPcdata, xml_AddAttribute, xml_AddXMLDeclaration |
---|
27 | public :: xml_AddComment, xml_AddCdataSection |
---|
28 | |
---|
29 | public :: xml_AddArray |
---|
30 | interface xml_AddArray |
---|
31 | module procedure xml_AddArray_integer, & |
---|
32 | xml_AddArray_real_dp, xml_AddArray_real_sp |
---|
33 | end interface |
---|
34 | private :: xml_AddArray_integer, xml_AddArray_real_dp, xml_AddArray_real_sp |
---|
35 | |
---|
36 | private :: get_unit |
---|
37 | private :: add_eol |
---|
38 | private :: write_attributes |
---|
39 | |
---|
40 | |
---|
41 | integer, private, parameter :: COLUMNS = 80 |
---|
42 | |
---|
43 | CONTAINS |
---|
44 | |
---|
45 | !------------------------------------------------------------------- |
---|
46 | subroutine xml_OpenFile(filename, xf, indent) |
---|
47 | character(len=*), intent(in) :: filename |
---|
48 | type(xmlf_t), intent(inout) :: xf |
---|
49 | logical, intent(in), optional :: indent |
---|
50 | |
---|
51 | integer :: iostat |
---|
52 | |
---|
53 | call get_unit(xf%lun,iostat) |
---|
54 | if (iostat /= 0) stop "cannot open file" |
---|
55 | open(unit=xf%lun, file=filename, form="formatted", status="replace", & |
---|
56 | action="write", position="rewind") ! , recl=65536) |
---|
57 | |
---|
58 | call reset_elstack(xf%stack) |
---|
59 | call reset_dict(xf%dict) |
---|
60 | call reset_buffer(xf%buffer) |
---|
61 | |
---|
62 | xf%start_tag_closed = .true. |
---|
63 | xf%root_element_output = .false. |
---|
64 | |
---|
65 | xf%indenting_requested = .false. |
---|
66 | if (present(indent)) then |
---|
67 | xf%indenting_requested = indent |
---|
68 | endif |
---|
69 | end subroutine xml_OpenFile |
---|
70 | |
---|
71 | !------------------------------------------------------------------- |
---|
72 | subroutine xml_AddXMLDeclaration(xf,encoding) |
---|
73 | type(xmlf_t), intent(inout) :: xf |
---|
74 | character(len=*), intent(in), optional :: encoding |
---|
75 | |
---|
76 | if (present(encoding)) then |
---|
77 | call add_to_buffer("<?xml version=""1.0"" encoding=""" & |
---|
78 | // trim(encoding) // """ ?>", xf%buffer) |
---|
79 | else |
---|
80 | call add_to_buffer("<?xml version=""1.0"" ?>", xf%buffer) |
---|
81 | endif |
---|
82 | end subroutine xml_AddXMLDeclaration |
---|
83 | |
---|
84 | !------------------------------------------------------------------- |
---|
85 | subroutine xml_AddComment(xf,comment) |
---|
86 | type(xmlf_t), intent(inout) :: xf |
---|
87 | character(len=*), intent(in) :: comment |
---|
88 | |
---|
89 | call close_start_tag(xf,">") |
---|
90 | call add_eol(xf) |
---|
91 | call add_to_buffer("<!--", xf%buffer) |
---|
92 | call add_to_buffer(comment, xf%buffer) |
---|
93 | call add_to_buffer("-->", xf%buffer) |
---|
94 | end subroutine xml_AddComment |
---|
95 | |
---|
96 | !------------------------------------------------------------------- |
---|
97 | subroutine xml_AddCdataSection(xf,cdata) |
---|
98 | type(xmlf_t), intent(inout) :: xf |
---|
99 | character(len=*), intent(in) :: cdata |
---|
100 | |
---|
101 | call close_start_tag(xf,">") |
---|
102 | call add_to_buffer("<![CDATA[", xf%buffer) |
---|
103 | call add_to_buffer(cdata, xf%buffer) |
---|
104 | call add_to_buffer("]]>", xf%buffer) |
---|
105 | end subroutine xml_AddCdataSection |
---|
106 | |
---|
107 | !------------------------------------------------------------------- |
---|
108 | subroutine xml_NewElement(xf,name) |
---|
109 | type(xmlf_t), intent(inout) :: xf |
---|
110 | character(len=*), intent(in) :: name |
---|
111 | |
---|
112 | if (is_empty(xf%stack)) then |
---|
113 | if (xf%root_element_output) stop "two root elements" |
---|
114 | xf%root_element_output = .true. |
---|
115 | endif |
---|
116 | |
---|
117 | call close_start_tag(xf,">") |
---|
118 | call push_elstack(name,xf%stack) |
---|
119 | call add_eol(xf) |
---|
120 | call add_to_buffer("<" // trim(name),xf%buffer) |
---|
121 | xf%start_tag_closed = .false. |
---|
122 | call reset_dict(xf%dict) |
---|
123 | |
---|
124 | end subroutine xml_NewElement |
---|
125 | !------------------------------------------------------------------- |
---|
126 | subroutine xml_AddPcdata(xf,pcdata,space,line_feed) |
---|
127 | type(xmlf_t), intent(inout) :: xf |
---|
128 | character(len=*), intent(in) :: pcdata |
---|
129 | logical, intent(in), optional :: space |
---|
130 | logical, intent(in), optional :: line_feed |
---|
131 | |
---|
132 | logical :: advance_line , advance_space |
---|
133 | integer :: n, i, jmax |
---|
134 | integer, parameter :: chunk_size = 128 |
---|
135 | |
---|
136 | advance_line = pcdata_advance_line_default |
---|
137 | if (present(line_feed)) then |
---|
138 | advance_line = line_feed |
---|
139 | endif |
---|
140 | |
---|
141 | advance_space = pcdata_advance_space_default |
---|
142 | if (present(space)) then |
---|
143 | advance_space = space |
---|
144 | endif |
---|
145 | |
---|
146 | if (is_empty(xf%stack)) then |
---|
147 | stop "pcdata outside element content" |
---|
148 | endif |
---|
149 | |
---|
150 | call close_start_tag(xf,">") |
---|
151 | |
---|
152 | if (advance_line) then |
---|
153 | call add_eol(xf) |
---|
154 | advance_space = .false. |
---|
155 | else |
---|
156 | if (xf%indenting_requested) then |
---|
157 | if ((len(xf%buffer) + len_trim(pcdata) + 1) > COLUMNS ) then |
---|
158 | call add_eol(xf) |
---|
159 | advance_space = .false. |
---|
160 | endif |
---|
161 | endif |
---|
162 | endif |
---|
163 | if (advance_space) call add_to_buffer(" ",xf%buffer) |
---|
164 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.false.) |
---|
165 | ! |
---|
166 | ! We bypass the buffer for the bulk of the dump |
---|
167 | ! |
---|
168 | n = len(pcdata) |
---|
169 | !print *, "writing pcdata of length: ", n |
---|
170 | i = 1 |
---|
171 | do |
---|
172 | jmax = min(i+chunk_size-1,n) |
---|
173 | ! print *, "writing chunk: ", i, jmax |
---|
174 | write(unit=xf%lun,fmt="(a)",advance="no") pcdata(i:jmax) |
---|
175 | if (jmax == n) exit |
---|
176 | i = jmax + 1 |
---|
177 | enddo |
---|
178 | end subroutine xml_AddPcdata |
---|
179 | |
---|
180 | !------------------------------------------------------------------- |
---|
181 | subroutine xml_AddAttribute(xf,name,value) |
---|
182 | type(xmlf_t), intent(inout) :: xf |
---|
183 | character(len=*), intent(in) :: name |
---|
184 | character(len=*), intent(in) :: value |
---|
185 | |
---|
186 | if (is_empty(xf%stack)) then |
---|
187 | stop "attributes outside element content" |
---|
188 | endif |
---|
189 | |
---|
190 | if (xf%start_tag_closed) then |
---|
191 | stop "attributes outside start tag" |
---|
192 | endif |
---|
193 | if (has_key(xf%dict,name)) then |
---|
194 | stop "duplicate att name" |
---|
195 | endif |
---|
196 | |
---|
197 | call add_key_to_dict(trim(name),xf%dict) |
---|
198 | call add_value_to_dict(trim(value),xf%dict) |
---|
199 | |
---|
200 | end subroutine xml_AddAttribute |
---|
201 | |
---|
202 | !----------------------------------------------------------- |
---|
203 | subroutine xml_EndElement(xf,name) |
---|
204 | type(xmlf_t), intent(inout) :: xf |
---|
205 | character(len=*), intent(in) :: name |
---|
206 | |
---|
207 | character(len=100) :: current |
---|
208 | |
---|
209 | if (is_empty(xf%stack)) then |
---|
210 | stop "Out of elements to close" |
---|
211 | endif |
---|
212 | |
---|
213 | call get_top_elstack(xf%stack,current) |
---|
214 | if (current /= name) then |
---|
215 | print *, "current, name: ", trim(current), " ", trim(name) |
---|
216 | stop |
---|
217 | endif |
---|
218 | if (.not. xf%start_tag_closed) then ! Empty element |
---|
219 | if (len(xf%dict) > 0) call write_attributes(xf) |
---|
220 | call add_to_buffer(" />",xf%buffer) |
---|
221 | xf%start_tag_closed = .true. |
---|
222 | else |
---|
223 | call add_eol(xf) |
---|
224 | call add_to_buffer("</" // trim(name) // ">", xf%buffer) |
---|
225 | endif |
---|
226 | call pop_elstack(xf%stack,current) |
---|
227 | |
---|
228 | end subroutine xml_EndElement |
---|
229 | |
---|
230 | !---------------------------------------------------------------- |
---|
231 | |
---|
232 | subroutine xml_Close(xf) |
---|
233 | type(xmlf_t), intent(in) :: xf |
---|
234 | |
---|
235 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) |
---|
236 | close(unit=xf%lun) |
---|
237 | |
---|
238 | end subroutine xml_Close |
---|
239 | |
---|
240 | !================================================================== |
---|
241 | !------------------------------------------------------------------- |
---|
242 | subroutine get_unit(lun,iostat) |
---|
243 | |
---|
244 | ! Get an available Fortran unit number |
---|
245 | |
---|
246 | integer, intent(out) :: lun |
---|
247 | integer, intent(out) :: iostat |
---|
248 | |
---|
249 | integer :: i |
---|
250 | logical :: unit_used |
---|
251 | |
---|
252 | do i = 10, 99 |
---|
253 | lun = i |
---|
254 | inquire(unit=lun,opened=unit_used) |
---|
255 | if (.not. unit_used) then |
---|
256 | iostat = 0 |
---|
257 | return |
---|
258 | endif |
---|
259 | enddo |
---|
260 | iostat = -1 |
---|
261 | lun = -1 |
---|
262 | end subroutine get_unit |
---|
263 | |
---|
264 | !---------------------------------------------------------- |
---|
265 | subroutine add_eol(xf) |
---|
266 | type(xmlf_t), intent(inout) :: xf |
---|
267 | |
---|
268 | integer :: indent_level |
---|
269 | character(len=100), parameter :: blanks = "" |
---|
270 | |
---|
271 | indent_level = len(xf%stack) - 1 |
---|
272 | write(unit=xf%lun,fmt="(a)") char(xf%buffer) |
---|
273 | call reset_buffer(xf%buffer) |
---|
274 | |
---|
275 | if (xf%indenting_requested) & |
---|
276 | call add_to_buffer(blanks(1:indent_level),xf%buffer) |
---|
277 | |
---|
278 | end subroutine add_eol |
---|
279 | !------------------------------------------------------------ |
---|
280 | subroutine dump_buffer(xf,lf) |
---|
281 | type(xmlf_t), intent(inout) :: xf |
---|
282 | logical, intent(in), optional :: lf |
---|
283 | |
---|
284 | if (present(lf)) then |
---|
285 | if (lf) then |
---|
286 | write(unit=xf%lun,fmt="(a)",advance="yes") char(xf%buffer) |
---|
287 | else |
---|
288 | write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer) |
---|
289 | endif |
---|
290 | else |
---|
291 | write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer) |
---|
292 | endif |
---|
293 | call reset_buffer(xf%buffer) |
---|
294 | |
---|
295 | end subroutine dump_buffer |
---|
296 | |
---|
297 | !------------------------------------------------------------ |
---|
298 | subroutine close_start_tag(xf,s) |
---|
299 | type(xmlf_t), intent(inout) :: xf |
---|
300 | character(len=*), intent(in) :: s |
---|
301 | |
---|
302 | if (.not. xf%start_tag_closed) then |
---|
303 | if (len(xf%dict) > 0) call write_attributes(xf) |
---|
304 | call add_to_buffer(s, xf%buffer) |
---|
305 | xf%start_tag_closed = .true. |
---|
306 | endif |
---|
307 | |
---|
308 | end subroutine close_start_tag |
---|
309 | |
---|
310 | !------------------------------------------------------------- |
---|
311 | subroutine write_attributes(xf) |
---|
312 | type(xmlf_t), intent(inout) :: xf |
---|
313 | |
---|
314 | integer :: i, status, size |
---|
315 | character(len=100) :: key, value |
---|
316 | |
---|
317 | do i = 1, len(xf%dict) |
---|
318 | call get_key(xf%dict,i,key,status) |
---|
319 | call get_value(xf%dict,key,value,status) |
---|
320 | key = adjustl(key) |
---|
321 | value = adjustl(value) |
---|
322 | size = len_trim(key) + len_trim(value) + 4 |
---|
323 | if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf) |
---|
324 | call add_to_buffer(" ", xf%buffer) |
---|
325 | call add_to_buffer(trim(key), xf%buffer) |
---|
326 | call add_to_buffer("=", xf%buffer) |
---|
327 | call add_to_buffer("""",xf%buffer) |
---|
328 | call add_to_buffer(trim(value), xf%buffer) |
---|
329 | call add_to_buffer("""", xf%buffer) |
---|
330 | enddo |
---|
331 | |
---|
332 | end subroutine write_attributes |
---|
333 | |
---|
334 | !--------------------------------------------------------------- |
---|
335 | subroutine xml_AddArray_integer(xf,a,format) |
---|
336 | type(xmlf_t), intent(inout) :: xf |
---|
337 | integer, intent(in), dimension(:) :: a |
---|
338 | character(len=*), intent(in), optional :: format |
---|
339 | |
---|
340 | call close_start_tag(xf,">") |
---|
341 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) |
---|
342 | if (present(format)) then |
---|
343 | write(xf%lun,format) a |
---|
344 | else |
---|
345 | write(xf%lun,"(6(i12))") a |
---|
346 | endif |
---|
347 | end subroutine xml_AddArray_integer |
---|
348 | |
---|
349 | !------------------------------------------------------------------- |
---|
350 | subroutine xml_AddArray_real_dp(xf,a,format) |
---|
351 | type(xmlf_t), intent(inout) :: xf |
---|
352 | real(kind=dp), intent(in), dimension(:) :: a |
---|
353 | character(len=*), intent(in), optional :: format |
---|
354 | |
---|
355 | call close_start_tag(xf,">") |
---|
356 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) |
---|
357 | if (present(format)) then |
---|
358 | write(xf%lun,format) a |
---|
359 | else |
---|
360 | write(xf%lun,"(4(es20.12))") a |
---|
361 | endif |
---|
362 | end subroutine xml_AddArray_real_dp |
---|
363 | |
---|
364 | !------------------------------------------------------------------ |
---|
365 | subroutine xml_AddArray_real_sp(xf,a,format) |
---|
366 | type(xmlf_t), intent(inout) :: xf |
---|
367 | real(kind=sp), intent(in), dimension(:) :: a |
---|
368 | character(len=*), intent(in), optional :: format |
---|
369 | |
---|
370 | call close_start_tag(xf,">") |
---|
371 | if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.) |
---|
372 | if (present(format)) then |
---|
373 | write(xf%lun,format) a |
---|
374 | else |
---|
375 | write(xf%lun,"(4(es20.12))") a |
---|
376 | endif |
---|
377 | end subroutine xml_AddArray_real_sp |
---|
378 | |
---|
379 | end module m_wxml_core |
---|
380 | |
---|