module m_xml_parser

!
! Basic module to parse XML in the SAX spirit.
!

use m_sax_buffer
use m_sax_reader
use m_sax_fsm
use m_sax_dictionary
use m_sax_debug
use m_xml_error
use m_sax_elstack          ! For element nesting checks
!
private

!
!  XML file handle
!
type, public :: xml_t
private
      type(file_buffer_t)  :: fb
      type(fsm_t)          :: fx
      character(len=200)   :: path_mark
      !
      ! error reporting section
      !
      type(xml_error_t)    :: error_info
end type xml_t

!
public :: xml_parse
public :: open_xmlfile, close_xmlfile
public :: endfile_xmlfile, rewind_xmlfile
public :: eof_xmlfile, sync_xmlfile
public :: xml_char_count
public :: xml_error_report
public :: xml_path, xml_mark_path, xml_get_path_mark
public :: xml_name, xml_attributes

CONTAINS  !=============================================================

subroutine open_xmlfile(fname,fxml,iostat,record_size)
  character(len=*), intent(in)      :: fname
  integer, intent(out)              :: iostat
  type(xml_t), intent(out)          :: fxml
  integer, intent(in), optional     :: record_size
  
  call open_file(fname,fxml%fb,iostat,record_size)
  call init_fsm(fxml%fx)
  call reset_error_info(fxml%error_info) 
  fxml%path_mark = ""
  
end subroutine open_xmlfile
!-------------------------------------------------------------------------

subroutine rewind_xmlfile(fxml)
  type(xml_t), intent(inout) :: fxml
  
  call rewind_file(fxml%fb)
  call reset_fsm(fxml%fx)
  call reset_error_info(fxml%error_info) 
  fxml%path_mark = ""
  
end subroutine rewind_xmlfile

!-----------------------------------------
subroutine endfile_xmlfile(fxml)
  type(xml_t), intent(inout) :: fxml

  call mark_eof_file(fxml%fb) 

end subroutine endfile_xmlfile

!-----------------------------------------
subroutine close_xmlfile(fxml)
  type(xml_t), intent(inout) :: fxml
  
  call close_file_buffer(fxml%fb)
  call reset_fsm(fxml%fx)         ! just in case
  call reset_error_info(fxml%error_info) ! ""
  fxml%path_mark = ""             ! ""

end subroutine close_xmlfile

!-----------------------------------------
subroutine sync_xmlfile(fxml,iostat)
  type(xml_t), intent(inout) :: fxml
  integer, intent(out)       :: iostat
  
  call sync_file(fxml%fb,iostat)
  ! Do not reset fx: that's the whole point of synching.
  
end subroutine sync_xmlfile

!----------------------------------------------------
function eof_xmlfile(fxml) result (res)
  type(xml_t), intent(in)          :: fxml
  logical                          :: res
  
  res = eof_file(fxml%fb)
  
end function eof_xmlfile
!
!----------------------------------------------------
!----------------------------------------------------
function xml_char_count(fxml) result (nc)
  type(xml_t), intent(in)          :: fxml
  integer                          :: nc
  nc = nchars_processed(fxml%fb)
end function xml_char_count
!
!----------------------------------------------------
subroutine xml_error_report(fxml,lun)
  type(xml_t), intent(in)          :: fxml
  integer, intent(in)              :: lun

  call print_error_report(fxml%error_info, lun)
  
end subroutine xml_error_report
!
!----------------------------------------------------
!

recursive subroutine xml_parse(fxml, begin_element_handler,    &
                           end_element_handler,      &
                           pcdata_chunk_handler,     &
                           comment_handler,          &
                           xml_declaration_handler,  &
                           cdata_section_handler,    &
                           sgml_declaration_handler, &
                           error_handler,            &
                           signal_handler,           &
                           verbose,                  &
                           empty_element_handler,    &
                           start_document_handler,   & 
                           end_document_handler,     &
                           stat)   

type(xml_t), intent(inout), target  :: fxml

