New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
m_xml_parser.f90 in vendors/XMLF90/current/src/sax – NEMO

source: vendors/XMLF90/current/src/sax/m_xml_parser.f90 @ 1963

Last change on this file since 1963 was 1963, checked in by flavoni, 14 years ago

importing XMLF90 r_53 vendor
File size: 16.5 KB
Line 
1module m_xml_parser
2
3!
4! Basic module to parse XML in the SAX spirit.
5!
6
7use m_buffer
8use m_reader
9use m_fsm
10use m_dictionary
11use m_debug
12use m_xml_error
13use m_elstack          ! For element nesting checks
14use m_entities
15!
16private
17
18!
19!  XML file handle
20!
21type, public :: xml_t
22private
23      type(file_buffer_t)  :: fb
24      type(fsm_t)          :: fx
25      character(len=200)   :: path_mark
26end type xml_t
27
28!
29public :: xml_parse
30public :: open_xmlfile, close_xmlfile
31public :: endfile_xmlfile, rewind_xmlfile
32public :: eof_xmlfile, sync_xmlfile
33public :: xml_char_count
34public :: xml_path, xml_mark_path, xml_get_path_mark
35public :: xml_name, xml_attributes
36
37CONTAINS  !=============================================================
38
39subroutine open_xmlfile(fname,fxml,iostat,record_size)
40character(len=*), intent(in)      :: fname
41integer, intent(out)              :: iostat
42type(xml_t), intent(out)          :: fxml
43integer, intent(in), optional     :: record_size
44
45call open_file(fname,fxml%fb,iostat,record_size)
46call init_fsm(fxml%fx)
47fxml%path_mark = ""
48
49end subroutine open_xmlfile
50!-------------------------------------------------------------------------
51
52subroutine rewind_xmlfile(fxml)
53type(xml_t), intent(inout) :: fxml
54
55call rewind_file(fxml%fb)
56call reset_fsm(fxml%fx)
57fxml%path_mark = ""
58
59end subroutine rewind_xmlfile
60
61!-----------------------------------------
62subroutine endfile_xmlfile(fxml)
63type(xml_t), intent(inout) :: fxml
64
65call mark_eof_file(fxml%fb) 
66
67end subroutine endfile_xmlfile
68
69!-----------------------------------------
70subroutine close_xmlfile(fxml)
71type(xml_t), intent(inout) :: fxml
72
73call close_file_buffer(fxml%fb)
74call reset_fsm(fxml%fx)         ! just in case
75fxml%path_mark = ""             ! ""
76
77end subroutine close_xmlfile
78
79!-----------------------------------------
80subroutine sync_xmlfile(fxml,iostat)
81type(xml_t), intent(inout) :: fxml
82integer, intent(out)       :: iostat
83
84call sync_file(fxml%fb,iostat)
85! Do not reset fx: that's the whole point of synching.
86
87end subroutine sync_xmlfile
88
89!----------------------------------------------------
90function eof_xmlfile(fxml) result (res)
91type(xml_t), intent(in)          :: fxml
92logical                          :: res
93
94res = eof_file(fxml%fb)
95
96end function eof_xmlfile
97!
98!----------------------------------------------------
99!----------------------------------------------------
100function xml_char_count(fxml) result (nc)
101type(xml_t), intent(in)          :: fxml
102integer                          :: nc
103
104nc = nchars_processed(fxml%fb)
105
106end function xml_char_count
107!
108!----------------------------------------------------
109!
110
111subroutine xml_parse(fxml, begin_element_handler,    &
112                           end_element_handler,      &
113                           pcdata_chunk_handler,     &
114                           comment_handler,          &
115                           xml_declaration_handler,  &
116                           cdata_section_handler,     &
117                           sgml_declaration_handler, &
118                           error_handler,            &
119                           signal_handler,            &
120                           verbose,                  &
121                           empty_element_handler)
122
123type(xml_t), intent(inout), target  :: fxml
124
125optional                            :: begin_element_handler
126optional                            :: end_element_handler
127optional                            :: pcdata_chunk_handler
128optional                            :: comment_handler
129optional                            :: xml_declaration_handler
130optional                            :: sgml_declaration_handler
131optional                            :: cdata_section_handler
132optional                            :: error_handler
133optional                            :: signal_handler
134logical, intent(in), optional       :: verbose
135optional                            :: empty_element_handler
136
137interface
138   subroutine begin_element_handler(name,attributes)
139   use m_dictionary
140   character(len=*), intent(in)     :: name
141   type(dictionary_t), intent(in)   :: attributes
142   end subroutine begin_element_handler
143
144   subroutine end_element_handler(name)
145   character(len=*), intent(in)     :: name
146   end subroutine end_element_handler
147
148   subroutine pcdata_chunk_handler(chunk)
149   character(len=*), intent(in) :: chunk
150   end subroutine pcdata_chunk_handler
151
152   subroutine comment_handler(comment)
153   character(len=*), intent(in) :: comment
154   end subroutine comment_handler
155
156   subroutine xml_declaration_handler(name,attributes)
157   use m_dictionary
158   character(len=*), intent(in)     :: name
159   type(dictionary_t), intent(in)   :: attributes
160   end subroutine xml_declaration_handler
161
162   subroutine sgml_declaration_handler(sgml_declaration)
163   character(len=*), intent(in) :: sgml_declaration
164   end subroutine sgml_declaration_handler
165
166   subroutine cdata_section_handler(cdata)
167   character(len=*), intent(in) :: cdata
168   end subroutine cdata_section_handler
169
170   subroutine error_handler(error_info)
171   use m_xml_error
172   type(xml_error_t), intent(in)            :: error_info
173   end subroutine error_handler
174
175   subroutine signal_handler(code)
176   logical, intent(out) :: code
177   end subroutine signal_handler
178
179   subroutine empty_element_handler(name,attributes)
180   use m_dictionary
181   character(len=*), intent(in)     :: name
182   type(dictionary_t), intent(in)   :: attributes
183   end subroutine empty_element_handler
184
185end interface
186
187character(len=1)     :: c
188integer              :: iostat, status
189
190character(len=150)   :: message
191integer              :: signal
192
193type(buffer_t)       :: translated_pcdata
194type(buffer_t)       :: name, oldname, dummy
195
196logical              :: have_begin_handler, have_end_handler, &
197                        have_pcdata_handler, have_comment_handler, &
198                        have_xml_declaration_handler, &
199                        have_sgml_declaration_handler, &
200                        have_cdata_section_handler, have_empty_handler, &
201                        have_error_handler, have_signal_handler
202
203logical              :: pause_signal
204
205type(xml_error_t)            :: error_info
206type(file_buffer_t), pointer :: fb
207type(fsm_t), pointer         :: fx
208
209have_begin_handler = present(begin_element_handler)
210have_end_handler = present(end_element_handler)
211have_pcdata_handler = present(pcdata_chunk_handler)
212have_comment_handler = present(comment_handler)
213have_xml_declaration_handler = present(xml_declaration_handler)
214have_sgml_declaration_handler = present(sgml_declaration_handler)
215have_cdata_section_handler = present(cdata_section_handler)
216have_error_handler = present(error_handler)
217have_signal_handler = present(signal_handler)
218have_empty_handler = present(empty_element_handler)
219
220fb => fxml%fb
221fx => fxml%fx
222if (present(verbose)) then
223   debug = verbose                 ! For m_converters
224   fx%debug = verbose              ! job-specific flag
225endif
226
227if (fx%debug) print *, " Entering xml_parse..."
228
229!---------------------------------------------------------------------
230do
231      call get_character(fb,c,iostat)
232
233      if (iostat /= 0) then          ! End of file...
234         if (.not. is_empty(fx%element_stack)) then
235            call build_error_info(error_info, &
236                 "Early end of file.", &
237                 line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
238            if (have_error_handler) then
239               call error_handler(error_info)
240            else
241               call default_error_handler(error_info)
242            endif
243         endif
244         call endfile_xmlfile(fxml)  ! Mark it as eof
245         EXIT
246      endif
247
248      call evolve_fsm(fx,c,signal)
249
250      if (fx%debug) print *, c, " ::: ", trim(fx%action)
251
252      if (signal == END_OF_TAG) then
253         !
254         ! We decide whether we have ended an opening tag or a closing tag
255         !
256         if (fx%context == OPENING_TAG) then
257            name = fx%element_name
258
259            if (fx%debug) print *, "We have found an opening tag"
260            if (fx%root_element_seen) then
261               if (name .equal. fx%root_element_name) then
262                  call build_error_info(error_info, &
263                  "Duplicate root element: " // str(name), &
264                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
265                  if (have_error_handler) then
266                     call error_handler(error_info)
267                  else
268                     call default_error_handler(error_info)
269                  endif
270               endif
271               if (is_empty(fx%element_stack)) then
272                  call build_error_info(error_info, &
273                  "Opening tag beyond root context: " // str(name), &
274                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
275                  if (have_error_handler) then
276                     call error_handler(error_info)
277                  else
278                     call default_error_handler(error_info)
279                  endif
280               endif
281            else
282               fx%root_element_name = name
283               fx%root_element_seen = .true.
284            endif
285            call push_elstack(name,fx%element_stack)
286            if (have_begin_handler) &
287                call begin_element_handler(str(name),fx%attributes)
288
289         else if (fx%context == CLOSING_TAG) then
290            name = fx%element_name
291         
292            if (fx%debug) print *, "We have found a closing tag"
293            if (is_empty(fx%element_stack)) then
294               call build_error_info(error_info, &
295                  "Nesting error: End tag: " // str(name) //  &
296                  " does not match -- too many end tags", &
297                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
298               if (have_error_handler) then
299                  call error_handler(error_info)
300               else
301                  call default_error_handler(error_info)
302               endif
303            else
304               call get_top_elstack(fx%element_stack,oldname)
305               if (oldname .equal. name) then
306                  call pop_elstack(fx%element_stack,oldname)
307                  if (have_end_handler) call end_element_handler(str(name))
308!!                  call pop_elstack(fx%element_stack,oldname)
309               else
310                  call build_error_info(error_info, &
311                       "Nesting error: End tag: " // str(name) //  &
312                       ". Expecting end of : " // str(oldname), &
313                       line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
314                  if (have_error_handler) then
315                     call error_handler(error_info)
316                  else
317                     call default_error_handler(error_info)
318                  endif
319               endif
320            endif
321         else if (fx%context == SINGLE_TAG) then
322            name = fx%element_name
323
324            if (fx%debug) print *, "We have found a single (empty) tag: ", &
325                                char(name)
326            !
327            ! Push name on to stack to reveal true xpath
328            !
329            call push_elstack(name,fx%element_stack)
330            if (have_empty_handler) then
331               if (fx%debug) print *, "--> calling empty_element_handler."
332               call empty_element_handler(str(name),fx%attributes)
333               call pop_elstack(fx%element_stack,dummy)
334            else
335               if (have_begin_handler) then
336                  if (fx%debug) print *, "--> calling begin_element_handler..."
337                  call begin_element_handler(str(name),fx%attributes)
338               endif
339               call pop_elstack(fx%element_stack,dummy)
340               if (have_end_handler) then
341                  if (fx%debug) print *, "--> ... and end_element_handler."
342                  call end_element_handler(str(name))
343               endif
344            endif
345!!            call pop_elstack(fx%element_stack,dummy)
346
347         else if (fx%context == CDATA_SECTION_TAG) then
348
349            if (fx%debug) print *, "We found a CDATA section"
350            if (is_empty(fx%element_stack)) then
351               if (fx%debug) print *, &
352                   "... Warning: CDATA section outside element context"
353            else
354               if (have_cdata_section_handler) then
355                  call cdata_section_handler(str(fx%pcdata))
356               else
357                  if (have_pcdata_handler) &
358                   call pcdata_chunk_handler(str(fx%pcdata))
359               endif
360            endif
361
362         else if (fx%context == COMMENT_TAG) then
363
364            if (fx%debug) print *, "We found a comment tag"
365            if (have_comment_handler)  &
366                 call comment_handler(str(fx%pcdata))
367
368         else if (fx%context == SGML_DECLARATION_TAG) then
369
370            if (fx%debug) print *, "We found an sgml declaration"
371            if (have_sgml_declaration_handler)  &
372                      call sgml_declaration_handler(str(fx%pcdata))
373
374         else if (fx%context == XML_DECLARATION_TAG) then
375
376            if (fx%debug) print *, "We found an XML declaration"
377            name = fx%element_name
378            if (have_xml_declaration_handler)  &
379                      call xml_declaration_handler(str(name),fx%attributes)
380
381         else
382
383            ! do nothing
384
385         endif
386
387      else if (signal == CHUNK_OF_PCDATA) then
388
389         if (fx%debug) print *, "We found a chunk of PCDATA"
390         if (is_empty(fx%element_stack)) then
391            if (fx%debug) print *, "... Warning: PCDATA outside element context"
392               ! Just a warning
393               call build_error_info(error_info, &
394                  "PCDATA outside of element context", &
395                  line(fb),column(fb),fx%element_stack,WARNING_CODE)
396               if (have_error_handler) then
397                  call error_handler(error_info)
398               else
399                  call default_error_handler(error_info)
400               endif
401         else
402            !
403            ! Replace entities by their value
404            !
405            call entity_filter(fx%pcdata,translated_pcdata,status,message)
406            if (status < 0) then
407               call build_error_info(error_info, message, &
408                  line(fb),-status,fx%element_stack,SEVERE_ERROR_CODE)
409               if (have_error_handler) then
410                  call error_handler(error_info)
411               else
412                  call default_error_handler(error_info)
413               endif
414            else if (status > 0) then
415               ! Just a warning
416               call build_error_info(error_info, message, &
417                  line(fb),status,fx%element_stack,WARNING_CODE)
418               if (have_error_handler) then
419                  call error_handler(error_info)
420               else
421                  call default_error_handler(error_info)
422               endif
423            else
424               if (have_pcdata_handler) &
425                   call pcdata_chunk_handler(str(translated_pcdata))
426            endif
427         endif
428
429      else if (signal == EXCEPTION) then
430         call build_error_info(error_info, fx%action, &
431                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
432         if (have_error_handler) then
433            call error_handler(error_info)
434         else
435            call default_error_handler(error_info)
436         endif
437      else
438         ! QUIET, do nothing
439      endif
440      if (signal /= QUIET) then
441         if (have_signal_handler) then
442            call signal_handler(pause_signal)
443            if (pause_signal) exit
444         endif
445      endif
446
447enddo
448
449end subroutine xml_parse
450
451!-----------------------------------------
452subroutine xml_path(fxml,path)
453type(xml_t), intent(in) :: fxml
454character(len=*), intent(out)  :: path
455
456call get_elstack_signature(fxml%fx%element_stack,path)
457
458end subroutine xml_path
459
460!-----------------------------------------
461subroutine xml_mark_path(fxml,path)
462!
463! Marks the current path
464!
465type(xml_t), intent(inout) :: fxml
466character(len=*), intent(out)  :: path
467
468call get_elstack_signature(fxml%fx%element_stack,fxml%path_mark)
469path = fxml%path_mark
470
471end subroutine xml_mark_path
472
473!-----------------------------------------
474subroutine xml_get_path_mark(fxml,path)
475!
476! Returns the currently markd path (or an empty string if there are no marks)
477!
478type(xml_t), intent(in)        :: fxml
479character(len=*), intent(out)  :: path
480
481path = fxml%path_mark
482
483end subroutine xml_get_path_mark
484
485!-----------------------------------------
486subroutine xml_name(fxml,name)
487type(xml_t), intent(in) :: fxml
488character(len=*), intent(out)  :: name
489
490name = char(fxml%fx%element_name)
491
492end subroutine xml_name
493!-----------------------------------------
494subroutine xml_attributes(fxml,attributes)
495type(xml_t), intent(in) :: fxml
496type(dictionary_t), intent(out)  :: attributes
497
498attributes = fxml%fx%attributes
499
500end subroutine xml_attributes
501
502end module m_xml_parser
503
504
505
506
Note: See TracBrowser for help on using the repository browser.