1module m_wxml_core
2
3use m_wxml_buffer
4use m_wxml_array_str, only: assign_array_to_str
5use m_wxml_array_str, only: assign_str_to_array
6use m_wxml_escape, only: check_Name
7use m_wxml_elstack
8use m_wxml_dictionary
9
10implicit none
11
12logical, private, save  :: pcdata_advance_line_default = .false.
13logical, private, save  :: pcdata_advance_space_default = .false.
14
15integer, private, parameter ::  sp = selected_real_kind(6,30)
16integer, private, parameter ::  dp = selected_real_kind(14,100)
17
18private
19
20type, public :: xmlf_t
21   character, pointer      :: filename(:)
22   integer                 :: lun
23   type(buffer_t)          :: buffer
24   type(elstack_t)         :: stack
25   type(wxml_dictionary_t) :: dict
26   logical                 :: start_tag_closed
27   logical                 :: root_element_output
28   logical                 :: indenting_requested
29end type xmlf_t
30
31public :: xml_OpenFile, xml_NewElement, xml_EndElement, xml_Close
32public :: xml_AddXMLDeclaration
33public :: xml_AddXMLStylesheet
34public :: xml_AddXMLPI
35public :: xml_AddComment, xml_AddCdataSection
36public :: xml_AddPcdata, xml_AddAttribute
37interface  xml_AddPcdata
38   module procedure xml_AddPcdata_Ch
39end interface
40!
41interface  xml_AddAttribute
42   module procedure xml_AddAttribute_Ch
43end interface
44!
45public :: xml_AddArray
46interface xml_AddArray
47   module procedure  xml_AddArray_integer,  &
48                xml_AddArray_real_dp, xml_AddArray_real_sp
49end interface
50private :: xml_AddArray_integer,  xml_AddArray_real_dp, xml_AddArray_real_sp
51
52private :: get_unit
53private :: add_eol
54private :: write_attributes
55
56!overload error handlers to allow file info
57interface wxml_warning
58  module procedure wxml_warning_xf
59end interface
60interface wxml_error
61  module procedure wxml_error_xf
62end interface
63interface wxml_fatal
64  module procedure wxml_fatal_xf
65end interface
66
67!
68! Heuristic (approximate) target for justification of output
69! Large unbroken pcdatas will go beyond this limit
70!
71integer, private, parameter  :: COLUMNS = 80
72
73! TOHW - This is the longest string that may be output without
74! a newline. The buffer must not be larger than this, but its size
75! can be tuned for performance.
76integer, private, parameter  :: xml_recl = 4096
77
78CONTAINS
79
80!-------------------------------------------------------------------
81subroutine xml_OpenFile(filename, xf, indent)
82character(len=*), intent(in)  :: filename
83type(xmlf_t), intent(inout)   :: xf
84logical, intent(in), optional :: indent
85
86integer :: iostat
87
88allocate(xf%filename(len(filename)))
89call assign_str_to_array(xf%filename,filename)
90
91call get_unit(xf%lun,iostat)
92if (iostat /= 0) call wxml_fatal(xf, "cannot open file")
93!
94! Use large I/O buffer in case the O.S./Compiler combination
95! has hard-limits by default (i.e., NAGWare f95's 1024 byte limit)
96! This is related to the maximum size of the buffer.
97! TOHW - This is the longest string that may be output without
98! a newline. The buffer must not be larger than this, but its size
99! can be tuned for performance.
100
101open(unit=xf%lun, file=filename, form="formatted", status="replace", &
102     action="write", position="rewind", recl=xml_recl)
103
104call init_elstack(xf%stack)
105
106call init_dict(xf%dict)
107call reset_buffer(xf%buffer)
108
109xf%start_tag_closed = .true.
110xf%root_element_output = .false.
111
112xf%indenting_requested = .false.
113if (present(indent)) then
114   xf%indenting_requested = indent
115endif
116end subroutine xml_OpenFile
117
118!-------------------------------------------------------------------
119subroutine xml_AddXMLDeclaration(xf,encoding)
120type(xmlf_t), intent(inout)   :: xf
121character(len=*), intent(in), optional :: encoding
122
123if (present(encoding)) then
124   call add_to_buffer("<?xml version=""1.0"" encoding=""" &
125                     // trim(encoding) // """ ?>", xf%buffer)
126else
127   call add_to_buffer("<?xml version=""1.0"" ?>", xf%buffer)
128endif
129end subroutine xml_AddXMLDeclaration
130
131!-------------------------------------------------------------------
132subroutine xml_AddXMLStylesheet(xf, href, type, title, media, charset, alternate)
133type(xmlf_t), intent(inout)   :: xf
134character(len=*), intent(in) :: href
135character(len=*), intent(in) :: type
136character(len=*), intent(in), optional :: title
137character(len=*), intent(in), optional :: media
138character(len=*), intent(in), optional :: charset
139logical,          intent(in), optional :: alternate
140
141call add_eol(xf)
142call add_to_buffer("<?xml-stylesheet href=""" //trim(href)// &
143     """ type=""" //trim(type)// """", xf%buffer)
144
145if (present(title)) call add_to_buffer(" title="""//trim(title)// """", xf%buffer)
146if (present(media)) call add_to_buffer(" media="""//trim(media)// """", xf%buffer)
147if (present(charset)) call add_to_buffer(" charset="""//trim(charset)// """", xf%buffer)
148if (present(alternate)) then
149   if (alternate) then
150      call add_to_buffer(" alternate=""yes""", xf%buffer)
151   else
152      call add_to_buffer(" alternate=""no""", xf%buffer)
153   endif
154endif
155call add_to_buffer(" ?>", xf%buffer)
156
157end subroutine xml_AddXMLStylesheet
158
159!-------------------------------------------------------------------
160subroutine xml_AddXMLPI(xf, name, data)
161type(xmlf_t), intent(inout)   :: xf
162character(len=*), intent(in) :: name
163character(len=*), intent(in), optional :: data
164
165call add_eol(xf)
166call add_to_buffer("<?" // trim(name) // " ", xf%buffer)
167if(present(data)) call add_to_buffer(data, xf%buffer)
168call add_to_buffer(" ?>", xf%buffer)
169
170end subroutine xml_AddXMLPI
171
172
173!-------------------------------------------------------------------
174subroutine xml_AddComment(xf,comment)
175type(xmlf_t), intent(inout)   :: xf
176character(len=*), intent(in)  :: comment
177
178call close_start_tag(xf,">")
179call add_eol(xf)
180call add_to_buffer("<!--", xf%buffer)
181call add_to_buffer(comment, xf%buffer)
182call add_to_buffer("-->", xf%buffer)
183end subroutine xml_AddComment
184
185!-------------------------------------------------------------------
186subroutine xml_AddCdataSection(xf,cdata)
187type(xmlf_t), intent(inout)   :: xf
188character(len=*), intent(in)  :: cdata
189
190call close_start_tag(xf,">")
191call add_to_buffer("<![CDATA[", xf%buffer)
192call add_to_buffer(cdata, xf%buffer)
193call add_to_buffer("]]>", xf%buffer)
194end subroutine xml_AddCdataSection
195
196!-------------------------------------------------------------------
197subroutine xml_NewElement(xf,name)
198type(xmlf_t), intent(inout)   :: xf
199character(len=*), intent(in)  :: name
200
201if (is_empty(xf%stack)) then
202   if (xf%root_element_output) call wxml_error(xf, "two root elements")
203   xf%root_element_output = .true.
204endif
205
206if (.not.check_Name(name)) then
207  call wxml_warning(xf, 'attribute name '//name//' is not valid')
208endif
209
210
211call close_start_tag(xf,">")
212call push_elstack(name,xf%stack)
213call add_eol(xf)
214call add_to_buffer("<" // trim(name),xf%buffer)
215xf%start_tag_closed = .false.
216call reset_dict(xf%dict)
217
218end subroutine xml_NewElement
219!-------------------------------------------------------------------
220subroutine xml_AddPcdata_Ch(xf,pcdata,space,line_feed)
221type(xmlf_t), intent(inout)   :: xf
222character(len=*), intent(in)  :: pcdata
223logical, intent(in), optional  :: space
224logical, intent(in), optional  :: line_feed
225
226logical :: advance_line , advance_space
227
228advance_line = pcdata_advance_line_default
229if (present(line_feed)) then
230   advance_line = line_feed
231endif
232
233advance_space = pcdata_advance_space_default
234if (present(space)) then
235   advance_space = space
236endif
237
238if (is_empty(xf%stack)) then
239   call wxml_error(xf, "pcdata outside element content")
240endif
241
242call close_start_tag(xf,">")
243
244if (advance_line) then
245   call add_eol(xf)
246   advance_space = .false.
247else
248   if (xf%indenting_requested) then
249      if ((len(xf%buffer) + len_trim(pcdata) + 1) > COLUMNS ) then
250         call add_eol(xf)
251         advance_space = .false.
252      endif
253   endif
254endif
255if (advance_space) call add_to_buffer(" ",xf%buffer)
256
257call add_to_buffer_escaping_markup(pcdata, xf%buffer)
258
259end subroutine xml_AddPcdata_Ch
260
261!-------------------------------------------------------------------
262subroutine xml_AddAttribute_Ch(xf,name,value)
263type(xmlf_t), intent(inout)   :: xf
264character(len=*), intent(in)  :: name
265character(len=*), intent(in)  :: value
266
267if (is_empty(xf%stack)) then
268   call wxml_error(xf, "attributes outside element content")
269endif
270
271if (xf%start_tag_closed)  then
272   call wxml_error(xf, "attributes outside start tag")
273endif
274
275if (has_key(xf%dict,name)) then
276   call wxml_error(xf, "duplicate att name")
277endif
278
279call add_item_to_dict(xf%dict, name, value)
280
281end subroutine xml_AddAttribute_Ch
282
283!-----------------------------------------------------------
284subroutine xml_EndElement(xf,name)
285type(xmlf_t), intent(inout)   :: xf
286character(len=*), intent(in)  :: name
287
288character(len=2000)  :: current
289
290if (is_empty(xf%stack)) then
291   call wxml_fatal(xf, "Out of elements to close")
292endif
293
294call get_top_elstack(xf%stack,current)
295if (current /= name) then
296   call wxml_fatal(xf, 'Trying to close '//Trim(name)//' but '//Trim(current)//' is open.')
297endif
298if (.not. xf%start_tag_closed)  then                ! Empty element
299   if (len(xf%dict) > 0) call write_attributes(xf)
300   call add_to_buffer(" />",xf%buffer)
301   xf%start_tag_closed = .true.
302else
303   call add_eol(xf)
304   call add_to_buffer("</" // trim(name) // ">", xf%buffer)
305endif
306call pop_elstack(xf%stack,current)
307
308end subroutine xml_EndElement
309
310!----------------------------------------------------------------
311
312subroutine xml_Close(xf)
313type(xmlf_t), intent(inout)   :: xf
314
315character(len=2000) :: name
316
317do
318   if (is_empty(xf%stack)) exit
319   call get_top_elstack(xf%stack,name)
320   call xml_EndElement(xf,trim(name))
321enddo
322
323write(unit=xf%lun,fmt="(a)") char(xf%buffer)
324close(unit=xf%lun)
325
326deallocate(xf%filename)
327
328end subroutine xml_Close
329
330!==================================================================
331!-------------------------------------------------------------------
332subroutine get_unit(lun,iostat)
333
334! Get an available Fortran unit number
335
336integer, intent(out)  :: lun
337integer, intent(out)  :: iostat
338
339integer :: i
340logical :: unit_used
341
342do i = 10, 99
343   lun = i
344   inquire(unit=lun,opened=unit_used)
345   if (.not. unit_used) then
346      iostat = 0
347      return
348   endif
349enddo
350iostat = -1
351lun = -1
352end subroutine get_unit
353
354!----------------------------------------------------------
355subroutine add_eol(xf)
356type(xmlf_t), intent(inout)   :: xf
357
358integer :: indent_level
359
360! In case we still have a zero-length stack, we must make
361! sure indent_level is not less than zero.
362indent_level = max(len(xf%stack) - 1, 0)
363
364!We must flush here (rather than just adding an eol character)
365!since we don't know what the eol character is on this system.
366!Flushing with a linefeed will get it automatically, though.
367write(unit=xf%lun,fmt="(a)") char(xf%buffer)
368call reset_buffer(xf%buffer)
369
370if (xf%indenting_requested) &
371   call add_to_buffer(repeat(' ',indent_level),xf%buffer)
372
373end subroutine add_eol
374!------------------------------------------------------------
375subroutine dump_buffer(xf,lf)
376type(xmlf_t), intent(inout)   :: xf
377logical, intent(in), optional :: lf
378
379if (present(lf)) then
380   if (lf) then
381      write(unit=xf%lun,fmt="(a)",advance="yes") char(xf%buffer)
382   else
383      write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer)
384   endif
385else
386   write(unit=xf%lun,fmt="(a)",advance="no") char(xf%buffer)
387endif
388call reset_buffer(xf%buffer)
389
390end subroutine dump_buffer
391
392!------------------------------------------------------------
393subroutine close_start_tag(xf,s)
394type(xmlf_t), intent(inout)   :: xf
395character(len=*), intent(in)  :: s
396
397if (.not. xf%start_tag_closed)  then
398   if (len(xf%dict) > 0)  call write_attributes(xf)
399   call add_to_buffer(s, xf%buffer)
400   xf%start_tag_closed = .true.
401endif
402
403end subroutine close_start_tag
404
405!-------------------------------------------------------------
406subroutine write_attributes(xf)
407type(xmlf_t), intent(inout)   :: xf
408
409integer  :: i, status, size, key_len, value_len
410character(len=2000)  :: key, value
411
412do i = 1, len(xf%dict)
413   call get_key(xf%dict,i,key,key_len,status)
414   call get_value(xf%dict,i,value,value_len,status)
415   size = key_len + value_len + 4
416   if ((len(xf%buffer) + size) > COLUMNS) call add_eol(xf)
417   call add_to_buffer(" ", xf%buffer)
418   call add_to_buffer(key(:key_len), xf%buffer)
419   call add_to_buffer("=", xf%buffer)
420   call add_to_buffer("""",xf%buffer)
421   call add_to_buffer_escaping_markup(value(:value_len), xf%buffer)
422   call add_to_buffer("""", xf%buffer)
423enddo
424
425end subroutine write_attributes
426
427!---------------------------------------------------------------
428    subroutine xml_AddArray_integer(xf,a,format)
429      type(xmlf_t), intent(inout)         :: xf
430      integer, intent(in), dimension(:)   :: a
431      character(len=*), intent(in), optional  :: format
432
433      call close_start_tag(xf,">")
434      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
435      if (present(format)) then
436         write(xf%lun,format) a
437      else
438         write(xf%lun,"(6(i12))") a
439      endif
440    end subroutine xml_AddArray_integer
441
442!-------------------------------------------------------------------
443    subroutine xml_AddArray_real_dp(xf,a,format)
444      type(xmlf_t), intent(inout)         :: xf
445      real(kind=dp), intent(in), dimension(:)   :: a
446      character(len=*), intent(in), optional  :: format
447
448      call close_start_tag(xf,">")
449      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
450      if (present(format)) then
451         write(xf%lun,format) a
452      else
453         write(xf%lun,"(4(es20.12))") a
454      endif
455    end subroutine xml_AddArray_real_dp
456
457!------------------------------------------------------------------
458    subroutine xml_AddArray_real_sp(xf,a,format)
459      type(xmlf_t), intent(inout)         :: xf
460      real(kind=sp), intent(in), dimension(:)   :: a
461      character(len=*), intent(in), optional  :: format
462
463      call close_start_tag(xf,">")
464      if (len(xf%buffer) > 0) call dump_buffer(xf,lf=.true.)
465      if (present(format)) then
466         write(xf%lun,format) a
467      else
468         write(xf%lun,"(4(es20.7))") a
469      endif
470    end subroutine xml_AddArray_real_sp
471
472!---------------------------------------------------------
473! Error handling/trapping routines:
474
475    subroutine wxml_warning_xf(xf, msg)
476      ! Emit warning, but carry on.
477      type(xmlf_t), intent(in) :: xf
478      character(len=*), intent(in) :: msg
479
480      write(6,'(a)') 'WARNING(wxml) in writing to file ', xmlf_name(xf)
481      write(6,'(a)')  msg
482
483    end subroutine wxml_warning_xf
484
485    subroutine wxml_error_xf(xf, msg)
486      ! Emit error message, clean up file and stop.
487      type(xmlf_t), intent(inout) :: xf
488      character(len=*), intent(in) :: msg
489
490      write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf)
491      write(6,'(a)')  msg
492
493      call xml_Close(xf)
494      stop
495
496    end subroutine wxml_error_xf
497
498    subroutine wxml_fatal_xf(xf, msg)
499      !Emit error message and abort with coredump. Does not try to
500      !close file, so should be used from anything xml_Close might
501      !itself call (to avoid infinite recursion!)
502
503      type(xmlf_t), intent(in) :: xf
504      character(len=*), intent(in) :: msg
505
506      write(6,'(a)') 'ERROR(wxml) in writing to file ', xmlf_name(xf)
507      write(6,'(a)')  msg
508
509      call pxfabort
510      stop
511
512    end subroutine wxml_fatal_xf
513
514    function xmlf_name(xf) result(fn)
515      Type (xmlf_t), intent(in) :: xf
516      character(len=size(xf%filename)) :: fn
517      call assign_array_to_str(fn,xf%filename)
518    end function xmlf_name
519
520
521end module m_wxml_core
522
523