optional                            :: begin_element_handler
optional                            :: end_element_handler
optional                            :: pcdata_chunk_handler
optional                            :: comment_handler
optional                            :: xml_declaration_handler
optional                            :: sgml_declaration_handler
optional                            :: cdata_section_handler
optional                            :: error_handler
optional                            :: signal_handler
logical, intent(in), optional       :: verbose
optional                            :: empty_element_handler
optional                            :: start_document_handler
optional                            :: end_document_handler
integer, intent(out), optional      :: stat

interface
   subroutine begin_element_handler(name,attributes)
   use m_sax_dictionary
   character(len=*), intent(in)     :: name
   type(dictionary_t), intent(in)   :: attributes
   end subroutine begin_element_handler

   subroutine end_element_handler(name)
   character(len=*), intent(in)     :: name
   end subroutine end_element_handler

   subroutine pcdata_chunk_handler(chunk)
   character(len=*), intent(in) :: chunk
   end subroutine pcdata_chunk_handler

   subroutine comment_handler(comment)
   character(len=*), intent(in) :: comment
   end subroutine comment_handler

   subroutine xml_declaration_handler(name,attributes)
   use m_sax_dictionary
   character(len=*), intent(in)     :: name
   type(dictionary_t), intent(in)   :: attributes
   end subroutine xml_declaration_handler

   subroutine sgml_declaration_handler(sgml_declaration)
   character(len=*), intent(in) :: sgml_declaration
   end subroutine sgml_declaration_handler

   subroutine cdata_section_handler(cdata)
   character(len=*), intent(in) :: cdata
   end subroutine cdata_section_handler

   subroutine error_handler(error_info)
   use m_xml_error
   type(xml_error_t), intent(in)            :: error_info
   end subroutine error_handler

   subroutine signal_handler(code)
   logical, intent(out) :: code
   end subroutine signal_handler

   subroutine empty_element_handler(name,attributes)
   use m_sax_dictionary
   character(len=*), intent(in)     :: name
   type(dictionary_t), intent(in)   :: attributes
   end subroutine empty_element_handler

   subroutine start_document_handler()   
   end subroutine start_document_handler 

   subroutine end_document_handler()     
   end subroutine end_document_handler   

end interface

character(len=1)     :: c
integer              :: iostat

integer              :: signal

type(buffer_t)       :: name, oldname, dummy

logical              :: have_begin_handler, have_end_handler, &
                        have_pcdata_handler, have_comment_handler, &
                        have_xml_declaration_handler, &
                        have_sgml_declaration_handler, &
                        have_cdata_section_handler, have_empty_handler, &
                        have_error_handler, have_signal_handler, &
                        have_start_document_handler, have_end_document_handler
logical              :: have_stat_argument
logical              :: return_flag
logical              :: pause_signal

type(file_buffer_t), pointer :: fb
type(fsm_t), pointer         :: fx

have_begin_handler = present(begin_element_handler)
have_end_handler = present(end_element_handler)
have_pcdata_handler = present(pcdata_chunk_handler)
have_comment_handler = present(comment_handler)
have_xml_declaration_handler = present(xml_declaration_handler)
have_sgml_declaration_handler = present(sgml_declaration_handler)
have_cdata_section_handler = present(cdata_section_handler)
have_error_handler = present(error_handler)
have_signal_handler = present(signal_handler)
have_empty_handler = present(empty_element_handler)
have_start_document_handler = present(start_document_handler)  
have_end_document_handler = present(end_document_handler)      

have_stat_argument = present(stat)

fb => fxml%fb
fx => fxml%fx
if (present(verbose)) then
   debug = verbose                 ! For m_converters
   fx%debug = verbose              ! job-specific flag
endif

if (fx%debug) print *, " Entering xml_parse..."
if (have_start_document_handler) call start_document_handler()

