Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

412 lines (326 sloc) 10.928 kB
module m_sax_reader
#ifndef DUMMYLIB
use fox_m_fsys_array_str, only: str_vs, vs_str_alloc, vs_vs_alloc
use fox_m_fsys_format, only: operator(//)
use m_common_charset, only: XML1_0
use m_common_error, only: error_stack, FoX_error, in_error, add_error
use m_common_io, only: setup_io, get_unit, io_err
use FoX_utils, only: URI, parseURI, copyURI, destroyURI, &
hasScheme, getScheme, getPath
use m_sax_xml_source, only: xml_source_t, &
get_char_from_file, push_file_chars, parse_declaration
implicit none
private
type file_buffer_t
!FIXME private
type(xml_source_t), pointer :: f(:) => null()
logical :: standalone = .false.
integer :: xml_version = XML1_0
end type file_buffer_t
public :: file_buffer_t
public :: line
public :: column
public :: add_error_position
public :: open_file
public :: close_file
public :: open_new_file
public :: push_chars
public :: get_character
public :: get_all_characters
public :: open_new_string
public :: pop_buffer_stack
public :: parse_xml_declaration
public :: parse_text_declaration
public :: reading_main_file
public :: reading_first_entity
contains
subroutine open_file(fb, iostat, file, lun, string, es)
type(file_buffer_t), intent(out) :: fb
character(len=*), intent(in), optional :: file
integer, intent(out) :: iostat
integer, intent(in), optional :: lun
character(len=*), intent(in), optional :: string
type(error_stack), intent(inout) :: es
type(URI), pointer :: fileURI
iostat = 0
call setup_io()
if (present(string)) then
if (present(file)) then
call FoX_error("Cannot specify both file and string input to open_xml")
elseif (present(lun)) then
call FoX_error("Cannot specify lun for string input to open_xml")
endif
fileURI => parseURI("")
call open_new_string(fb, string, "", baseURI=fileURI)
else
fileURI => parseURI(file)
if (.not.associated(fileURI)) then
call add_error(es, "Could not open file "//file//" - not a valid URI")
iostat=1
return
endif
call open_new_file(fb, fileURI, iostat, lun)
endif
call destroyURI(fileURI)
end subroutine open_file
subroutine open_new_file(fb, baseURI, iostat, lun, pe)
type(file_buffer_t), intent(inout) :: fb
integer, intent(out) :: iostat
type(URI), pointer :: baseURI
integer, intent(in), optional :: lun
logical, intent(in), optional :: pe
integer :: i
type(xml_source_t) :: f
type(xml_source_t), pointer :: temp(:)
logical :: pe_
if (present(pe)) then
pe_ = pe
else
pe_ = .false.
endif
if (hasScheme(baseURI)) then
if (getScheme(baseURI)/="file") then
iostat = io_err
return
endif
endif
call open_actual_file(f, getPath(baseURI), iostat, lun)
if (iostat==0) then
if (.not.associated(fb%f)) allocate(fb%f(0))
! First file
temp => fb%f
allocate(fb%f(size(temp)+1))
do i = 1, size(temp)
fb%f(i+1)%lun = temp(i)%lun
fb%f(i+1)%xml_version = temp(i)%xml_version
fb%f(i+1)%encoding => temp(i)%encoding
fb%f(i+1)%filename => temp(i)%filename
fb%f(i+1)%line = temp(i)%line
fb%f(i+1)%col = temp(i)%col
fb%f(i+1)%startChar = temp(i)%startChar
fb%f(i+1)%next_chars => temp(i)%next_chars
fb%f(i+1)%input_string => temp(i)%input_string
fb%f(i+1)%baseURI => temp(i)%baseURI
fb%f(i+1)%pe = temp(i)%pe
enddo
deallocate(temp)
fb%f(1)%lun = f%lun
fb%f(1)%filename => f%filename
if (pe_) then
fb%f(1)%next_chars => vs_str_alloc(" ")
else
fb%f(1)%next_chars => vs_str_alloc("")
endif
fb%f(1)%pe = pe_
fb%f(1)%baseURI => copyURI(baseURI)
endif
end subroutine open_new_file
subroutine open_actual_file(f, file, iostat, lun)
type(xml_source_t), intent(out) :: f
character(len=*), intent(in) :: file
integer, intent(out) :: iostat
integer, intent(in), optional :: lun
if (present(lun)) then
f%lun = lun
else
call get_unit(f%lun, iostat)
if (iostat/=0) return
endif
open(unit=f%lun, file=file, form="formatted", status="old", &
action="read", position="rewind", iostat=iostat)
if (iostat/=0) return
f%filename => vs_str_alloc(file)
end subroutine open_actual_file
subroutine close_file(fb)
type(file_buffer_t), intent(inout) :: fb
integer :: i
do i = 1, size(fb%f)
call close_actual_file(fb%f(i))
enddo
if (associated(fb%f)) deallocate(fb%f)
end subroutine close_file
subroutine close_actual_file(f)
type(xml_source_t), intent(inout) :: f
deallocate(f%filename)
if (f%lun>0) then
close(f%lun)
else
deallocate(f%input_string%s)
deallocate(f%input_string)
endif
if (associated(f%encoding)) deallocate(f%encoding)
f%line = 0
f%col = 0
deallocate(f%next_chars)
call destroyURI(f%baseURI)
end subroutine close_actual_file
subroutine open_new_string(fb, string, name, baseURI, pe)
type(file_buffer_t), intent(inout) :: fb
character(len=*), intent(in) :: string
character(len=*), intent(in) :: name
type(URI), pointer :: baseURI
logical, intent(in), optional :: pe
integer :: i
type(xml_source_t), pointer :: temp(:)
logical :: pe_
if (present(pe)) then
pe_ = pe
else
pe_ = .false.
endif
if (.not.associated(fb%f)) allocate(fb%f(0))
temp => fb%f
allocate(fb%f(size(temp)+1))
do i = 1, size(temp)
fb%f(i+1)%lun = temp(i)%lun
fb%f(i+1)%xml_version = temp(i)%xml_version
fb%f(i+1)%encoding => temp(i)%encoding
fb%f(i+1)%filename => temp(i)%filename
fb%f(i+1)%line = temp(i)%line
fb%f(i+1)%col = temp(i)%col
fb%f(i+1)%startChar = temp(i)%startChar
fb%f(i+1)%next_chars => temp(i)%next_chars
fb%f(i+1)%input_string => temp(i)%input_string
fb%f(i+1)%baseURI => temp(i)%baseURI
fb%f(i+1)%pe = temp(i)%pe
enddo
deallocate(temp)
allocate(fb%f(1)%input_string)
fb%f(1)%filename => vs_str_alloc(name)
fb%f(1)%input_string%s => vs_str_alloc(string)
if (pe_) then
fb%f(1)%next_chars => vs_str_alloc(" ")
else
fb%f(1)%next_chars => vs_str_alloc("")
endif
fb%f(1)%pe = pe_
if (associated(baseURI)) then
fb%f(1)%baseURI => copyURI(baseURI)
else
fb%f(1)%baseURI => copyURI(fb%f(2)%baseURI)
endif
end subroutine open_new_string
subroutine pop_buffer_stack(fb)
type(file_buffer_t), intent(inout) :: fb
integer :: i
type(xml_source_t), pointer :: temp(:)
call close_actual_file(fb%f(1))
temp => fb%f
allocate(fb%f(size(temp)-1))
do i = 1, size(temp)-1
fb%f(i)%lun = temp(i+1)%lun
fb%f(i)%xml_version = temp(i+1)%xml_version
fb%f(i)%encoding => temp(i+1)%encoding
fb%f(i)%filename => temp(i+1)%filename
fb%f(i)%line = temp(i+1)%line
fb%f(i)%col = temp(i+1)%col
fb%f(i)%startChar = temp(i+1)%startChar
fb%f(i)%next_chars => temp(i+1)%next_chars
fb%f(i)%input_string => temp(i+1)%input_string
fb%f(i)%baseURI => temp(i+1)%baseURI
fb%f(i)%pe = temp(i+1)%pe
enddo
deallocate(temp)
end subroutine pop_buffer_stack
subroutine push_chars(fb, s)
type(file_buffer_t), intent(inout) :: fb
character(len=*), intent(in) :: s
call push_file_chars(fb%f(1), s)
end subroutine push_chars
function get_character(fb, eof, es) result(string)
type(file_buffer_t), intent(inout) :: fb
logical, intent(out) :: eof
type(error_stack), intent(inout) :: es
character(len=1) :: string
type(xml_source_t), pointer :: f
character, pointer :: temp(:)
f => fb%f(1)
if (size(f%next_chars)>0) then
eof = .false.
string = f%next_chars(1)
if (size(f%next_chars)>1) then
temp => vs_str_alloc(str_vs(f%next_chars(2:)))
else
temp => vs_str_alloc("")
endif
deallocate(f%next_chars)
f%next_chars => temp
else
string = get_char_from_file(f, fb%xml_version, eof, es)
endif
end function get_character
function get_all_characters(fb, es) result(s)
type(file_buffer_t), intent(inout) :: fb
type(error_stack), intent(inout) :: es
character, pointer :: s(:)
logical :: eof
character :: c
character, pointer :: temp(:)
eof = .false.
s => vs_str_alloc("")
do while (.not.eof)
c = get_character(fb, eof, es)
if (eof.or.in_error(es)) return
temp => vs_str_alloc(str_vs(s)//c)
deallocate(s)
s => temp
enddo
end function get_all_characters
function line(fb) result(n)
type(file_buffer_t), intent(in) :: fb
integer :: n
n = fb%f(1)%line
end function line
function column(fb) result(n)
type(file_buffer_t), intent(in) :: fb
integer :: n
n = fb%f(1)%col
end function column
subroutine parse_xml_declaration(fb, xv, enc, sa, es)
type(file_buffer_t), intent(inout) :: fb
integer, intent(out) :: xv
character, pointer :: enc(:)
logical, intent(out) :: sa
type(error_stack), intent(inout) :: es
logical :: eof
call parse_declaration(fb%f(1), eof, es, sa)
if (eof.or.in_error(es)) then
call add_error(es, "Error parsing XML declaration")
else
fb%xml_version = fb%f(1)%xml_version
xv = fb%xml_version
enc => vs_vs_alloc(fb%f(1)%encoding)
endif
end subroutine parse_xml_declaration
subroutine parse_text_declaration(fb, es)
type(file_buffer_t), intent(inout) :: fb
type(error_stack), intent(inout) :: es
logical :: eof
integer :: xv
xv = fb%f(size(fb%f))%xml_version
call parse_declaration(fb%f(1), eof, es)
if (in_error(es)) then
call add_error(es, "Error parsing text declaration")
return
elseif (xv==XML1_0.and.fb%f(1)%xml_version/=XML1_0) then
call add_error(es, "XML 1.0 document cannot reference entities with higher version numbers")
return
endif
end subroutine parse_text_declaration
function reading_main_file(fb) result(p)
type(file_buffer_t), intent(in) :: fb
logical :: p
p = (size(fb%f)==1)
end function reading_main_file
function reading_first_entity(fb) result(p)
type(file_buffer_t), intent(in) :: fb
logical :: p
p = (size(fb%f)==2)
end function reading_first_entity
subroutine add_error_position(stack, fb)
type(error_stack), intent(inout) :: stack
type(file_buffer_t), intent(in) :: fb
call add_error(stack,"(Possibly near line="//line(fb)//" col="//column(fb)//")")
end subroutine add_error_position
#endif
end module m_sax_reader
Jump to Line
Something went wrong with that request. Please try again.