Permalink
Fetching contributors…
Cannot retrieve contributors at this time
502 lines (421 sloc) 12.9 KB
module m_common_namecheck
#ifndef DUMMYLIB
! These are basically a collection of what would be regular
! expressions in a more sensible language.
! The only external dependency should be knowing how these
! regular expressions may differ between XML-1.0 and 1.1 (which
! is only in the areas of
! 1: allowing character entity references to control characters
! 2: More characters allowed in Names (but this only affects
! unicode-aware programs, so is only skeleton here)
use fox_m_fsys_format, only: str_to_int_10, str_to_int_16, operator(//)
use fox_m_fsys_string, only: toLower
use m_common_charset, only: isLegalCharRef, isNCNameChar, &
isInitialNCNameChar, isInitialNameChar, isNameChar, isRepCharRef
implicit none
private
character(len=*), parameter :: lowerCase = "abcdefghijklmnopqrstuvwxyz"
character(len=*), parameter :: upperCase = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
character(len=*), parameter :: letters = lowerCase//upperCase
character(len=*), parameter :: digits = "0123456789"
character(len=*), parameter :: hexdigits = "0123456789abcdefABCDEF"
character(len=*), parameter :: NameChars = lowerCase//upperCase//digits//".-_:"
public :: checkName
public :: checkNames
public :: checkQName
public :: checkQNames
public :: checkNmtoken
public :: checkNmtokens
public :: checkNCName
public :: checkNCNames
public :: checkEncName
public :: checkPITarget
public :: checkPublicId
public :: checkPEDef
public :: checkPseudoAttValue
public :: checkAttValue
public :: checkCharacterEntityReference
public :: checkRepCharEntityReference
public :: likeCharacterEntityReference
public :: prefixOfQName
public :: localpartOfQName
contains
pure function checkEncName(name) result(good)
![81] EncName ::= [A-Za-z] ([A-Za-z0-9._] | '-')*
character(len=*), intent(in) :: name
logical :: good
integer :: n
n = len(name)
good = (n > 0)
if (good) good = (scan(name(1:1), letters) /= 0)
if (good .and. n > 1) &
good = (verify(name(2:), letters//digits//'.-_') == 0)
end function checkEncName
function checkPITarget(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for a NAME
! Is not fully compliant; ignores UTF issues.
good = checkName(name, xv) &
.and.toLower(name)/="xml"
end function checkPITarget
pure function checkName(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for a NAME
! Is not fully compliant; ignores UTF issues.
good = (len(name) > 0)
if (.not.good) return
if (good) good = isInitialNameChar(name(1:1), xv)
if (.not.good.or.len(name)==1) return
good = isNameChar(name(2:), xv)
end function checkName
pure function checkNames(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the production for NAMES
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = checkName(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkNames
pure function checkQName(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for a NAME
! Is not fully compliant; ignores UTF issues.
integer :: n
n = index(name, ':')
if (n == 0) then
good = checkNCName(name, xv)
else
good = (checkNCName(name(:n-1), xv) .and. checkNCName(name(n+1:), xv))
endif
end function checkQName
pure function checkQNames(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the production for NAMES
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = checkQName(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkQNames
pure function checkNCName(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for an NCNAME
! Is not fully compliant; ignores UTF issues.
good = (len(name)/=0)
if (.not.good) return
good = isInitialNCNameChar(name(1:1), xv)
if (.not.good.or.len(name)==1) return
good = isNCNameChar(name(2:), xv)
end function checkNCName
pure function checkNCNames(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the production for NAMES
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = checkNCName(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkNCNames
pure function checkNmtoken(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for an NCNAME
! Is not fully compliant; ignores UTF issues.
good = isNameChar(name, xv)
end function checkNmtoken
pure function checkNmtokens(name, xv) result(good)
character(len=*), intent(in) :: name
integer, intent(in) :: xv
logical :: good
! Validates a string against the XML requirements for an NCNAME
! Is not fully compliant; ignores UTF issues.
integer :: i, j
good = (len(name) > 0)
if (.not.good) return
i = verify(name, " ")
if (i==0) then
good = .false.
return
endif
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
do
good = isNameChar(name(i:j), xv)
if (.not.good) return
i = j + 1
j = verify(name(i:), " ")
if (j==0) exit
i = i + j - 1
j = scan(name(i:), " ")
if (j==0) then
j = len(name)
else
j = i + j - 2
endif
enddo
end function checkNmtokens
function checkPublicId(value) result(good)
character(len=*), intent(in) :: value
logical :: good
character(len=*), parameter :: PubIdChars = &
" "//achar(10)//achar(13)//lowerCase//upperCase//digits//"-'()+,./:=?;!*#@$_%"
good = (verify(value, PubIdChars)==0)
end function checkPublicId
function checkPEDef(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
integer :: i1, i2
p = .false.
if (scan(value, '%&')==0) then
p = .true.
elseif (scan(value, '"')==0) then
i1 = scan(value, '%&')
i2 = 0
do while (i1>0)
i1 = i2 + i1
i2 = index(value(i1+1:),';')
if (i2==0) return
i2 = i1 + i2
if (value(i1:i1)=='&') then
if (.not.checkName(value(i1+1:i2-1), xv) .and. &
.not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) return
else
if (.not.checkName(value(i1+1:i2-1), xv)) &
return
endif
i1 = scan(value(i2+1:), '%&')
enddo
p = .true.
endif
end function checkPEDef
function checkPseudoAttValue(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
integer :: i1, i2
!fixme can we have entrefs in PIs?
p = .false.
if (scan(value, '"<&')==0) then
p = .true.
elseif (index(value, '&') > 0) then
i1 = index(value, '&')
i2 = 0
do while (i1 > 0)
i1 = i2 + i1
i2 = index(value(i1+1:),';')
if (i2==0) return
i2 = i1 + i2
if (value(i1+1:i2-1) /= 'amp' .and. &
value(i1+1:i2-1) /= 'lt' .and. &
value(i1+1:i2-1) /= 'gt' .and. &
value(i1+1:i2-1) /= 'quot' .and. &
value(i1+1:i2-1) /= 'apos' .and. &
.not.checkCharacterEntityReference(value(i1+1:i2-1), xv)) &
return
i1 = index(value(i2+1:), '&')
enddo
p = .true.
endif
end function checkPseudoAttValue
function checkAttValue(value, xv) result(p)
character(len=*), intent(in) :: value
integer, intent(in) :: xv
logical :: p
! This function is called basically to make sure
! that any attribute value looks like one. It will
! not flag up out-of-range character entities, and
! is a very weak check. Only used from xml_AddAttribute
! when escaping is off.
integer :: i1, i2
p = .false.
if (scan(value, '"<&'//"'")==0) then
p = .true.
elseif (index(value, '&') > 0) then
i1 = index(value, '&')
i2 = 0
do while (i1 > 0)
i1 = i1 + i2 + 1
i2 = scan(value(i1+1:),';')
if (i2 == 0) return
i2 = i1 + i2
if (.not.checkName(value(i1+1:i2-1), xv) .and. &
.not.likeCharacterEntityReference(value(i1+1:i2-1))) then
print*, value(i1+1:i2-1), " ", &
likeCharacterEntityReference(value(i1+1:i2-1))
return
endif
i1 = index(value(i2+1:), '&')
enddo
p = .true.
endif
end function checkAttValue
function likeCharacterEntityReference(code) result(good)
character(len=*), intent(in) :: code
logical :: good
good = .false.
if (len(code) > 0) then
if (code(1:1) == "#") then
if (code(2:2) == "x") then
if (len(code) > 2) then
good = (verify(code(3:), hexdigits) == 0)
endif
else
good = (verify(code(2:), digits) == 0)
endif
endif
endif
end function likeCharacterEntityReference
function checkCharacterEntityReference(code, xv) result(good)
character(len=*), intent(in) :: code
integer, intent(in) :: xv
logical :: good
integer :: i
good = .false.
if (len(code) > 0) then
if (code(1:1) == "#") then
if (code(2:2) == "x") then
if (len(code) > 2) then
good = (verify(code(3:), hexdigits) == 0)
if (good) then
i = str_to_int_16(code(3:))
endif
endif
else
good = (verify(code(2:), digits) == 0)
if (good) then
i = str_to_int_10(code(2:))
endif
endif
endif
endif
if (good) good = isLegalCharRef(i, xv)
end function checkCharacterEntityReference
function checkRepCharEntityReference(code, xv) result(good)
character(len=*), intent(in) :: code
integer, intent(in) :: xv
logical :: good
! Is this a reference to a character we can actually represent
! in memory? ie without unicode, US-ASCII only.
integer :: i
good = .false.
if (len(code) > 0) then
if (code(1:1) == "#") then
if (code(2:2) == "x") then
if (len(code) > 2) then
good = (verify(code(3:), hexdigits) == 0)
if (good) then
i = str_to_int_16(code(3:))
endif
endif
else
good = (verify(code(2:), digits) == 0)
if (good) then
i = str_to_int_10(code(2:))
endif
endif
endif
endif
if (good) good = isRepCharRef(i, xv)
end function checkRepCharEntityReference
pure function prefixOfQName(qname) result(prefix)
character(len=*), intent(in) :: qname
character(len=max(index(qname, ':')-1,0)) :: prefix
prefix = qname ! automatic truncation
end function prefixOfQName
pure function localpartOfQname(qname) result(localpart)
character(len=*), intent(in) :: qname
character(len=max(len(qname)-index(qname,':'),0)) ::localpart
localpart = qname(index(qname,':')+1:)
end function localpartOfQname
#endif
end module m_common_namecheck