!---------------------------------------------------------------------
do
      call get_character(fb,c,iostat)

      if (iostat /= 0) then          ! End of file...
         if (.not. is_empty(fx%element_stack)) then
            call build_error_info(fxml%error_info, &
                 "Early end of file.", &
                 line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
            call process_error(return_flag); if (return_flag) RETURN
         endif
         if (have_end_document_handler) call end_document_handler()
         call endfile_xmlfile(fxml)  ! Mark it as eof
         EXIT
      endif

      call evolve_fsm(fx,c,signal)

      if (fx%debug) print *, c, " ::: ", trim(fx%action)

      if (signal == END_OF_TAG) then
         !
         ! We decide whether we have ended an opening tag or a closing tag
         !
         if (fx%context == OPENING_TAG) then
            name = fx%element_name

            if (fx%debug) print *, "We have found an opening tag"
            if (fx%root_element_seen) then
               if (name .equal. fx%root_element_name) then
                  call build_error_info(fxml%error_info, &
                  "Duplicate root element: " // str(name), &
                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
                  call process_error(return_flag); if (return_flag) RETURN
               endif
               if (is_empty(fx%element_stack)) then
                  call build_error_info(fxml%error_info, &
                  "Opening tag beyond root context: " // str(name), &
                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
                  call process_error(return_flag); if (return_flag) RETURN
               endif
            else
               fx%root_element_name = name
               fx%root_element_seen = .true.
            endif
            call push_elstack(name,fx%element_stack)
            if (have_begin_handler) &
                call begin_element_handler(str(name),fx%attributes)

         else if (fx%context == CLOSING_TAG) then
            name = fx%element_name
         
            if (fx%debug) print *, "We have found a closing tag"
            if (is_empty(fx%element_stack)) then
               call build_error_info(fxml%error_info, &
                  "Nesting error: End tag: " // str(name) //  &
                  " does not match -- too many end tags", &
                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
               call process_error(return_flag); if (return_flag) RETURN
            else
               call get_top_elstack(fx%element_stack,oldname)
               if (oldname .equal. name) then
                  call pop_elstack(fx%element_stack,oldname)
                  if (have_end_handler) call end_element_handler(str(name))
!!                  call pop_elstack(fx%element_stack,oldname)
               else
                  call build_error_info(fxml%error_info, &
                       "Nesting error: End tag: " // str(name) //  &
                       ". Expecting end of : " // str(oldname), &
                       line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
                  call process_error(return_flag); if (return_flag) RETURN
               endif
            endif
         else if (fx%context == SINGLE_TAG) then
            name = fx%element_name

            if (fx%debug) print *, "We have found a single (empty) tag: ", &
                                str(name)
            !
            ! Push name on to stack to reveal true xpath
            !
            call push_elstack(name,fx%element_stack)
            if (have_empty_handler) then
               if (fx%debug) print *, "--> calling empty_element_handler."
               call empty_element_handler(str(name),fx%attributes)
               call pop_elstack(fx%element_stack,dummy)
            else
               if (have_begin_handler) then
                  if (fx%debug) print *, "--> calling begin_element_handler..."
                  call begin_element_handler(str(name),fx%attributes)
               endif
               call pop_elstack(fx%element_stack,dummy)
               if (have_end_handler) then
                  if (fx%debug) print *, "--> ... and end_element_handler."
                  call end_element_handler(str(name))
               endif
            endif
!!            call pop_elstack(fx%element_stack,dummy)

         else if (fx%context == CDATA_SECTION_TAG) then

            ! Should not be reached
            if (fx%debug) print *, "We found a CDATA section"
            if (is_empty(fx%element_stack)) then
               if (fx%debug) print *, &
                    "... Warning: CDATA section outside element context"
            endif
            if (have_cdata_section_handler) then
               call cdata_section_handler(str(fx%pcdata))
            else if (have_pcdata_handler) then
               if (fx%debug) print *, &
                    "... Warning: CDATA section chunk processed as pcdata"
               call pcdata_chunk_handler(str(fx%pcdata))
            endif

         else if (fx%context == COMMENT_TAG) then
            ! It might overflow for long comments
            if (fx%debug) print *, "We found a comment tag"
            if (have_comment_handler)  &
                 call comment_handler(str(fx%pcdata))

         else if (fx%context == SGML_DECLARATION_TAG) then

            if (fx%debug) print *, "We found an sgml declaration"
            if (have_sgml_declaration_handler)  &
                      call sgml_declaration_handler(str(fx%pcdata))

         else if (fx%context == XML_DECLARATION_TAG) then

            if (fx%debug) print *, "We found an XML declaration"
            name = fx%element_name
            if (have_xml_declaration_handler)  &
                      call xml_declaration_handler(str(name),fx%attributes)

         else

            ! do nothing

         endif

      else if (signal == CHUNK_OF_PCDATA) then

         if (fx%debug) print *, "We found a chunk of PCDATA"
         if (is_empty(fx%element_stack)) then
            if (fx%debug) print *, "... Warning: PCDATA outside element context"
            ! Just a warning
            call build_error_info(fxml%error_info, &
                 "PCDATA outside of element context", &
                 line(fb),column(fb),fx%element_stack,WARNING_CODE)
            call process_error(return_flag); if (return_flag) RETURN
         else
            if (have_pcdata_handler) &
                 call pcdata_chunk_handler(str(fx%pcdata))
         endif

      else if (signal == CHUNK_OF_CDATA_SECTION) then

         if (fx%debug) print *, "We found a chunk of CDATA"
         if (is_empty(fx%element_stack)) then
            if (fx%debug) print *, "... Warning: CDATA outside element context"
            ! Just a warning
            call build_error_info(fxml%error_info, &
                 "CDATA outside of element context", &
                 line(fb),column(fb),fx%element_stack,WARNING_CODE)
            call process_error(return_flag); if (return_flag) RETURN
         else
            if (have_cdata_section_handler) then
               call cdata_section_handler(str(fx%pcdata))
            ! Note that this will replace entities!
            else if (have_pcdata_handler) then
               if (fx%debug) print *, &
                    "... Warning: CDATA section chunk processed as pcdata"
               call pcdata_chunk_handler(str(fx%pcdata))
            endif
         endif

      else if (signal == EXCEPTION) then
         call build_error_info(fxml%error_info, fx%action, &
                  line(fb),column(fb),fx%element_stack,SEVERE_ERROR_CODE)
         call process_error(return_flag); if (return_flag) RETURN
      else
         ! QUIET, do nothing
      endif
      ! FIXME: Clarify intent, and fix type bug in argument of signal_handler
      if (signal /= QUIET) then
         if (have_signal_handler) then
            call signal_handler(pause_signal)
            if (pause_signal) exit
         endif
      endif

enddo

CONTAINS

  subroutine process_error(return_flag)
    logical, intent(out) :: return_flag

    ! This flag, if .true., will make the parser return to
    ! the caller with a 'stat' code and information in fx
    !
    return_flag = .false.
    if (have_stat_argument) then
       stat = 0
       if (fxml%error_info%severity == SEVERE_ERROR_CODE) then
          stat = -2
          return_flag = .true.
       endif
    else
       if (have_error_handler) then
          call error_handler(fxml%error_info)
       else
          call default_error_handler(fxml%error_info)
       endif
    endif
  end subroutine process_error
  
end subroutine xml_parse

!-----------------------------------------
subroutine xml_path(fxml,path)
  type(xml_t), intent(in) :: fxml
  character(len=*), intent(out)  :: path
  
  call get_elstack_signature(fxml%fx%element_stack,path)
  
end subroutine xml_path

!-----------------------------------------
subroutine xml_mark_path(fxml,path)
  !
  ! Marks the current path
  !
  type(xml_t), intent(inout) :: fxml
  character(len=*), intent(out)  :: path
  
  call get_elstack_signature(fxml%fx%element_stack,fxml%path_mark)
  path = fxml%path_mark
  
end subroutine xml_mark_path

!-----------------------------------------
subroutine xml_get_path_mark(fxml,path)
  !
  ! Returns the currently markd path (or an empty string if there are no marks)
  !
  type(xml_t), intent(in)        :: fxml
  character(len=*), intent(out)  :: path
  
  path = fxml%path_mark
  
end subroutine xml_get_path_mark

!-----------------------------------------
subroutine xml_name(fxml,name)
  type(xml_t), intent(in) :: fxml
  character(len=*), intent(out)  :: name
  
  name = str(fxml%fx%element_name)
  
end subroutine xml_name
!-----------------------------------------
subroutine xml_attributes(fxml,attributes)
  type(xml_t), intent(in) :: fxml
  type(dictionary_t), intent(out)  :: attributes
  
  attributes = fxml%fx%attributes
  
end subroutine xml_attributes

end module m_xml_parser




